#' @inheritParams grid::curveGrob
#' @export
#' @rdname geom_segment
geom_curve <- function(mapping = NULL, data = NULL,
                       stat = "identity", position = "identity",
                       ...,
                       curvature = 0.5,
                       angle = 90,
                       ncp = 5,
                       arrow = NULL,
                       arrow.fill = NULL,
                       lineend = "butt",
                       na.rm = FALSE,
                       show.legend = NA,
                       inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomCurve,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list2(
      arrow = arrow,
      arrow.fill = arrow.fill,
      curvature = curvature,
      angle = angle,
      ncp = ncp,
      lineend = lineend,
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @include geom-segment.r
#' @format NULL
#' @usage NULL
#' @export
GeomCurve <- ggproto("GeomCurve", GeomSegment,
  default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),
  draw_panel = function(data, panel_params, coord, curvature = 0.5, angle = 90,
                        ncp = 5, arrow = NULL, arrow.fill = NULL, lineend = "butt", na.rm = FALSE) {

    if (!coord$is_linear()) {
      cli::cli_warn("{.fn geom_curve} is not implemented for non-linear coordinates")
    }

    trans <- coord$transform(data, panel_params)

    arrow.fill <- arrow.fill %||% trans$colour

    curveGrob(
      trans$x, trans$y, trans$xend, trans$yend,
      default.units = "native",
      curvature = curvature, angle = angle, ncp = ncp,
      square = FALSE, squareShape = 1, inflect = FALSE, open = TRUE,
      gp = gpar(
        col = alpha(trans$colour, trans$alpha),
        fill = alpha(arrow.fill, trans$alpha),
        lwd = trans$size * .pt,
        lty = trans$linetype,
        lineend = lineend),
      arrow = arrow
    )
  }
)


Scythian<-read.csv("~/Dropbox/Courses/Popgen_teaching_Notes/Journal_figs/genetic_drift/Scythian_horses/Scythian_horses.csv",as.is=TRUE)

Scythian<-Scythian[Scythian$pop %in% c("Berel","Nordic"),]

my.bars<-barplot(pi~pop+locus, data=Scythian,beside=TRUE,cex.names=1.5,cex.lab=1.8,cex.axis=1.3,xlab="",ylab=expression(pi),
        legend.text = c("Scythian","Modern"),args.legend=list(cex=1.5)
)

pi.ratios<-Scythian[Scythian$pop=="Nordic","pi"]/Scythian[Scythian$pop=="Berel","pi"]
names(pi.ratios)<-Scythian$locus[1:4]
pi.ratios<-pi.ratios[c("auto","mtDNA","X","Y")]
text(x=my.bars[2,]+0.2,y=Scythian[Scythian$pop=="Nordic","pi"][c(2,1,3,4)]+1e-4,format(pi.ratios,dig=2),cex=1.4)
dev.copy2pdf(file="Dropbox/Courses/Popgen_teaching_Notes/Journal_figs/genetic_drift/Scythian_horses/Scythian_horses.pdf")


# Listing 4-0
# This is for the R code in the chapter
# set working directory to chapter location
# (change for where you set up files in ch 2)
setwd("~/book/ch04")
# make sure the packages for this chapter
# are installed, install if necessary
pkg <- c("bitops", "ggplot2", "mapproj", "stringr", "maps",
         "grid", "gridExtra", "RColorBrewer", "igraph",
         "colorspace", "scales", "stringr", "reshape2")
new.pkg <- pkg[!(pkg %in% installed.packages())]
if (length(new.pkg)) {
  install.packages(new.pkg)
}

# Listing 4-1
# requires packages: bitops
library(bitops) # load the bitops functions

# Define functions for converting IP addresses to/from integers
# take an IP address string in dotted octets (e.g. "192.168.0.1")
# and convert it to a 32-bit long integer (e.g. 3232235521)
ip2long <- function(ip) {
  # convert string into vector of characters
  ips <- unlist(strsplit(ip, '.', fixed=TRUE))
  # set up a function to bit-shift, then "OR" the octets
  octet <- function(x,y) bitOr(bitShiftL(x, 8), y)
  # Reduce applys a function cumulatively left to right
  Reduce(octet, as.integer(ips))
}

# take an 32-bit integer IP address (e.g. 3232235521)
# and convert it to a (e.g. "192.168.0.1").
long2ip <- function(longip) {
  # set up reversing bit manipulation
  octet <- function(nbits) bitAnd(bitShiftR(longip, nbits), 0xFF)
  # Map applys a function to each element of the argument
  # paste converts arguments to character and concatenates them
  paste(Map(octet, c(24,16,8,0)), sep="", collapse=".")
}

long2ip(ip2long("192.168.0.0"))
## [1] "192.168.0.0"
long2ip(ip2long("192.168.100.6"))
## [1] "192.168.100.6"

# Listing 4-2
# requires packages: bitops
# requires all objects from 4-1
# Define function to test for IP CIDR membership
# take an IP address (string) and a CIDR (string) and
# return whether the given IP address is in the CIDR range
ip.is.in.cidr <- function(ip, cidr) {
  long.ip <- ip2long(ip)
  cidr.parts <- unlist(strsplit(cidr, "/"))
  cidr.range <- ip2long(cidr.parts[1])
  cidr.mask <- bitShiftL(bitFlip(0), (32-as.integer(cidr.parts[2])))
  return(bitAnd(long.ip, cidr.mask) == bitAnd(cidr.range, cidr.mask))
}

ip.is.in.cidr("10.0.1.15","10.0.1.3/24")
## TRUE
ip.is.in.cidr("10.0.1.15","10.0.2.255/24")
## FALSE

# Listing 4-3
# R code to extract longitude/latitude pairs from AlienVault data
# read in the AlienVault reputation data
avRep <- "data/reputation.data"
av.df <- read.csv(avRep, sep="#", header=FALSE)
colnames(av.df) <- c("IP", "Reliability", "Risk", "Type",
                     "Country", "Locale", "Coords", "x")

# create a vector of lat/long data by splitting on ","
av.coords.vec <- unlist(strsplit(as.character(av.df$Coords), ","))
# convert the vector in a 2-column matrix
av.coords.mat <- matrix(av.coords.vec, ncol=2, byrow=TRUE)
# project into a data frame
av.coords.df <- as.data.frame(av.coords.mat)
# name the columns
colnames(av.coords.df) <- c("lat","long")
# convert the characters to numeric values
av.coords.df$long <- as.double(as.character(av.coords.df$long))
av.coords.df$lat <- as.double(as.character(av.coords.df$lat))

# Listing 4-4
# requires packages: ggplot2, maps, RColorBrewer, scales
# requires object: av.coords.df (4-3)
# generates Figure 4-2
# R code to extract longitude/latitude pairs from AlienVault data
# need plotting and mapping functions plus colors
library(ggplot2)
library(maps)
library(RColorBrewer)
library(scales)

# extract a color palette from the RColorBrewer package
set2 <- brewer.pal(8,"Set2")

# extract the polygon information for the world map, minus Antarctica
world <- map_data('world')
world <- subset(world, region != "Antarctica")

# plot the map with the points marking lat/lon of the geocoded entries
# plotting ~200K takes a bit of time
# Chapter 5 examples explain mapping in greater detail
gg <- ggplot()
gg <- gg + geom_polygon(data=world, aes(long, lat, group=group),
                        fill="white")
gg <- gg + geom_point(data=av.coords.df, aes(x=long, y=lat),
                      color=set2[2], size=1, alpha=0.1)
gg <- gg + labs(x="", y="")
gg <- gg + theme(panel.background=element_rect(fill=alpha(set2[3],0.2),
                                              colour='white'))
gg

# Listing 4-5
# requires packages: stringr
# requires object: av.df (4-3)
# R code to incporporate IANA IPv4 allocations
# retrieve IANA prefix list
library(stringr)

ianaURL <- "http://www.iana.org/assignments/ipv4-address-space/ipv4-address-space.csv"
ianaData <- "data/ipv4-address-space.csv"
if (file.access(ianaData)) {
  download.file(ianaURL, ianaData)
}

# read in the IANA table
iana <- read.csv(ianaData)

# clean up the iana prefix since it uses the old/BSD-
# number formatting (i.e. allows leading zeroes and
# we do not need to know the CIDR component.
iana$Prefix <- sub("^(00|0)", "", iana$Prefix, perl=TRUE)
iana$Prefix <- sub("/8$", "", iana$Prefix, perl=TRUE)

# define function to strip 'n' characters from a string
# (character vector) and return the shortened string.
# note that this function is 'vectorized' (you can pass it a single
# string or a vector of them)
rstrip <- function(x, n){
  substr(x, 1, nchar(x)-n)
}

# extract just the prefix from the AlienVault list
av.IP.prefix <- rstrip(str_extract(as.character(av.df$IP),
                                  "^([0-9]+)\\."), 1)

# there are faster ways than 'sapply()' but we wanted you to
# see the general "apply" pattern in action as you will use it
# quite a bit throughout your work in R
av.df$Designation <- sapply(av.IP.prefix, function(ip) {
  iana[iana$Prefix == ip, ]$Designation
})

# summarize, order & review the findings
summary(factor(av.df$Designation))
##       Administered by AFRINIC         Administered by APNIC
##                           322                          2615
##          Administered by ARIN      Administered by RIPE NCC
##                         17974                          5893
##                       AFRINIC                         APNIC
##                          1896                         93776
##                          ARIN        AT&T Bell Laboratories
##                         42358                            24
## Digital Equipment Corporation       Hewlett-Packard Company
##                             1                             3
##                        LACNIC  Level 3 Communications, Inc.
##                         18914                            31
##                  PSINet, Inc.                      RIPE NCC
##                            30                         74789

# Listing 4-6
# requires packages: ggplot2, maps, RColorBrewer
# requires object: av.coords.df (4-3), iana (4-5)
# Code to extract IANA block assignments & compare w/AlienVault groups
# create a new data frame from the iana designation factors
iana.df <- data.frame(table(iana$Designation))
colnames(iana.df) <- c("Registry", "IANA.Block.Count")

# make a data frame of the counts of the av iana
# designation factor
tmp.df <- data.frame(table(factor(av.df$Designation)))
colnames(tmp.df) <- c("Registry", "AlienVault.IANA.Count")

# merge (join) the data frames on the "reg" column
combined.df <- merge(iana.df, tmp.df)
print(combined.df[with(combined.df, order(-IANA.Block.Count)),],
      row.names=FALSE)

##                       Registry IANA.Block.Count AlienVault.IANA.Count
##                          APNIC               45                 93776
##           Administered by ARIN               44                 17974
##                           ARIN               36                 42358
##                       RIPE NCC               35                 74789
##                         LACNIC                9                 18914
##          Administered by APNIC                6                  2615
##       Administered by RIPE NCC                4                  5893
##                        AFRINIC                4                  1896
##        Administered by AFRINIC                2                   322
##   Level 3 Communications, Inc.                2                    31
##         AT&T Bell Laboratories                1                    24
##  Digital Equipment Corporation                1                     1
##        Hewlett-Packard Company                1                     3
##                   PSINet, Inc.                1                    30

# Listing 4-7
# requires packages: reshape, grid, gridExtra, ggplot2, RColorBrewer
# requires object: combined.df (4-6), set2 (4-4)
# generates Figure 4-3
# plot charts from IANA data
# flatten the data frame by making one entry per "count" type
# versus having the counts in individual columns
# need the 'melt()' function from the reshape package
# to transform the data frame shape
library(reshape2)
library(grid)
library(gridExtra)

# normalize the IANA and AV values to % so bar chart scales
# match and make it easier to compare
combined.df$IANA.pct <- 100 * (combined.df$IANA.Block.Count /
                                 sum(combined.df$IANA.Block.Count))
combined.df$AV.pct <- 100 * (combined.df$AlienVault.IANA.Count /
                               sum(combined.df$AlienVault.IANA.Count))

combined.df$IANA.vs.AV.pct <- combined.df$IANA.pct - combined.df$AV.pct

melted.df <- melt(combined.df)
# plot the new melted data frame values
gg1 <- ggplot(data=melted.df[melted.df$variable=="IANA.pct",],
              aes(x=reorder(Registry, -value), y=value))
# set min/max for axis so scale is same for both charts
gg1 <- gg1 + ylim(0,40)
gg1 <- gg1 +  geom_bar(stat="identity", fill=set2[3]) # using bars

# make a better label for the y axis
gg1 <- gg1 + labs(x="Registry", y="%", title="IANA %")
# make bar chart horizontal
gg1 <- gg1 + coord_flip()
# rotate the x-axis labels and remove the legend
gg1 <- gg1 + theme(axis.text.x = element_text(angle = 90, hjust = 1),
                   panel.background = element_blank(),
                   legend.position = "none")

gg2 <- ggplot(data=melted.df[melted.df$variable=="AV.pct",],
              aes(x=reorder(Registry,-value), y=value))
gg2 <- gg2 + geom_bar(stat="identity", fill=set2[4]) # using bars
gg2 <- gg2 + ylim(0,40)
gg2 <- gg2 + labs(x="Registry", y="%", title="AlienVault IANA %")
gg2 <- gg2 + coord_flip()
gg2 <- gg2 + theme(axis.text.x = element_text(angle = 90, hjust = 1),
                   panel.background = element_blank(),
                   legend.position = "none")

# grid.arrange makes it possible to do very precise placement of
# multiple ggplot objects
grid.arrange(gg1, gg2, ncol=1, nrow=2)

# Listing 4-8
# requires packages: ggplot2
# requires object: combined.df (4-7), set2 (4-4)
gg <- ggplot(data=combined.df,
             aes(x=reorder(Registry, -IANA.Block.Count), y=AV.pct ))
gg <- gg + geom_bar(stat="identity", fill=set2[2])
gg <- gg + labs(x="Registry", y="Count",
                title="AlienVault/IANA sorted by IANA (low-to-high")
gg <- gg + coord_flip()
gg <- gg + theme(axis.text.x = element_text(angle = 90, hjust = 1),
                 panel.background = element_blank(),
                 legend.position = "none")
gg

######################################################################
# BEGIN CODE FOR FIGURE 4-5 (Scatterplots)
# THIS CODE GENERATES THE FIGURE BUT IS NOT DISPLAYED IN THE BOOK
######################################################################
mfrow <- par()$mfrow
mar <- par()$mar
oma <- par()$oma

par(mfrow=c(2, 3), mar=c(0, 0, 2, 0), oma=c(1, 1, 1, 1))
set.seed(2)
x <- runif(500, min=0, max=pi)

y <- rnorm(500, mean=x, sd=0.2)
plot(x,y, pch=19, cex=.8, col="#666699CC", axes=FALSE, xlab="", ylab="",
     main=paste("Designation: ", round(cor(x,y), 2)))

y <- rnorm(500, mean=-x, sd=0.3)
plot(x,y, pch=19, cex=.8, col="#666699CC", axes=FALSE, xlab="", ylab="",
     main=paste("Correlation: ", round(cor(x,y), 2)))

y <- rnorm(500, mean=sin(x), sd=0.2)
plot(x,y, pch=19, cex=.8, col="#666699CC", axes=FALSE, xlab="", ylab="",
     main=paste("Correlation: ", round(cor(x,y), 2)))

y <- rnorm(500, mean=x, sd=2)
plot(x,y, pch=19, cex=.8, col="#666699CC", axes=FALSE, xlab="", ylab="",
     main=paste("Correlation: ", round(cor(x,y), 2)))

y <- rnorm(500, mean=-x, sd=1)
plot(x,y, pch=19, cex=.8, col="#666699CC", axes=FALSE, xlab="", ylab="",
     main=paste("Correlation: ", round(cor(x,y), 2)))

y <- runif(500, min=0, max=pi)
plot(x,y, pch=19, cex=.8, col="#666699CC", axes=FALSE, xlab="", ylab="",
     main=paste("Correlation: ", round(cor(x,y), 2)))

par(mfrow=mfrow, mar=mar, oma=oma)
######################################################################
# END CODE FOR FIGURE 4-5
######################################################################

# Listing 4-9
# requires packages: ggplot2, scales
# requires object: combined.df (4-7), set2 (4-4)
# generates figure 4-6
library(scales)
gg <- ggplot(data=combined.df)
gg <- gg + geom_point(aes(x=IANA.Block.Count,
                          y=AlienVault.IANA.Count),
                      color=set2[2], size=4)
gg <- gg + labs(x="IANA Block Count", y="AlienVault IANA Count",
                title="IANA ~ AlienVault")
gg <- gg + theme(axis.text.x = element_text(angle = 90, hjust = 1),
                 legend.position = "none")
gg <- gg + theme(panel.background=element_rect(fill=alpha(set2[3],0.2),
                                               colour='white'))
gg

cor(combined.df$IANA.Block.Count,
    combined.df$AlienVault.IANA.Count, method="spearman")

# Listing 4-10
anscombe[,c(1,5,2,6,3,7,4,8)]
##    x1    y1 x2   y2 x3    y3 x4    y4
## 1  10  8.04 10 9.14 10  7.46  8  6.58
## 2   8  6.95  8 8.14  8  6.77  8  5.76
## 3  13  7.58 13 8.74 13 12.74  8  7.71
## 4   9  8.81  9 8.77  9  7.11  8  8.84
## 5  11  8.33 11 9.26 11  7.81  8  8.47
## 6  14  9.96 14 8.10 14  8.84  8  7.04
## 7   6  7.24  6 6.13  6  6.08  8  5.25
## 8   4  4.26  4 3.10  4  5.39 19 12.50
## 9  12 10.84 12 9.13 12  8.15  8  5.56
## 10  7  4.82  7 7.26  7  6.42  8  7.91
## 11  5  5.68  5 4.74  5  5.73  8  6.89

sapply(anscombe,mean)
##       x1       x2       x3       x4       y1       y2       y3
## 9.000000 9.000000 9.000000 9.000000 7.500909 7.500909 7.500000
##       y4
## 7.500909
sapply(anscombe,sd)
##       x1       x2       x3       x4       y1       y2       y3
## 3.316625 3.316625 3.316625 3.316625 2.031568 2.031657 2.030424
##       y4
## 2.030579
sapply(anscombe,var)
##      x1        x2        x3        x4        y1        y2
## 11.000000 11.000000 11.000000 11.000000  4.127269  4.127629
##       y3        y4
## 4.122620  4.123249
for (i in 1:4) cat(cor(anscombe[,i], anscombe[,i+4]), "\n")
## 0.8164205
## 0.8162365
## 0.8162867
## 0.8165214

# Listing 4-11
# Retrieve and read ZeuS blocklist data into R
zeusURL <- "https://zeustracker.abuse.ch/blocklist.php?download=ipblocklist"
zeusData <- "data/zeus.csv"
if (file.access(zeusData)) {
  # need to change download method for universal "https" compatibility
  download.file(zeusURL, zeusData, method="curl")
}
# read in the ZeuS table; skip junk; no header; assign colnames
zeus <- read.table(zeusData, skip=5, header=FALSE, col.names=c("IP"))

# Listing 4-12
# requires packages: igraph, plyr, RColorBrewer, colorspace
# requires object: set2 (4-4)
library(igraph)
library(plyr)
library(colorspace)

# HELPER FUNCTION MENTIONED IN THE BOOK
# BUT NOT IN THE PRINTED LISTINGS

trim <- function (x) gsub("^\\s+|\\s+$", "", x)

# HELPER FUNCTION MENTIONED IN THE BOOK
# BUT NOT IN THE PRINTED LISTINGS

BulkOrigin <- function(ip.list,host="v4.whois.cymru.com",port=43) {

  # setup query
  cmd <- "begin\nverbose\n"
  ips <- paste(unlist(ip.list), collapse="\n")
  cmd <- sprintf("%s%s\nend\n",cmd,ips)

  # setup connection and post query
  con <- socketConnection(host=host,port=port,blocking=TRUE,open="r+")
  cat(cmd,file=con)
  response <- readLines(con)
  close(con)

  # trim header, split fields and convert results
  response <- response[2:length(response)]
  response <- laply(response,.fun=function(n) {
    sapply(strsplit(n,"|",fixed=TRUE),trim)
  })
  response <- adply(response,c(1))
  response <- subset(response, select = -c(X1) )
  names(response) = c("AS","IP","BGP.Prefix","CC",
                      "Registry","Allocated","AS.Name")

  return(response)

}

# HELPER FUNCTION MENTIONED IN THE BOOK
# BUT NOT IN THE PRINTED LISTINGS

BulkPeer <- function(ip.list,host="v4-peer.whois.cymru.com",port=43) {

  # setup query
  cmd <- "begin\nverbose\n"
  ips <- paste(unlist(ip.list), collapse="\n")
  cmd <- sprintf("%s%s\nend\n",cmd,ips)

  # setup connection and post query
  con <- socketConnection(host=host,port=port,blocking=TRUE,open="r+")
  cat(cmd,file=con)
  response <- readLines(con)
  close(con)

  # trim header, split fields and convert results
  response <- response[2:length(response)]
  response <- laply(response,function(n) {
    sapply(strsplit(n,"|",fixed=TRUE),trim)
  })
  response <- adply(response,c(1))
  response <- subset(response, select = -c(X1) )
  names(response) <- c("Peer.AS","IP","BGP.Prefix","CC",
                       "Registry","Allocated","Peer.AS.Name")
  return(response)

}

# HELPER FUNCTION MENTIONED IN THE BOOK
# BUT NOT IN THE PRINTED LISTINGS

BulkOriginASN <- function(asn.list,host="v4.whois.cymru.com",port=43) {

  # setup query
  cmd <- "begin\nverbose\n"
  ips <- paste(unlist(asn.list), collapse="\n")
  cmd <- sprintf("%s%s\nend\n",cmd,ips)

  # setup connection and post query
  con <- socketConnection(host=host,port=port,blocking=TRUE,open="r+")
  cat(cmd,file=con)
  response <- readLines(con)
  close(con)

  # trim header, split fields and convert results

  response <- response[2:length(response)]
  response <- laply(response,.fun=function(n) {
    sapply(strsplit(n,"|",fixed=TRUE),trim)
  })

  response <- adply(response,c(1))
  response <- subset(response, select = -c(X1) )
  names(response) <- c("AS","CC","Registry","Allocated","AS.Name")

  return(response)

}

# load the zeus botnet data used to perform the
# remainder of the analyses in the chapter
zeus <- read.table("data/zeus-book.csv", skip=5, header=FALSE,
                   col.names=c("IP"))
ips <- as.character(zeus$IP)
# get BGP origin data & peer data;
origin <- BulkOrigin(ips)
g <- graph.empty() # start graphing
# Make IP vertices; IP endpoints are red
g <- g + vertices(ips, size=5, color=set2[4], group=1)
# Make BGP vertices
g <- g + vertices(origin$CC, size=5, color=set2[2], group=2)
# for each IP address, get the origin AS CC and return
# them as a pair to create the IP->CC edge list
ip.cc.edges <- lapply(ips, function(x) {
  iCC <- origin[origin$IP==x, ]$CC
  lapply(iCC, function(y){
    c(x, y)
  })
})
g <- g + edges(unlist(ip.cc.edges)) # build CC->IP edges
# simplify the graph by combining commmon edges
g <- simplify(g, edge.attr.comb=list(weight="sum"))
# delete any standalone vertices (lone wolf ASNs). In "graph" terms
# delete any vertex with a degree of 0
g <- delete.vertices(g, which(degree(g) < 1))
E(g)$arrow.size <- 0 # we hate arrows
# blank out all the IP addresses to focus on ASNs
V(g)[grep("\\.", V(g)$name)]$name <- ""

# Listing 4-13
# Visualizing the ZeuS blocklist country cluster graph
# requires packages: igraph, plyr
# requires all objects from Listing 4-11
# this is a great layout for moderately sized networks. you can
# tweak the "n=10000" if this runs too slowly for you. The more
# iterations, the cleaner the graph will look
L <- layout.fruchterman.reingold(g, niter=10000, area=30*vcount(g)^2)
# plot the graph
par(bg = 'white', mfrow=c(1,1))
plot(g, margin=0, layout=L, vertex.label.dist=0.5,
     vertex.label.cex=0.75,
     vertex.label.color="black",
     vertex.label.family="sans",
     vertex.label.font=2,
     main="ZeuS botnet nodes clustered by country")

# Listing 4-14
# require package: igraph (4-11)
# requires object: V() (4-11), g (4-11)
# read in country code to name translation table
zeus.cc <- grep("[A-Z]", V(g)$name, value=TRUE)
zeus.cc <- zeus.cc[order(zeus.cc)]
# read in the country codes data frame
cc.df <- read.csv("data/countrycode_data.csv")
# display cc & name for just the ones from our data set
print(head(cc.df[cc.df$iso2c %in% zeus.cc, c(7,1)], n=10),
      row.names=FALSE)
## iso2c   country.name
##    AR      ARGENTINA
##    AU      AUSTRALIA
##    AT        AUSTRIA
##    AZ     AZERBAIJAN
##    BG       BULGARIA
##    CA         CANADA
##    CL          CHILE
##    CN          CHINA
##    CZ CZECH REPUBLIC
##    DE        GERMANY

# Listing 4-15
# requires objects: BulkOrigin() & BulkPeer() from book's web site &
#   set2 (4-4)
# create connected network of ZeuS IPs, ASNs, and ASN peers
# generates Figure 4-8
# require package: igraph, RColorBrewer
g <- graph.empty()
g <- g + vertices(ips, size=3, color=set2[4], group=1)
origin <- BulkOrigin(ips)
peers <- BulkPeer(ips)
# add ASN origin & peer vertices
g <- g + vertices(unique(c(peers$Peer.AS, origin$AS)),
                  size=3, color=set2[2], group=2)
# build IP->BGP edge list
ip.edges <- lapply(ips, function(x) {
  iAS <- origin[origin$IP==x, ]$AS
  lapply(iAS,function(y){
    c(x, y)
  })
})

bgp.edges <- lapply(
  grep("NA",unique(origin$BGP.Prefix),value=TRUE,invert=TRUE),
  function(x) {
    startAS <- unique(origin[origin$BGP.Prefix==x,]$AS)
    lapply(startAS,function(z) {
      pAS <- peers[peers$BGP.Prefix==x,]$Peer.AS
      lapply(pAS,function(y) {
        c(z,y)
      })
    })
  })
g <- g + edges(unlist(ip.edges))
g <- g + edges(unlist(bgp.edges))
g <- delete.vertices(g, which(degree(g) < 1))
g <- simplify(g, edge.attr.comb=list(weight="sum"))
E(g)$arrow.size <- 0
V(g)[grep("\\.", V(g)$name)]$name = ""
L <- layout.fruchterman.reingold(g, niter=10000, area=30*vcount(g)^2)
par(bg = 'white')
plot(g, margin=0, layout=L, vertex.label.dist=0.5,
     vertex.label=NA,
     main="ZeuS botnet ASN+Peer Network")

# ADDITIONAL HELPER FUNCTION MENTIONED IN THE BOOK BUT NOT PRINTED

graph.cc <- function(ips, alien.vault.df, show.plot=TRUE) {

  options("warn" = -1)

  # Lookup ASN info for the incoming IP list which will
  # have country of origin info that's fairly accurate
  origin <- BulkOrigin(ips)

  # filter out IP and Type from the alienvault DB only for our ip list
  ips.types <- alien.vault.df[alien.vault.df$IP %in% ips,c(1,2,4)]

  # get a tabular summary of the types and counts
  ftab <- table(factor(ips.types[ips.types$IP %in% ips,]$Type))

  # build a color table from the tabular summary
  # myColors <- rainbow_hcl(length(names(ftab)),c=60,l=70,start=20)
  myColors <- set2
  col.df <- data.frame(Type=names(ftab),Color=myColors)

  # begin graph creation
  g <- graph.empty()

  # add our ip list as the starting vertices
  g <- g + vertices(ips,size=3,group=1)

  # i don't the df is necessary anymore...will test later
  ips.df <- data.frame(ips)
  colnames(ips.df) <- c("IP")

  # get the current list of vertex names...i think i can remove this too
  v.names <- V(g)$name

  # assign colors to the vertices based on the type
  V(g)$color <- as.character(col.df[col.df$Type %in% ips.types[ips.types$IP %in% v.names,]$Type,]$Color)

  # add country vertices
  g <- g + vertices(
    unique(origin$CC),
    size=3,color="black",group=2)

  # build country->ip edges
  ip.cc.edges <- lapply(ips,function(x) {
    iCC <- origin[origin$IP==x,]$CC
    lapply(iCC,function(y){
      c(x,y)
    })
  })

  # add edges
  g <- g + edges(unlist(ip.cc.edges))

  # simplify (though it's almost not necessary given the low
  # complexity of the graph)
  g <- simplify(g, edge.attr.comb=list(weight="sum"))

  # remove lone wolf vertices
  g <- delete.vertices(g, which(degree(g) < 1))

  # arrows: ugh
  E(g)$arrow.size <- 0

  # we only want to see country labels, not IPs
  V(g)[grep("[0-9]",V(g)$name)]$name <- ""

  # 10000 makes pretty graphs and takes a pretty long time
  L <- layout.fruchterman.reingold(g, niter=10000, area=30*vcount(g)^2)

  # for when I add community options
  c <- walktrap.community(g, steps=10)
  v <- evcent(g)$vector

  if (show.plot) {
    def.par <- par(no.readonly = TRUE)
    par(bg = 'white')
    layout(matrix(c(1,2,3,1), 1, 2, byrow = TRUE), widths=c(5,1))
    plot(g,margin=0,layout=L,vertex.label.dist=0.6,
         vertex.label.cex=0.75,
         vertex.label.color="black",
         vertex.label.family="sans",
         vertex.label.font=2)
    par(mar=c(5,0,2,2))
    barplot(ftab,horiz=TRUE,las=1,cex.names=0.75,cex.axis=0.75,
            col=as.character(col.df[col.df$Type %in% unlist(labels(ftab)),]$Color))
    par(def.par)
  }

  options("warn" = 0)

  return(g)
}

# ADDITIONAL HELPER FUNCTION MENTIONED IN THE BOOK BUT NOT PRINTED

graph.asn <- function(ips,alien.vault.df,add.peers=FALSE,show.plot=TRUE,show.labels=FALSE) {

  options("warn" = -1)

  # Lookup ASN info for the incoming IP list
  origin <- BulkOrigin(ips)

  if (add.peers) { # and peers if specified
    peers <- BulkPeer(ips)
  }

  # filter out IP and Type from the alienvault DB only for our ip list
  ips.types <- alien.vault.df[alien.vault.df$IP %in% ips,c(1,2,4)]

  # get a tabular summary of the types and counts
  ftab <- table(factor(ips.types[ips.types$IP %in% ips,]$Type))

  # build a color table from the tabular summary
  #myColors <- rainbow_hcl(length(names(ftab)),c=60,l=70,start=20)
  myColors <- set2
  col.df <- data.frame(Type=names(ftab),Color=myColors)

  # begin graph creation
  g <- graph.empty()

  # add our ip list as the starting vertices
  g <- g + vertices(ips,size=3,group=1)

  # i don't think the df is necessary anymore...will test later
  ips.df <- data.frame(ips)
  colnames(ips.df) <- c("IP")

  # get the current list of vertex names...i think i can remove this too
  v.names <- V(g)$name

  # assign colors to the vertices based on the type
  V(g)$color <- as.character(col.df[col.df$Type %in% ips.types[ips.types$IP %in% v.names,]$Type,]$Color)

  # add BGP->IP vertices and - if requested - add peer ASN vertices
  if (add.peers) {
    g <- g + vertices(
      unique(c(peers$Peer.AS, origin$AS)),
      size=4,color="black",group=2)
  } else {
    g <- g + vertices(
      unique(origin$AS),
      size=4,color="black", group=2)
  }

  # Make IP/BGP edges
  ip.edges <- lapply(ips,function(x) {
    iAS <- origin[origin$IP==x,]$AS
    lapply(iAS,function(y){
      c(x,y)
    })
  })

  if (add.peers) { # same for peers if specified
    bgp.edges <- lapply(
      grep("NA",unique(origin$BGP.Prefix),value=TRUE,invert=TRUE),
      function(x) {
        startAS <- unique(origin[origin$BGP.Prefix==x,]$AS)
        lapply(startAS,function(z) {
          pAS <- peers[peers$BGP.Prefix==x,]$Peer.AS
          lapply(pAS,function(y) {
            c(z,y)
          })
        })
      })
  }

  # build ASN->IP edges
  g <- g + edges(unlist(ip.edges))

  if (add.peers) { # same for peers if specified
    g <- g + edges(unlist(bgp.edges))
  }

  # simplify the structure (prbly needed since it's already
  # well organized w/o dupes
  g <- simplify(g, edge.attr.comb=list(weight="sum"))

  # delete any standalone vertices (lone wolf ASNs)
  g <- delete.vertices(g, which(degree(g) < 1))

  # arrows: ugh
  E(g)$arrow.size <- 0

  # if we do show labels, we only want to see the ASNs
  V(g)[grep("\\.",V(g)$name)]$name <- ""

  # 10000 makes it pretty...and pretty slow
  L <- layout.fruchterman.reingold(g, niter=10000,
                                   area=30*vcount(g)^2)

  # shld make an options parameter and if-block this
  c <- walktrap.community(g, steps=10)
  v <- evcent(g)$vector

  if (show.plot) {
    def.par <- par(no.readonly = TRUE)
    par(bg = 'white')
    layout(matrix(c(1,2,3,1), 1, 2, byrow = TRUE),
           widths=c(5,1))
    if (show.labels) {
      plot(g,
           margin=0,
           layout=L,
           vertex.label.dist=0.6,
           vertex.label.cex=0.75,
           vertex.label.color="black",
           vertex.label.family="sans",
           vertex.label.font=2)
    } else {
      plot(g,margin=0,vertex.label=NA,layout=L)
    }
    par(mar=c(5,0,2,2))
    barplot(ftab,horiz=TRUE,las=1,cex.names=0.75,cex.axis=0.75,
            col=as.character(
              col.df[col.df$Type %in% unlist(labels(ftab)),]$Color))
    par(def.par)
  }

  options("warn" = 0)
  return(g)
}

# Listing 4-16
# requires objects: BulkOrigin() & BulkPeer(), graph.cc(), graph.asn()
#   from book's web site & set2 (4-4)
# Working with Real Data
# create connected network of ZeuS IPs, ASNs, and ASN peers
# generates Figure 4-9
# require package: igraph, RColorBrewer
avRep <- "data/reputation.data"
av.df <- read.csv(avRep, sep="#", header=FALSE)
colnames(av.df) <- c("IP", "Reliability", "Risk", "Type",
                     "Country", "Locale", "Coords", "x")

# read in list of destination IP addresses siphoned from firewall logs
dest.ips <- read.csv("data/dest.ips", col.names= c("IP"))

# take a look at the reliability of the IP address entries
# (you could also plot a histogram)
table(av.df[av.df$IP %in% dest.ips$IP, ]$Reliability)
##  1   2   3   4   5   6   7   8   9  10
## 16 828 831 170   1 266  92   2  23  24

# extract only the "bad" ones, designated by presence in alienvault
# database with a reliability greater than 6 since there seems to
# be a trailing off at that point
ips <- as.character(av.df[(av.df$IP %in% dest.ips$IP) &
                            (av.df$Reliability > 6), ]$IP)
# graph it
g.cc <- graph.cc(ips, av.df)


######### ---------------rpart Code for decision trees--------------------###########

library(tm)
library(rpart)

#Load the files into corpus
obamaCorpus <- Corpus(DirSource(directory = "D:/R/Chap 6/Speeches/obama" , encoding="UTF-8"))
romneyCorpus <- Corpus(DirSource(directory = "D:/R/Chap 6/Speeches/romney" , encoding="UTF-8"))

#Merge both the corpus to one big corpus
fullCorpus <- c(obamaCorpus,romneyCorpus)#1-22 (obama), 23-44(romney)

#Do basic processing on the loaded corpus
fullCorpus.cleansed <- tm_map(fullCorpus, removePunctuation)
fullCorpus.cleansed <- tm_map(fullCorpus.cleansed, stripWhitespace)
fullCorpus.cleansed <- tm_map(fullCorpus.cleansed, tolower)
fullCorpus.cleansed <- tm_map(fullCorpus.cleansed, removeWords, stopwords("english"))
fullCorpus.cleansed <- tm_map(fullCorpus.cleansed, PlainTextDocument)

#Create the term document matrix for analysis
full.dtm <- DocumentTermMatrix(fullCorpus.cleansed)

#Remove sparse terms
full.dtm.spars <- removeSparseTerms(full.dtm , 0.6)

#Convert the Document term matrix to data frame for easy manipulation
full.matix <- data.matrix(full.dtm.spars)
full.df <- as.data.frame(full.matix)

#Add the speakers name to dataframe
full.df[,"SpeakerName"] <- "obama"
full.df$SpeakerName[21:44] <- "romney"

#Create the training and Test index
train.idx <- sample(nrow(full.df) , ceiling(nrow(full.df)* 0.6))
test.idx <- (1:nrow(full.df))[-train.idx]

# Select the top 70 terms used in the corpus
freqterms70 <- findFreqTerms( full.dtm.spars, 70)

#Creat the formuls for input to rpart function
outcome <- "SpeakerName"
formula_str <- paste(outcome, paste(freqterms70, collapse=" + "), sep=" ~ ")
formula <- as.formula(formula_str)

fit <- rpart(formula, method="class", data=full.df.train,control=rpart.control(minsplit=5, cp=0.001));

print(fit) #display cp table

printcp(fit) # plot cross-validation results

par(mfrow = c(1,2), xpd = NA)
text(fit, use.n=T)

# ----------------------spam classifier -----------------#
#We will set up the environment by loading all the required library
#The data set used in this code can be download from http://www.aueb.gr/users/ion/data/enron-spam/
#The data is Enron-Spam in pre-processed form: Enron1

install.packages("caret")
require(caret)

install.packages("kernlab")
require(kernlab)

install.packages("e1071")
require(e1071)

install.packages("tm")
require(tm)

install.packages("plyr")
require(plyr)

#Extract the Enron-Spam data set to you local file system in my case its in the below directory
pathName <- "D:/R/Chap 6/enron1"

#The data set has two sub folders "spam" folder contains all the mails that are spam ,and "ham" folder which contains all the mails that are legitimate
emailSubDir <- c("ham","spam")
#Build a Term document matrix , Here we are converting the text to quantitative format for analysis.
GenerateTDMForEMailCorpus <- function(subDir , path){
    # concatenate the variable i.e. the path and the sub-folder name to create the complete path to mail corpus directory.
    #mailDir <- sprintf("%s/%s", path, subDir)
    mailDir <-paste(path, subDir, sep="/")
    #create a corpus using the above computed directory path , we will use DirSource since we are dealing with directories , with encoding UTF-8

    mailCorpus <- Corpus(DirSource(directory = mailDir , encoding="UTF-8"))
    #create term document matrix
    mail.tdm <- TermDocumentMatrix(mailCorpus)
    #remove sparse terms from TDM for better analysis
    mail.tdm <- removeSparseTerms(mail.tdm,0.7)
    #return the results , which is the list of TDM for spam and ham.
    result <- list(name = subDir , tdm = mail.tdm)
}

# Let’s write a function that can convert Term document matrix to data frame

#We will convert the TDM to data frame and append the type of mail if its a spam or ham the data frame.
BindMailTypeToTDM <- function(individualTDM){
    # Create a numeric matrix , get its transpose so that column contains the words and row contains number of word occurrences in the mail
    mailMatrix <- t(data.matrix(individualTDM[["tdm"]]))
    #convert this matrix into data frame since its easy to work with with data frames.
    mailDataFrame <- as.data.frame(mailMatrix , stringASFactors = FALSE)
    # Add the type of mail to each row in the data frame
    mailDataFrame <- cbind(mailDataFrame , rep(individualTDM[["name"]] , nrow(mailDataFrame)))
    #Give a proper name to the last column of the data frame
    colnames(mailDataFrame)[ncol(mailDataFrame)] <- "MailType"
    return (mailDataFrame)
}

tdmList <- lapply(emailSubDir , GenerateTDMForEMailCorpus , path = pathName)
mailDataFrame <- lapply(tdmList, BindMailTypeToTDM)

# join both the data frames for spam and ham
allMailDataFrame <- do.call(rbind.fill , mailDataFrame)
# fill the empty columns with 0
allMailDataFrame[is.na(allMailDataFrame)] <- 0

#reorder the column for readability
allMailDataFrame_ordered <- allMailDataFrame[ ,c(1:18,20:23,19)]

#Prepare a training set , we are getting about 60% of the rows to train the modal
train.idx <- sample(nrow(allMailDataFrame_ordered) , ceiling(nrow(allMailDataFrame_ordered)* 0.6))
# prepare the test set , with the remaining rows that are not part of training sample
test.idx <- (1:nrow(allMailDataFrame_ordered))[-train.idx]

allMailDataFrame.train <- allMailDataFrame_ordered[train.idx,]
allMailDataFrame.test <- allMailDataFrame_ordered[test.idx,]

trainedModel <- naiveBayes(allMailDataFrame.train[,c(1:22)],allMailDataFrame.train[,c(23)], data = allMailDataFrame.train)
prediction <- predict(trainedModel, allMailDataFrame.test)
confusionMatrix <- confusionMatrix(prediction,allMailDataFrame.test[,c(23)])
confusionMatrix

ctable <- as.table(matrix(c(634   , 1, 466 , 450), nrow = 2, byrow = TRUE))
fourfoldplot(ctable, color = c("#CC6666", "#99CC99"), conf.level = 0, margin = 1, main = "Confusion Matrix")

####KNN--------
#Load library
install.packages("class")
require(class)

install.packages("tm")
require(tm)

install.packages("plyr")
require(plyr)

install.packages("caret")
require(caret)

# to make sure strings are not converted to nominal or categorical variables we set the below option
options(stringAsFactors = FALSE)

#Extract the Speech data set to you local file system in my case its in the below directory
speechDir <- c("romney","obama")
#The data set has two sub folders "obama" folder contains all the speeches from obama ,and "romney" folder which contains all the speeches that are from romney
pathToSpeeches <- "D:/R/Chap 6/Speeches"

#Data cleaning is a essential step when we do analysis on a text data , like Remove numbers ,Strip whitespaces, Remove punctuation , Remove stop words , change to lowercase.

CleanSpeechText <- function(speechText){
    #We will remove all punctuation characters from text
    speechText.cleansed <- tm_map(speechText, removePunctuation)
    #We will remove all white space from text
    speechText.cleansed <- tm_map(speechText, stripWhitespace)
    #We will convert all the words to lower case
    speechText.cleansed <- tm_map(speechText, tolower)
    #We will remove all stop words related to english
    speechText.cleansed <- tm_map(speechText, removeWords, stopwords("english"))
    #return the cleansed text
    return (speechText.cleansed)
}

#We Build a Term document matrix , Here we are converting the text to quantitative format for analysis.
produceTDM <- function(speechFolder,path){
    #Concinate the strings to get the full path to the respective speeches
    speechDirPath <-paste(path, speechFolder, sep="/")
    #Since its a directory use DirSource to create the corpus.
    speechCorpus <- Corpus(DirSource(directory = speechDirPath , encoding="UTF-8"))
    #Clean this corpus to remove unwanted noise in the text to make our analysis better
    speechCorpus.cleansed <- CleanSpeechText(speechCorpus)
    #Build the term document matrix for this cleansed corpus
    speech.tdm <- TermDocumentMatrix(speechCorpus.cleansed)
    #Remove the sparse terms to improve the prediction
    speech.tdm <- removeSparseTerms(speech.tdm,0.6)
    #Return the result of both the speeches as a list of tdm.
    resultTdmList <- list(name = speechFolder , tdm = speech.tdm)
}

#We will add the speakers name to the TDM matrix for training and testing
addSpeakerName <- function(individualTDM){
    # Create a numeric matrix , get its transpose so that column contains the words and row contains number of word occurrences in the speech
    speech.matix <- t(data.matrix(individualTDM[["tdm"]]))
    #convert this matrix into data frame since its easy to work with with data frames.
    seech.df <- as.data.frame(speech.matix)
    # Add the speakers name to each row in the data frame
    seech.df <- cbind(seech.df , rep(individualTDM[["name"]] , nrow(seech.df)))
    #Give a proper name to the last column of the data frame
    colnames(seech.df)[ncol(seech.df)] <- "SpeakerName"
    return (seech.df)
}

tdmList <- lapply(speechDir , produceTDM , path = pathToSpeeches)
speechDfList <- lapply(tdmList, addSpeakerName)

#Join both the data frames for obama and romney
combinedSpeechDf <- do.call(rbind.fill , speechDfList)
# fill the empty columns with 0
combinedSpeechDf[is.na(combinedSpeechDf)] <- 0

#Prepare a training set , we are getting about 60% of the rows to train the modal
train.idx <- sample(nrow(combinedSpeechDf) , ceiling(nrow(combinedSpeechDf)* 0.6))
#Prepare the test set , with the remaining rows that are not part of training sample
test.idx <- (1:nrow(combinedSpeechDf))[-train.idx]

# Lets create a data frame that only has the speaker names of the training set
combinedSpeechDf.speakers <- combinedSpeechDf[,"SpeakerName"]
# Lets create a data frame that all the attributes except the speaker name
combinedSpeechDf.allAttr <- combinedSpeechDf[,!colnames(combinedSpeechDf) %in% "SpeakerName"]

# Lets use the above training set and test set to create inputs to our classifier
combinedSpeechDf.train <- combinedSpeechDf.allAttr[train.idx,]
combinedSpeechDf.test <- combinedSpeechDf.allAttr[test.idx,]
combinedSpeechDf.trainOutcome <- combinedSpeechDf.speakers[train.idx]
combinedSpeechDf.testOutcome <- combinedSpeechDf.speakers[test.idx]

prediction <- knn(combinedSpeechDf.train ,combinedSpeechDf.test ,combinedSpeechDf.trainOutcome)

# Lets check out the confusion matrix
confusionMatrix <- confusionMatrix(prediction,testOutcome)

#### -------------SVM--------

sv <- svm(combinedSpeechDf.train, combinedSpeechDf.trainOutcome)
pred <-predict(sv,combinedSpeechDf.test)
table(pred, combinedSpeechDf.testOutcome)

# MAXENT---
library(maxent)
data <- read.csv(system.file("data/USCongress.csv.gz",package = "maxent"))

library(tm)
corpus <- Corpus(VectorSource(data$text))
dtm <- TermDocumentMatrix(corpus,
control=list(weighting = weightTfIdf,
language = "english",
tolower = TRUE,
stopwords = TRUE,
removeNumbers = TRUE,
removePunctuation = TRUE,
stripWhitespace = TRUE))

max_model <- maxent(matrix_sp[,1:2000],data$major[1:2000],use_sgd = TRUE,
set_heldout = 200)
save.model(max_model, "Model")
max_model <- load.model(“Model")

results <- predict(max_model, matrix_sp[,2001:2400])
model_tune <- tune.maxent(matrix_sp[,1:5000],+ data$major[1:5000],nfold=3, showall=TRUE)

model_tune
optimal_model <- maxent(matrix_sp[,1:2000],data$major[1:2000],l2_regularizer= 0.2, use_sgd = FALSE)

results <- predict(optimal_model, matrix_sp[,2001:2400])

####RTextools-------
#Load obama speech's
obamaCorpus <- Corpus(DirSource(directory = "D:/R/Chap 6/Speeches/obama" , encoding="UTF-8"))

obamaDataFrame<-data.frame(text=unlist(sapply(obamaCorpus, `[`, "content")),stringsAsFactors=F)

obama.df <- cbind(obamaDataFrame , rep("obama" , nrow(obamaDataFrame)))
colnames(obama.df)[ncol(obama.df)] <- "name"

#Load  romney speech's
romneyCorpus <- Corpus(DirSource(directory = "D:/R/Chap 6/Speeches/romney" , encoding="UTF-8"))

romneyDataFrame<-data.frame(text=unlist(sapply(romneyCorpus, `[`, "content")),stringsAsFactors=F)

romney.df <- cbind(romneyDataFrame , rep("romney" , nrow(romneyDataFrame)))
colnames(romney.df)[ncol(romney.df)] <- "name"

# combine both the speech's into on big data frame
speech.df <- rbind(obama.df, romney.df)

speech_matrix <- create_matrix(speech.df["text"], language="english", weighting=tm::weightTfIdf)

speech_container <- create_container(speech_matrix,as.numeric(factor(speech.df$name)),trainSize=1:2000, testSize=2001:3857, virgin=FALSE)

speech_model <- train_model(speech_container,"SVM")

speech_results <- classify_model(speech_container,speech_model)

speech_analytics <- create_analytics(speech_container, speech_results)

speech_score_summary <- create_scoreSummary(speech_container, speech_results)

summary(speech_results)

summary(speech_analytics)

#Let’s try out multiple algorithms on the same data frame
speech_multi_models <- train_models(speech_container, algorithms=c("MAXENT","SVM"))

speech_multi_results <- classify_models(speech_container,speech_multi_models)

speech_multi_analytics <- create_analytics(speech_container, speech_multi_results)

ensemble_summary <- create_ensembleSummary(speech_multi_analytics@document_summary)

precisionRecallSummary <- create_precisionRecallSummary(speech_container, speech_multi_results, b_value = 1)

scoreSummary <- create_scoreSummary(speech_container, speech_multi_results)

recall_acc <- recall_accuracy (speech_multi_analytics@document_summary$MANUAL_CODE,speech_multi_analytics@document_summary$MAXENTROPY_LABEL)

summary(speech_multi_results)

summary(recall_acc)

summary(scoreSummary)

summary(precisionRecallSummary)

# roc

install.packages('ROCR')

library(ROCR)
data(ROCR.simple)

pred <- prediction( ROCR.simple$predictions, ROCR.simple$labels)
perf <- performance(pred,"tpr","fpr")
plot(perf,colorize=TRUE)

lines(x=c(0, 1), y=c(0, 1), col="black")

# precision recall

perf1 <- performance(pred, "prec", "rec")
plot(perf1,colorize=TRUE)

perf1 <- performance(pred, "sens", "spec")
plot(perf1,colorize=TRUE)

# k fold cv
install.packages("cvTools")
install.packages("robustbase")
data("coleman")
fit <- lmrob(Y ~ ., data=coleman)

cvFit(fit, data = coleman, y = coleman$Y, cost = rtmspe, K = 5, R = 10, costArgs = list(trim = 0.1), seed = 1234)

install.packages("boot")
cv.glm(data, glmfit, cost, K)


require(RColorBrewer)

desat = function(cols, sat=0.5) {
    X = diag(c(1, sat, 1)) %*% rgb2hsv(col2rgb(cols))
    hsv(X[1,], X[2,], X[3,])
}

jet.colors <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan","#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000"))

set.colors = c(brewer.pal(9, 'Set1'), brewer.pal(7, 'Set2'), brewer.pal(12, 'Set3')[c(3,9,8)], 'violetred4')
set.colors[6] = 'khaki2'
set.colors[8] = 'lightskyblue2'
set.colors = rep(set.colors, 10)

tsne.colors = c(brewer.pal(7, 'Set2'), brewer.pal(9, 'Set1'), brewer.pal(12, 'Set3')[c(3,9,8)], 'violetred4')
tsne.colors[13] = 'khaki2'
tsne.colors[15] = 'lightskyblue2'
tsne.colors = rep(tsne.colors, 10)
tsne.colors = desat(tsne.colors, sat=.75)

material.heat <- function(n)
{
    mh = c(
        #"#607D8B", #blue grey
        "#283593", #indigo 800
        "#3F51B5",  #indigo
        "#2196F3", # blue
        #"#03A9F4", # light blue
        "#00BCD4", #cyan
        #"#009688", # teal
        "#4CAF50", #green
        "#8BC34A", #light green
        "#CDDC39", # lime
        "#FFEB3B", #yellow
        "#FFC107", # amber
        "#FF9800", # organe
        "#FF5722", # deep orange)
        "#f44336")
    colorRampPalette(mh)(n)
}

nmf.colors = c("#D73027", "#FC8D59", "#FEE090", "#FFFFBF", "#E0F3F8", "#91BFDB", "#4575B4")

tol1qualitative=c("#4477AA")
tol2qualitative=c("#4477AA", "#CC6677")
tol3qualitative=c("#4477AA", "#DDCC77", "#CC6677")
tol4qualitative=c("#4477AA", "#117733", "#DDCC77", "#CC6677")
tol5qualitative=c("#332288", "#88CCEE", "#117733", "#DDCC77", "#CC6677")
tol6qualitative=c("#332288", "#88CCEE", "#117733", "#DDCC77", "#CC6677","#AA4499")
tol7qualitative=c("#332288", "#88CCEE", "#44AA99", "#117733", "#DDCC77", "#CC6677","#AA4499")
tol8qualitative=c("#332288", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77", "#CC6677","#AA4499")
tol9qualitative=c("#332288", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77", "#CC6677", "#882255", "#AA4499")
tol10qualitative=c("#332288", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77", "#661100", "#CC6677", "#882255", "#AA4499")
tol11qualitative=c("#332288", "#6699CC", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77", "#661100", "#CC6677", "#882255", "#AA4499")
tol12qualitative=c("#332288", "#6699CC", "#88CCEE", "#44AA99", "#117733", "#999933", "#DDCC77", "#661100", "#CC6677", "#AA4466", "#882255", "#AA4499")

# material colors
# ---------------

material = read.table('~/code/single_cell/material_colors.txt', row.names=1, comment.char='', stringsAsFactors=F)
rownames(material) = tolower(rownames(material))

shades = function(color, n){
    colorRampPalette(material[color,])(n)
}
disc.colors = function(n, shade=6){
    disc.order = c('red', 'light_blue', 'amber', 'green', 'grey')
    if(n <= length(disc.order)){
        material[disc.order[1:n], shade]
    } else if(n <= nrow(material)){
        material[as.integer(seq(from=1, to=nrow(material), length.out=n)), shade]
    } else {
        colorRampPalette(material[,shade])(n)
    }
}
cont.colors = function(shade=6){
    colorRampPalette(material[,shade])(100)
}
name.colors = function(names, shade=6){
    material[names, shade]
}

set3.colors = c('#80b1d3', '#fdb462', '#b3de69')
set3.colors = c(set3.colors, setdiff(brewer.pal(12, 'Set3'), set3.colors))

# get similar colors
# ------------------

col2hcl <- function(x, maxColorValue=255, ...){
    library(colorspace)
    x = RGB(t(col2rgb(x))[,1:3,drop=F]/maxColorValue)
    x = colorspace::coords(as(x, 'polarLUV'))
    x[is.na(x)] = 0
    x[1,]
}

nice_colors = function(n, col=NULL, type='fancy', hmin=NULL, hmax=NULL, cmin=NULL, cmax=NULL, lmin=NULL, lmax=NULL, plot=F){

    library(grDevices)
    library(hues)

    # initialize palette
    beg = end = c()

    # map color to hues
    if(!is.null(col)){
        h0 = col2hcl(col)[['H']]
	hmin = h0 - 30
	hmax = h0 + 30
    }

    # get preset color schemes
    if(!is.null(type)){
	if(type == 'single'){cmin = 10; cmax = 100; lmin = 35; lmax = 100}
        if(type == 'shades'){hmin = 0; hmax = 240; cmin = 0; cmax = 15; lmin = 0; lmax = 100;}
	if(type == 'tarnish'){hmin = 0; hmax = 360; cmin = 0; cmax = 15; lmin = 30; lmax = 70;}
	if(type == 'pastel'){hmin = 0; hmax = 360; cmin = 0; cmax = 30; lmin = 70; lmax = 100;}
	if(type == 'pimp1'){hmin = 0; hmax = 360; cmin = 30; cmax = 100; lmin = 25; lmax = 70;}
	if(type == 'pimp2'){hmin = 0; hmax = 360; cmin = 30; cmax = 100; lmin = 55; lmax = 100;}
	if(type == 'intense'){hmin = 0; hmax = 360; cmin = 20; cmax = 100; lmin = 15; lmax = 80;}
	if(type == 'fluo'){hmin = 0; hmax = 300; cmin = 35; cmax = 100; lmin = 75; lmax = 100;}
	if(type == 'fancy'){hmin = 0; hmax = 360; cmin = 15; cmax = 40; lmin = 70; lmax = 100;}
	if(type == 'large'){hmin = 0; hmax = 360; cmin = 0; cmax = 85; lmin = 30; lmax = 95;}
    }

    # fix chroma values
    cmin = cmin*180/100.
    cmax = cmax*180/100.

    # handle edge cases
    if((hmin < 0 & hmax < 0) | (hmin > 360 & hmax > 360)){stop('error: invalid hmin and hmax range')}
    if(hmin < 0){
        n1 = round(n*(-hmin)/(hmax - hmin))
	if(n1 > 0){
	    beg = iwanthue(n1, hmin=360+hmin, hmax=360, cmin=cmin, cmax=cmax, lmin=lmin, lmax=lmax)
	    n = n - n1
	}
	hmin = 0
    }
    if(hmax > 360){
        n1 = round(n*(hmax - 360)/(hmax - hmin))
	if(n1 > 0){
	    end = iwanthue(n1, hmin=0, hmax=hmax-360, cmin=cmin, cmax=cmax, lmin=lmin, lmax=lmax)
	    n = n - n1
	}
	hmax = 360
    }
    pal = c(beg, iwanthue(n, hmin=hmin, hmax=hmax, cmin=cmin, cmax=cmax, lmin=lmin, lmax=lmax), end)
    unname(pal)
}

set2.colors = c(brewer.pal(9, 'Set1'), brewer.pal(7, 'Set2'), brewer.pal(12, 'Set3')[c(3,9,8)], 'violetred4')
set2.colors[6] = 'khaki2'
set2.colors[8] = 'lightskyblue2'
set2.colors = c(set2.colors, nice_colors(16, type='intense'), nice_colors(16, type='large'))


  prep.maturity.data = function(x, sex="male", quantiles=c(0,0.25,0.5,0.75,1) ) {

    # sex codes
    male = 0
    female = 1
    sex.unknown = 2

    # maturity codes
    immature = 0
    mature = 1
    mat.unknown = 2

      x=x[is.finite(x$z),]
      x=x[is.finite(x$t),]
      x=x[is.finite(x$cw),]

      x=x[is.finite(x$yr),]
      x$yr=as.factor(x$yr)

      x$reg = NA # initialise the column / field
      x$reg[ polygon_inside(x,aegis.polygons::polygon_internal_code("cfanorth")) ] = "cfanorth"
      x$reg[ polygon_inside(x,aegis.polygons::polygon_internal_code("cfasouth")) ] = "cfasouth"
      x$reg[ polygon_inside(x,aegis.polygons::polygon_internal_code("cfa4x")) ] = "cfa4x"
      x = x[ which( x$reg %in% c("cfanorth", "cfasouth" ) ) ,]
      x$reg=as.factor(x$reg)

      if (sex=="male") {
        x = x[ which( x$sex==1) ,]
        x = x[,c( "cw", "chela", "mat", "cfa", "z", "t", "yr", "reg", "julian")]
        x = x[ which(is.finite(x$chela)),]
      }
      if (sex=="female") {
        x = x[ which( x$sex==2) ,]
        x = x[,c( "cw", "abdomen", "mat", "cfa", "z", "t", "yr", "reg", "julian")]
        x = x[ which(is.finite(x$abdomen)),]
      }

    ### Switch Maturity Codes such that 0=immature   1=mature

      x$mat = as.numeric( as.character( x$mat) )
      x$mat[which(x$mat==2)]= 0
      x$mat = as.factor(x$mat )
      x = x[ which( x$mat %in% c(0,1)) ,]

      # temp fix as the cut function seems to drop the lowest data points.
      t.q = quantile(x$t, quantiles)
      t.q[1] = t.q[1] - 0.1

      z.q = quantile(x$z, quantiles)
      z.q[1] = z.q[1] - 10

      # discrete codings for temp and depth
      x$tq=cut(x$t, t.q, include.lowest=T)
      x$zq=cut(x$z, z.q, include.lowest=T)

    return ( x )

  }


open me.xyz
bond 1.55
hybridize 1 SP2
model GAFF
thermostat ANDERSEN
energy
minimize 0.0001 0.00001 40000 1000 min.xyz
energy
heat 500 50 400 0.01 0.01 0.0001 0.00001 0.3 heat.xyz
temperature
energy
prod 0.0001 0.0001 500 .3 50000 10 prod.xyz


REBOL [
	Title: "REBOL Core"
	Name: core
	Type: extension
	Exports: [] ; added by make-host-ext.r
]

words: [
	n			;modulus
	e			;public exponent
	d			;private exponent
	p			;prime num 1
	q			;prime num 2
	dp			;CRT exponent 1
	dq			;CRT exponent 2
	qinv		;CRT coefficient
]

init-words: command [
	words [block!]
]

init-words words

show-console: command [
	"Opens console window"
]

console-output: command [
	"Enables/Diables printing to console"
	state [logic!]
]

hide-console: command [
	"Hides console window if already open"
]

to-png: command [
	"Save an image to PNG format"
	image [image!]
]

<no-export> req-dir: command [
	"low-level command used by REQUEST-DIR"
	/title
		text [string!]
	/path
		dir [string!]
]

request-dir: funct [
	"Asks user to select a directory and returns it as file path"
	/title
		"Custom dialog title text"
		text [string!]
	/path
		"Default directory path"
		dir [file!]
][
	if dir [dir: lib/replace/all to-local-file dir "/" "//"]
	if result: apply :req-dir [title text path dir] [
		return to-rebol-file result
	]
]

rc4: command [
	"Encrypt/decrypt data(modifies) using RC4 algorithm. Returns stream cipher context handle."
	data [binary! none!] "Data to encrypt/decrypt. Or NONE to close the cipher stream."
	/key
		crypt-key [binary!] "Crypt key. Have to be provided only for the first time."
	/stream
		ctx [handle!] "Stream cipher context."
]

rsa-make-key: func [
	"Creates a key object for RSA algorithm."
][
	make object! [
		n:			;modulus
		e:			;public exponent
		d:			;private exponent
		p:			;prime num 1
		q:			;prime num 2
		dp:			;CRT exponent 1
		dq:			;CRT exponent 2
		qinv:		;CRT coefficient
		none
	]
]

rsa: command [
	"Encrypt/decrypt data using the RSA algorithm (with PKCS#1 padding)."
	data [binary!]
	key-object [object!]
	/decrypt "Decrypts the data (default is to encrypt)"
	/private "Uses an RSA private key (default is a public key)"
]


library(WALRUS)
library(configr)
library(R6)
library(bmi)

hoursSince1970toDate = function(hours) {
   # hours since 1970
   seconds = hours * 3600 # convert to seconds since 1970
   date10digit = as.numeric(format(as.POSIXlt(seconds, origin='1970/01/01', tz='UTC'), '%Y%m%d%H'))
   return(date10digit)
}

WalrusBmi <- R6Class(
  inherit = AbstractBmi,
  private = list(
    config = NULL,
    data = NULL,
    forc = NULL,
    pars = NULL,
    mod = NULL,
    current = 0,
    vars = list(
      label=c(
        'actual evapotranspiration', 'discharge', 'groundwater drainage/surface water infiltration', 'quickflow',
        'storage deficit', 'equilibrium storage deficit', 'groundwater depth', 'level quickflow reservoir',
        'surface water level', 'wetness index'
      ),
      name=c('ETact', 'Q', 'fGS', 'fQS', 'dV', 'dVeq', 'dG', 'hQ', 'hS', 'w'),
      type=rep('float64', 10),
      unit=c('mm/h', 'mm/h', 'mm/h', 'mm/h', 'mm', 'mm', 'mm', 'mm', 'mm', '-'),
      size=rep(8L, 10)
    )
  ),
  public = list(
    bmi_initialize = function(config_file) {
      private$config = read.config(config_file)

      private$data = read.table(private$config$data, header=TRUE)

      startDate = hoursSince1970toDate(private$config$start)
      endDate = hoursSince1970toDate(private$config$end)
      # WALRUS_selectdates uses get(), which gives Error: object of type 'closure' is not subsettable
      # So switch to inline filter
      # private$forc = WALRUS_selectdates(private$data, startDate, endDate)
      private$forc = private$data[private$data$date >= startDate & private$data$date <= endDate ,]

      WALRUS_preprocessing(f=private$forc, dt=private$config$step)
      private$pars = data.frame(private$config$parameters)
      # TODO do not run here, but in update* methods
      private$mod <- WALRUS_loop(private$pars)
      private$current <- private$config$start
      return()
    },
    update = function() {
      private$current <- private$current + private$config$step
    },
    updateUntil = function(until) {
      private$current <- until
    },
    updateFrac = function(frac) {
      private$current <- private$config$start + round((private$config$end - private$config$start) * frac)
    },

    getComponentName = function() return('WALRUS'),
    getInputVarNames = function() return(list()),
    # TODO map to CSDMS Standard Names
    getOutputVarNames = function() return(private$vars$name),

    getTimeUnits = function() return('hours since 1970-01-01 00:00:00.0 00:00'),
    getTimeStep = function() return(private$config$step),
    getStartTime = function() return(private$config$start),
    getEndTime = function() return(private$config$end),
    getCurrentTime = function() {
        return(private$current)
    },

    getVarGrid = function(name) {
        return(0L)
    },
    getVarType = function(name) {
        return(private$vars$type[private$vars$name == name])
    },
    getVarItemSize = function(name) {
      return(private$vars$size[private$vars$name == name])
    },
    getVarUnits = function(name) {
      return(private$vars$unit[private$vars$name == name])
    },
    getVarNBytes = function(name) {
        # grid size is 1x1 so same as single value
        return(self$getVarUnits(name));
    },

    getValue = function(name) {
        offset <- private$current - private$config$start
        return(private$mod[offset, name])
    },
    getValueAtIndices = function(name, indices) {
        offset <- private$current - private$config$start
        return(private$mod[offset, name])
    },
    # Skip getValuePtr, getValueAtIndices and setValue*, model does not support it

    getGridSize = function(grid_id) return(1L),
    getGridType = function(grid_id) return('rectilinear'),
    getGridRank = function(grid_id) return(1L),
    getGridShape = function(grid_id) return(c(1L, 1L)),
    getGridX = function(grid_id) return(c(private$config$centroid$lon)),
    getGridY = function(grid_id) return(c(private$config$centroid$lat)),
    getGridZ = function(grid_id) return(c()),

    bmi_finalize = function() return()
  )
)


library(rJava)

cpath <<- "/Users/jeremy/Dropbox/Eclipse Workspace/DoPE Pharmacoepi Toolbox/jar/pharmacoepi.jar"

.jinit(classpath=cpath, parameters=c("-Xmx1gm"), force.init = TRUE);

# create sample patient data
N <- 250000
id <- as.character(1:N)
exposure <- rbinom(N, 1, 0.5)
ps <- runif(N, 0, 1)

cohort <- data.frame(id, exposure, ps)

m <- .jnull("org.drugepi.match.Match");

# Instantiate match object
m <- .jnew("org.drugepi.match.Match");

print(sprintf("Match version %s", m$version))

.jcall(m, "V", "initMatch", "nn", "2");
.jfield(m, "matchRatio") <- as.integer(1);
.jfield(m, "fixedRatio") <- as.integer(1);
.jfield(m, "parallelMatchingMode") <- as.integer(1);

# not all options will be used in all runs, but set them anyway
.jfield(m, "caliper") <- as.double(0.05)
.jfield(m, "startDigit") <- as.integer(5)
.jfield(m, "endDigit") <- as.integer(1)

# treatment group is group 1
.jcall(m, "V", "addMatchGroup", "1");

# referent group is group 0
.jcall(m, "V", "addMatchGroup", "0");

.jfield(m, "outfilePath") <- "/tmp/out.txt"

match_header <- paste(names(cohort), collapse="\t")
match_data <- paste(paste(cohort[,1], cohort[,2], cohort[,3], sep="\t"),
					collapse="\n")

.jcall(m, "V", "addPatientsFromBuffer", paste(match_header, match_data, sep="\n"))

tryCatch( .jcall(m, "V", "run"),
	NumberFormatException = function(e) {
		e$jobj$printStackTrace()
	}
);

matches <- read.table("/tmp/out.txt", header=TRUE, sep="\t");
matched_cohort <- merge(matches, cohort, by.x="pat_id", by.y=names(cohort)[1], all=FALSE)

m <- .jnull("Object")

####
# EXPERIMENTAL
####

match_results <- .jcall(m, "S", "getMatchOutputData");

# get the lines of data
r <- unlist(strsplit(match_results, "\n"))
# split into a list of field vectors
d <- strsplit(r, split="\t")
# remove the header
d <- d[2:length(d)]

# create a data frame of matches
matches <- data.frame(
			set_num = sapply(d, function(x) {x[1]}),
			pat_id = sapply(d, function(x) {x[2]}),
			stringsAsFactors = FALSE
)

# strip quotes from the patient ID
matches$pat_id <- gsub("\"", "", matches$pat_id)

# merge into a single matched cohort, deleting any patients who didn't match
matched_cohort <- merge(matches, cohort, by.x="pat_id", by.y=names(cohort)[1], all=FALSE)
matched_cohort = matched_cohort[order(matched_cohort$set_num), ]
#matched_cohort


require("shiny")
#require("reshape")
#require("ggplot2")
#require("plotly")

#1. use require instead of library
#2. four functions: name.tabPanel
#                   name.siderbarPanel
#                   name.prepareData
#                   name.preparePlot
#3. profile to pass parameters for specific data
#4. function fileLocate to locate the date in selected folder
#5. In prepareData, use <<- instead of <- or == to bring the reactive variable out
#6. name each variables with prefix to aviod name conflict
#7  global data frame sampleInfo as the sample profiles
#8. touch server.R to enforce the update
#9. use conditionalPanel in sidebarPanel
#10. global data frame all_parameters to get folder specific parameters
#11. reactive data is shareable
#12. To use the module for one data, put "tools	toolname" in main.profile in the folder
#13. To add parameter for a module for a folder, put "key	value" in toolname in the folder

tTest.tabPanel<-function(profile){
	tabPanel("T-test",verbatimTextOutput("tTest"))
}

tTest.sidebarPanel<-function(profile,input,session){
  conditionalPanel(condition = "input.tabs1 == 'T-test'"
           #        selectInput("tTest.type","Select a test",levels(tTest.data()$variable))
	)
}

tTest.prepareData<-function(input){
}

tTest.preparePlot<-function(input,output){
  output$tTest <- renderPrint({
	formula=paste("value ~ ",input$group_by,sep="")
	t.test(as.formula(formula),share.filteredData())
  })
}


## Script to summarise and plot coverage across targetted regions
## nb guides were designed in hg19
## ONT aligned to hg38

convertBamToGranges<-function(list){
	GRanges(seqnames = list$rname, strand = list$strand, ranges = IRanges(start = list$pos, width = list$qwidth))
}

library(Gviz)
library(vioplot)
library(Rsamtools)

library(TxDb.Hsapiens.UCSC.hg38.knownGene)
txdb <- TxDb.Hsapiens.UCSC.hg38.knownGene

# need a biostrings object for reference
library(BSgenome.Hsapiens.UCSC.hg38)
genome <- BSgenome.Hsapiens.UCSC.hg38

## define target regions
allGuides<-read.csv("../../Resources/SmokingEWAS/GuideRNAsFINAL.csv")

targetRegions<-cbind(aggregate(allGuides$hg38, by = list(allGuides$Chr), min), aggregate(allGuides$hg38, by = list(allGuides$Chr), max)$x)

targetGRanges<-GRanges(seqnames = paste0("chr", targetRegions[,1]), strand = "*", ranges = IRanges(start = targetRegions[,2], end = targetRegions[,3]))

## load coverage stats
bedg1<-read.table("SumStats/FAN62113.bedg")
bedg1<-GRanges(seqnames = bedg1$V1, strand = "*", ranges = IRanges(start = bedg1$V2, end = bedg1$V3), Depth = bedg1$V4)

bedg2<-read.table("SumStats/FAO06764.bedg")
bedg2<-GRanges(seqnames = bedg2$V1, strand = "*", ranges = IRanges(start = bedg2$V2, end = bedg2$V3), Depth = bedg2$V4)

## load bam files
what <- c("rname", "strand", "pos", "qwidth")

param <- ScanBamParam(which = targetGRanges, what = what)
bam1 <- scanBam("FAN62113/FAN62113.sorted.filtered.primary.bam", param=param)
bam2 <- scanBam("FAO06764/FAO06764.sorted.filtered.primary.bam", param=param)

bamGranges1 <- lapply(bam1, convertBamToGranges)
names(bamGranges1) <- names(bam1)
bamGranges2 <- lapply(bam2, convertBamToGranges)
names(bamGranges2) <- names(bam2)

## count number of reads in each target regions
unlist(lapply(bamGranges1, length))+ unlist(lapply(bamGranges2, length))

## create alignment tracks for plotting
alTrack1 <- AlignmentsTrack("FAN62113/FAN62113.sorted.filtered.primary.bam",
  isPaired = FALSE, genome="hg38", fill = "#009E73", col = "#009E73")
alTrack2 <- AlignmentsTrack("FAO06764/FAO06764.sorted.filtered.primary.bam",
  isPaired = FALSE, genome="hg38", fill = "#009E73", col = "#009E73")

## plot coverage within target regions
axTrack <- GenomeAxisTrack()

for(i in 1:length(targetGRanges)){
	chr<-as.character(seqnames(targetGRanges)[i])
	start<-start(targetGRanges)[i]
	stop<-end(targetGRanges)[i]
	## expand window slightly for better resolution
	windowSize<-stop-start
	start<-start-windowSize*0.1
	stop<-stop+windowSize*0.1

	idxTrack <- IdeogramTrack(genome="hg38", chromosome=chr)

	refGenes <- UcscTrack(genome="hg38", chromosome=chr, table="ncbiRefSeq", track = 'NCBI RefSeq',from=start, to=stop, trackType="GeneRegionTrack", rstarts="exonStarts", rends="exonEnds", gene="name",
							  symbol="name2", transcript="name", strand="strand", fill="#56B4E9",
							  name="NCBI RefSeq", transcriptAnnotation="symbol", collapseTranscripts = "longest")
	cpgIslands <- UcscTrack(genome="hg38", chromosome=chr, track="cpgIslandExt", from=start, to=stop,trackType="AnnotationTrack", start="chromStart", end="chromEnd", id="name",shape="box", fill="#009E73", col = "#009E73", name="CpG Islands")

	subGuides<-allGuides[which(allGuides$Chr == gsub("chr", "",chr)),]
	arrowSize<-windowSize*0.02
	subGuides$Start<-subGuides$hg38
	subGuides$End<-subGuides$hg38
	subGuides$Start[subGuides$Strand == "-1"]<-subGuides$Start[subGuides$Strand == "-1"]-arrowSize
	subGuides$End[subGuides$Strand == "1"]<-subGuides$Start[subGuides$Strand == "1"]+arrowSize

	subGuides<-GRanges(seqnames = chr, strand = subGuides$Strand, ranges = IRanges(start = subGuides$Start, end = subGuides$End))

	aTrack<-AnnotationTrack(subGuides, genome = "hg38", name = "Guides", fill = "#999999", col = "#999999")

	alTrack <- AlignmentsTrack(c(bamGranges1[[i]], bamGranges2[[i]]),
		isPaired = FALSE, genome="hg38", fill = "#E69F00", col = "#E69F00", coverageHeight = 0.2, max.height = 0.01, name = "ONT reads")

	pdf(paste0("Plots/CoverageHistogram_", chr, "_", start, "-", stop, ".pdf"), width = 10, height = 6)
	plotTracks(list(idxTrack, axTrack, refGenes,cpgIslands, aTrack, alTrack), from=start, to=stop, showTitle=TRUE, sizes = c(1,1.2,2,0.5,0.5,8))
	dev.off()
}

## count reads in regions
inTargets1<-subsetByOverlaps(bedg1, targetGRanges)
inTargets2<-subsetByOverlaps(bedg2, targetGRanges)

## calculate mean coverage within target regions
sum(width(inTargets1)*inTargets1$Depth)/sum(width(inTargets1))
nReads1<-aggregate(width(inTargets1)*inTargets1$Depth, list(as.character(seqnames(inTargets1))), sum)$x
nReads2<-aggregate(width(inTargets2)*inTargets2$Depth, list(as.character(seqnames(inTargets2))), sum)$x
nBases1<-aggregate(width(inTargets1), list(as.character(seqnames(inTargets1))), sum)$x
nBases2<-aggregate(width(inTargets2), list(as.character(seqnames(inTargets2))), sum)$x

((nReads1/nBases1)+(nReads2/nBases2))/2

for(i in 1:length(targetGRanges)){
	sum(width(inTargets1)*inTargets1$Depth)
}

## calculate mean coverage genome-wide
(sum(width(bedg1)*bedg1$Depth)/sum(width(bedg1)) +sum(width(bedg2)*bedg2$Depth)/sum(width(bedg2)))/2

## plot distribution of read lengths within each region
pdf("Plots/HistogramReadLengthsPerTarget.pdf", height = 4, width = 12)
par(mfrow = c(1,3))
for(i in 1:length(targetGRanges)){
	hist(c(width(bamGranges1[[i]]),width(bamGranges2[[i]])), main = paste0(as.character(seqnames(targetGRanges)[i]), ":", start(targetGRanges)[i], "-", end(targetGRanges)[i]), xlab = "Read length(bp)", ylab = "Number of reads", breaks = 20)
}
dev.off()

for(i in 1:length(targetGRanges)){
	print(mean(c(width(bamGranges1[[i]]),width(bamGranges2[[i]]))))
 }

 for(i in 1:length(targetGRanges)){
	print(max(c(width(bamGranges1[[i]]),width(bamGranges2[[i]]))))
 }

 for(i in 1:length(targetGRanges)){
	print(sum(c(width(bamGranges1[[i]]),width(bamGranges2[[i]])) > 10000))
<<<<<<< HEAD
 }
=======
 }
>>>>>>> 638f31e2662b1d1498cd237a8809634e886c7425


##
## Code to reproduce the analysis in Thomas et al. "The narrow gap between norms and cooperative behaviour in a reindeer herding community"
##
## Author: Matthew Gwynfryn Thomas (@matthewgthomas)
##
## Requires the following packages:
## - tidyverse
## - readxl
## - data.table
## - igraph
## - proxy
## - ggplot2
## - amen
## - bayesplot
## - rstanarm
## - loo (currently the development version, so can run model_weights())
## - gridExtra
## - broom
## - reshape2
## - rmarkdown
## - futile.logger
##
# set up log file
library(futile.logger)
flog.appender(appender.file(paste0("analysis - ", format(Sys.time(), "%Y-%m-%d %H_%M_%S"), ".log")))  # create timestamped log file

# this data preparation step was run on the raw data to create processed data loaded by 'init.r' and analysed below
# (raw data are not available as part of this project for reasons of confidentiality)
#source("data prep.r")  # see the data coding and transformations doc for an explanation of this step

source("init.r")
source("init plots.r")

source("plot gift distribution.r")

source("social network analysis - reciprocity.r")
source("social network analysis - degree and gifts.r")
source("social network analysis - similarity.r")

source("social relations model - fit.r")      # (this takes a bit of time to fit all the models)
source("social relations model - compare.r")
source("social relations model - analyse.r")

rmarkdown::render("results text.r", "word_document", output_dir=results.dir)  # this produces the in-text statistics

flog.info("Finished analysis!")


#!/usr/bin/Rscript

## Author: David Eccles (gringer), 2008 <programming@gringer.org>

## gt2pw.r -- Calculate allele sharing values across all markers for all individuals in the input file

# usage: ./gt2pw.pl <input>
# where <input> is formatted as follows
# <marker>  aa aa ga ca ...

usage <- function(){
  cat("usage: ./gt2pw.r <simplegt file> [options]\n");
  cat("\nOther Options:\n");
  cat("-help               : Only display this help message\n");
  cat("-clustersize        : Number of parallel processes\n");
  cat("-usempi             : Use MPI for parallel cluster\n");
  cat("-makeimage          : Create an image after calculating matrix\n");
  cat("-dendrogram         : Create a sorted dendrogram after matrix\n");
  cat("\n");
}

loadData <- function(con, indivs, skip = 0, nlines = 1000){
  ## 1) Read in data
  gtData <- scan(con, skip = skip, what = character(), nlines =
                 nlines, quiet = TRUE);
  if(length(gtData)>0){
    ## 2) Extract markers
    markerNames <- gtData[0:(length(gtData)/(indivs+1) - 1) * (indivs+1) + 1];
    ## 3) Convert genotypes
    ## factor to make genotype substitutions easier
    gtData <-
    factor(gtData[-(0:(length(gtData)/(indivs+1) - 1) * (indivs+1) + 1)]);

    ## combine complementary genotypes
    ## 0: homozygous A/T
    ## 1: heterozygous A/T|C/G
    ## 2: homozygous C/G

    ## Aside: An alternative way to do this would be considering
    ## minor/major alleles. This would have benefits because the "D'-ish"
    ## distance calculation would be more accurate. However, determining
    ## the minor/major alleles per marker would take longer. The
    ## implementation of such a method would probably be something like
    ## subtracting the above values from 2 if the mean value exceeded 1,
    ## meaning you'd still lose out for genotypes with complementary
    ## alleles.
    ## 0: homozygous major allele
    ## 1: heterozygous major/minor
    ## 2: homozygous minor allele

    levels(gtData)[grep("([AT][AT])",levels(gtData))] <- 0;
    levels(gtData)[grep("([AT][CG]|[CG][AT])",levels(gtData))] <- 1;
    levels(gtData)[grep("([CG][CG])",levels(gtData))] <- 2;

    ## convert to numeric vector for easier dist calculations
    warnVal <- getOption("warn");
    options(warn = -1); # ignore NA conversion warning -- we want
                        # other values to be converted to NA
    gtData <- as.numeric(levels(gtData))[gtData];
    options(warn = warnVal);

    ## redim because factor/numeric conversion kills dimensions
    dim(gtData) <- c(indivs, length(gtData)/indivs);
    colnames(gtData) <- markerNames;
    if(indivLabels[1] != FALSE){
      rownames(gtData) <- indivLabels;
    }

    ## Note: a marker distance calculation similar to D' can be
    ## generated by substituting gtData with t(gtData) in the return
    ## value. Be aware that a ~500,000x500,000 matrix generated from
    ## that off the Affymetrix chip is *large*, and probably will
    ## cause R (and possibly the host computer) to freeze.
    cat("L", file=stderr());
    return(gtData);
  } else {
    return (integer());
  }
}

numClusters <- 2; # number of processors in the cluster
argLoc <- 1;      # any more than ~20, and R memory
inFile <- FALSE;  # limits will probably come into play
skipVal <- 0;
indSeq <- FALSE;
indivLabels <- FALSE;
numIndivs <- 0;
splitPoint <- FALSE;
useMPI <- FALSE; # use MPI for parallel interface
makeDendrogram <- FALSE; # If TRUE, make a sorted heatmap with dendrogram (slow)
makeImage <- FALSE; # Given that this generates a ~550MB PDF file for
                    # the T1D data, It's not a good idea to enable
                    # this for large input files

argLoc <- grep("--args",commandArgs()) + 1; # hack to get around R v2.4
                                            # issue stopping
                                            # commandArgs(TRUE) from
                                            # working
rVersion <- paste(R.Version()$major,substr(R.Version()$minor,1,1),sep=".")
cat("R Version: ", rVersion, "\n",
    file = stderr(), sep = "");

while(!is.na(commandArgs()[argLoc])){
  cat("Processing argument '", commandArgs()[argLoc], "'\n",
      file = stderr(), sep = "");
  if(file.exists(commandArgs()[argLoc])){ # file existence check
    if(inFile == FALSE){
      inFile <- gzfile(commandArgs()[argLoc]);
      ## check for header line
      z <- scan(inFile, nlines = 1, what = character(), quiet = TRUE);
      if((length(z) > 0) && (z[1] == "##")){
        indPos <- grep("IDs:",z);
        endPos <- grep(">",z);
        ## Determine individual labels
        ## This works even if more than one <ID> region is present in the
        ## header line, as might be the case in a 'join'ed file
        if(length(indPos) > 0){
          indSeq <- integer(0);
          indivLabels <- character(0);
          for(x in 1:length(indPos)){
            indSeq <- (indPos[x] + 1):(endPos[x] - 1);
            indivLabels <- c(indivLabels,z[indSeq]);
          }
          numIndivs <- length(indivLabels);
        }
        skipVal <- 1;
      } else {
        # header not included, so don't label individuals
        # an alternate decision would be to label them as 1:numIndivs
        numIndivs <- length(z) - 1;
        indivLabels <- FALSE;
      }
    } else{
      cat("Error: More than one input file specified\n", file = stderr());
      usage();
      quit(save = "no", status=1);
    }
  } else {
    if(commandArgs()[argLoc] == "-help"){
      usage();
      quit(save = "no", status=0);
    }
    if(commandArgs()[argLoc] == "-clustersize"){
      numClusters <- as.numeric(commandArgs()[argLoc + 1]);
      argLoc <- argLoc + 1;
    }
    if(commandArgs()[argLoc] == "-usempi"){
      useMPI <- TRUE;
    }
    if(commandArgs()[argLoc] == "-makeimage"){
      makeImage <- TRUE;
    }
    if(commandArgs()[argLoc] == "-dendrogram"){
      makeImage <- TRUE;
      makeDendrogram <- TRUE;
    }
  }
  argLoc <- argLoc + 1;
}

if(inFile == FALSE){
  cat("Error: No [valid] input file specified\n", file = stderr());
  usage();
  quit(save="no", status = 3);
}

## Extract genotype data, store in large array
open(inFile);
indDists <- 0;
## This section has been modified to (hopefully) work better in a
## computing cluster

## Package requirements... each version needs a different compile dir.
## If the package is not installed in R, this will try to compile it
## from a source file from a subdirectory ('Rlib/src') off the current
## directory.
if(!require(snow) && !require(snow, lib.loc =
                              paste("~/Rlib",rVersion,sep="/"))){
  install.packages("~/Rlib/src/snow_0.3-3.tar.gz",
                   lib=paste("~/Rlib",rVersion,sep="/"), repos=NULL);
  library(snow, lib.loc = paste("~/Rlib",rVersion,sep="/"));
}
if(useMPI){
  if(!require(Rmpi) && !require(Rmpi, lib.loc =
                                paste("~/Rlib",rVersion,sep="/"))){
    install.packages("~/Rlib/src/Rmpi_0.5-5.tar.gz",
                     lib=paste("~/Rlib",rVersion,sep="/"), repos=NULL);
    library(Rmpi, lib.loc = paste("~/Rlib",rVersion,sep="/"));
  }
}

cl <- NULL;
if(useMPI){
  cl <- getMPIcluster();
}
loadedCluster <- FALSE; # indicates that the cluster was [not] created in R
if(is.null(cl)){
  loadedCluster <- TRUE;
  cat("Creating", if(useMPI){"MPI"}, "cluster...", file = stderr());
  if(useMPI){
    cl <- makeMPIcluster(numClusters);
  } else {
    cl <- makeCluster(numClusters);
  }
  cat("done!\n", file = stderr());
}
cat("Loading genotype data:\n[one 'LD' pair per 1000 lines]\n", file=stderr());
numIterations <- 0;
numClusters <- length(cl);
retVal <- rep(list(c(NA,NA)),numClusters);
while(length(retVal[[numClusters]]) > 1){
  ## using replicate on master to (hopefully) avoid race conditions
  ## regarding file access
  retVal <- replicate(numClusters, loadData(inFile, indivs =
                      numIndivs, skip = skipVal), simplify = FALSE);
  ## Calculate distance matrix
  ## Note: this is what everything else was leading up to
  ## explanation of manhattan method from R help:
  ##  'manhattan': Absolute distance between the two vectors (1 norm).
  distRes <- clusterApply(cl, retVal, dist, method = "manhattan");
  for(repNum in 1:numClusters){
    if(length(retVal[[repNum]]) > 1){
      indDists <- indDists + distRes[[repNum]];
      cat("D", file=stderr());
    }
  }
  numIterations <- numIterations + 1;
}
close(inFile);
cat("\ndone!\n", file=stderr());
if(loadedCluster){
  cat("Stopping cluster...", file = stderr());
  stopCluster(cl);
  cat("done!\n", file = stderr());
}

write.csv(as.matrix(indDists));

if(makeImage){
  pdf("output_pwheatmap.pdf",width = 30, height = 30);
  indMat <- as.matrix(indDists);
  rm(indDists);
  diag(indMat) <- NA; ## ignore comparisons of individuals to themselves
  if(!makeDendrogram){
    image(1:numIndivs, 1:numIndivs, t(indMat)[ncol(indMat):1,], axes =
          FALSE, col = topo.colors(100), xlab = "", ylab = "");
    if(indivLabels[1] != FALSE){
      axis(1, 1:numIndivs, labels = indivLabels, las = 2, line = -0.5,
           tick = 0);
      axis(4, 1:numIndivs, labels = indivLabels, las = 2, line = -0.5,
           tick = 0);
    }
  } else {
    heatmap(indMat, col = topo.colors(100), symm = TRUE);
  }
  dummy <- dev.off();
}


 #SNOPSIS

 #visualizes genetic gain using boxplot.

 #AUTHOR
 # Isaak Y Tecle (iyt2@cornell.edu)

options(echo = FALSE)

library(data.table)
#library(phenoAnalysis)
library(dplyr)
library(methods)
library(ggplot2)
#library(plotly)

allArgs <- commandArgs()

outputFiles <- scan(grep("output_files", allArgs, value = TRUE),
                    what = "character")

inputFiles  <- scan(grep("input_files", allArgs, value = TRUE),
                   what = "character")

trGebvFiles <- grep("training", inputFiles, value = TRUE)

message('training file: ', trGebvFiles)

slGebvFiles <- grep("selection", inputFiles, value = TRUE)

message('selection file: ', slGebvFiles)

boxplotFile <-  grep("genetic_gain_plot", outputFiles, value = TRUE)
message('boxplot file: ', boxplotFile)

plotDataFile <-  grep("genetic_gain_data", outputFiles, value = TRUE)
message('boxplot file: ', plotDataFile)

trGebv   <- c()
gebvsCol <- 'GEBVs'

for (trGebvFile in trGebvFiles) {
    gebv <- data.frame(fread(trGebvFile, header = TRUE))
    trait <- names(gebv)[2]
    colnames(gebv)[2] <- gebvsCol
    gebv$trait <- trait
    trGebv <- bind_rows(trGebv, gebv)
}

trGebv$pop <- 'training'
slGebv <- c()

for (slGebvFile in slGebvFiles) {
    gebv <- data.frame(fread(slGebvFile, header = TRUE))
    trait <- names(gebv)[2]
    colnames(gebv)[2] <- gebvsCol
    gebv$trait <- trait
    slGebv <- bind_rows(slGebv, gebv)
}

slGebv$pop <- 'selection'

boxplotData <- bind_rows(trGebv, slGebv)
boxplotData$pop <- as.factor(boxplotData$pop)
boxplotData$trait <- as.factor(boxplotData$trait)

boxplotData$pop <- with(boxplotData, relevel(pop, "training"))

## pop       <- 'pop'
## training  <- 'training'
## selection <- 'selection'
## trait     <- 'trait'
## Gebvs     <- 'GEBVs'

bp <- ggplot(boxplotData,
             aes(y=GEBVs, x=pop, fill=pop)) +
             geom_boxplot(width=0.4) +
             stat_summary(geom="text", fun.y=quantile, size=5,
             aes(label=sprintf("%1.3f", ..y..), color=pop),
             position=position_nudge(x=0.35)) +
             theme_bw() +
             facet_wrap(~trait, ncol=2, scales="free") +
             theme(legend.position="none",
               axis.text=element_text(color='blue', size=12,  face='bold'),
               axis.title.y=element_text(color='blue'),
               axis.title.x=element_blank(),
               strip.text.x=element_text(color='blue', face='bold'))

wid <- 480 * if(length(trGebvFiles) > 1) 2 else 1;

png(boxplotFile, width=wid)
bp
dev.off()

if (length(plotDataFile) != 0 ) {
    fwrite(boxplotData,
       file      = plotDataFile,
       sep       = "\t",
       row.names = FALSE,
       quote     = FALSE,
       )

}

q(save = "no", runLast = FALSE)


words = tolower(readLines("http://wiki.puzzlers.org/pub/wordlists/unixdict.txt"))
ie.npc = sum(grepl("(?<!c)ie", words, perl = T))
ei.npc = sum(grepl("(?<!c)ei", words, perl = T))
ie.pc = sum(grepl("cie", words, fixed = T))
ei.pc = sum(grepl("cei", words, fixed = T))

p1 = ie.npc > 2 * ei.npc
p2 = ei.pc > 2 * ie.pc

message("(1) is ", (if (p1) "" else "not "), "plausible.")
message("(2) is ", (if (p2) "" else "not "), "plausible.")
message("The whole phrase is ", (if (p1 && p2) "" else "not "), "plausible.")


#This function constructs DotPlot with cluster coloring taken over all cell types. Written by Leonid Uroshlev, 21.01.2021

if(!require( ggplot2)){
  install.packages("ggplot2")
}
library("ggplot2")

if(!require( dplyr)){
  install.packages("dplyr")
}
library("dplyr")

if(!require( tidyr)){
  install.packages("tidyr")
}
library("tidyr")

library("Seurat")

PercentAbove<- function(x, threshold){
  return(length(x = x[x > threshold]) / length(x = x))
}

dotPlotBalanced <- function(
  object,
  genes.plot,
  cols.use = c("lightgrey", "blue"),
  col.min = -2.5,
  col.max = 2.5,
  dot.min = 0,
  dot.scale = 6,
  group.by,
  plot.legend = FALSE,
  do.return = FALSE,
  x.lab.rot = FALSE,
  scale.by = "radius"
) {
  if (! missing(x = group.by)) {
    object <- SetAllIdent(object = object, id = group.by)
  }
  data.to.plot <- data.frame(FetchData(object = object, vars.all = genes.plot))
  data.to.plot$cell <- rownames(x = data.to.plot)
  data.to.plot$id <- object@ident
  data.to.plot %>% gather(
    key = genes.plot,
    value = expression,
    -c(cell, id)
  ) -> data.to.plot
  data.to.plot %>%
    group_by(id, genes.plot) %>%
    summarize(
      avg.exp = mean(expm1(x = expression)),
      pct.exp = PercentAbove(x = expression, threshold = 0)
    ) -> data.to.plot
  data.to.plot %>%
    ungroup() %>%
    mutate(avg.exp.scale = scale(x = avg.exp)) %>%
    mutate(avg.exp.scale = MinMax(
      data = avg.exp.scale,
      max = col.max,
      min = col.min
    )) ->  data.to.plot
  data.to.plot$genes.plot <- factor(
    x = data.to.plot$genes.plot,
    levels = rev(x = sub(pattern = "-", replacement = ".", x = genes.plot))
  )
  data.to.plot$pct.exp[data.to.plot$pct.exp < dot.min] <- NA
  p <- ggplot(data = data.to.plot, mapping = aes(x = genes.plot, y = id)) +
    geom_point(mapping = aes(size = pct.exp, color = avg.exp.scale)) +
    scale_radius(range = c(0, dot.scale)) +
    scale_color_gradient(low = cols.use[1], high = cols.use[2]) +
    theme(axis.title.x = element_blank(), axis.title.y = element_blank())
  if (! plot.legend) {
    p <- p + theme(legend.position = "none")
  }
  if (x.lab.rot) {
    p <- p + theme(axis.text.x = element_text(angle = 90, vjust = 0.5))
  }
  suppressWarnings(print(p))
  if (do.return) {
    return(p)
  }
}


#' @title point2PolygonDist
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
point2PolygonDist <- function(poly, pt){
	require(PBSmapping)
	attr(poly,'projection') <-"LL"
	attr(pt,'projection') <-"LL"
	attr(poly,'zone') <- 20
	attr(pt,'zone') <- 20
	poly	= convUL(poly)
	pt 		= convUL(pt)
	pp <-  dist2Line(pt[,c('X','Y')],poly[,c('X','Y')])
	pt$dist <- pp[,1]/1000
	pt <- convUL(pt)
return(pt)
}


# user options

last.assessment.year<-2009
last.year.in.forecast<-2014
years.in.refernce.F<-1  #take the last X years mean F and used them for reference mean F

TACfirst<-548  # TAC for the intermidiate year, used for output only

# percentiles, put =c() for none
percentiles<-c(0.025,0.25,0.50,0.75,0.975)
percentiles<-c()

incl.prob.below.SSB.refernce.point<-F

if (T) {  #constant F
  HCR.rule<-1
  #Fsq<-0.453
  Fsq<-1
  Fpa<-0.32
  F2009<-0.399
  HCR.options.file<-'HCR_options.dat'  #option file for prediction
#  ICES.F.levels<-c(0.0001,0.10,0.25,0.50,0.75,0.90,1.00,1.10,1.25,Fsq/Fpa)
#  ICES.basis<-paste('Fpa*',round(ICES.F.levels,2),sep='')
#  iterations<-ICES.F.levels*Fpa    # levels times Fpa

  ICES.F.levels<-c(0.000, F2009*0.1 , F2009*0.25 , F2009*0.50 ,0.05             ,0.0636528       ,0.156237354,         0.18         ,F2009*0.75,F2009        ,0.32 )   # please note, you cannot have the same value twice
  ICES.basis<-   c("F=0","F2009*0.1","F2009*0.25","F2009*0.50","Management plan","MSY Framework","ICES MSY transition","FMSY","F2009*0.75","Fsq=F2009","F=Fpa")
  cbind(ICES.basis, ICES.F.levels)
  iterations<-ICES.F.levels    # levels times Fpa

  #iterations<-c(0.0,0.32,0.51,1.0)  # F values

  ICES.basis<-ICES.basis[order(ICES.F.levels)]
}
if (F) {  #constant TAC
  HCR.rule<-2
  Fsq<-0.453
  Fpa<-0.32
  HCR.options.file<-'HCR_options_constantTAC.dat'  #option file for prediction
  ICES.F.levels<-c(1.6E6,1.747E6)
  ICES.basis<-paste(round(ICES.F.levels,3),sep='')
  iterations<-ICES.F.levels
}

Landings.fac<-1E3  # factor applied in output tables for nice output
SSB.fac<-1E3
TSB.fac<-1E3

short.out<-'short-term.csv'               #output file
short.out.ICES<-'short-term-ICES.csv'     #output file, speciial ICES format

######### end user options #########
do.HCR.short.term<-function() {

scenario<-"Short-term"
outdir<-file.path(data.path,scenario)

setwd(data.path)
bio.interact<-FALSE

#  runs are made in a separate dirictory
scenario.dir<-scenario

dir.create(scenario.dir,showWarnings = FALSE)

SMS.files.single<-c("sms.exe","natmor.in","canum.in","west.in","weca.in","propmat.in","fleet_catch.in",
                    "fleet_names.in","fleet_info.dat","just_one.in","sms.psv","species_names.in",
                    "SSB_R.in","Prediction_F.in","reference_points.in","predict_stock_N.in",
                    "Exploitation_pattern.in","zero_catch_season_ages.in","zero_catch_year_season.in","proportion_M_and_F_before_spawning.in")

for (from.file in SMS.files.single) {
  to.file<-file.path(data.path,scenario.dir,from.file)
  file.copy(from.file, to.file, overwrite = TRUE)
}

# read data and options into FLR objects
control<-read.FLSMS.control()
HCR<-read.FLSMS.predict.control(control=control,file=HCR.options.file)

sp.name<-control@species.names

setwd(outdir)
write.FLSMS.control(control,file='SMS.dat')

iter<-0

for (option in (iterations)) {
    iter<-iter+1

    print(paste("Iteration:",iter))

    HCR@no.MCMC.iterations <-1

    if (HCR.rule==1) {
      HCR@HCR[1]<-1    # constant F
      HCR@constant.F[1,1]<-option
    }
    if (HCR.rule==2) {
      HCR@HCR[1]<-2    # constant TAC
      HCR@constant.TAC[1,1]<-option
    }

    write.FLSMS.predict.control(HCR,control,file='HCR_options.dat')

    #run SMS
    shell(paste( file.path(data.path,"sms.exe")," -mceval",sep=" "), invisible = TRUE)

    a<-Read.MCMC.SSB.rec.data(dir=outdir)
    a<-subset(a,Year>=last.assessment.year & Year<=last.year.in.forecast ,drop=T)
    if (iter==1) b1<-data.frame(option=option,a)
    else b1<-rbind(b1,data.frame(option=option,a))

    a<-Read.MCMC.F.yield.data(dir=outdir)
    a<-subset(a,Year>=last.assessment.year & Year<=last.year.in.forecast ,drop=T)
    if (iter==1) b2<-data.frame(option=option,a)
    else b2<-rbind(b2,data.frame(option=option,a))
  }

  setwd(data.path)

  # prepare to get SSB next year in the same row
  b.plus<-data.frame(option=b1$option,Species=b1$Species,Species.n=b1$Species.n, Year=b1$Year-1, Repetion=b1$Repetion,
                       Iteration=b1$Iteration,SSB.plus=b1$SSB,TSB.plus=b1$TSB,recruit.plus=b1$recruit)

  b<-merge(b1,b2)
  b<-merge(b,b.plus)
  b<-subset(b,select=-mean_F_percieved)

  tmp<-Read.MCMC.mean.data(dir=outdir)
  tmp<-subset(tmp,Year>=last.assessment.year-years.in.refernce.F+1 & Year<=last.assessment.year)
  ref.F<-tapply(tmp$mean.F,list(tmp$Species), mean)
  list(ref.F=ref.F,result=b)
}
short.results<-do.HCR.short.term()

#Read refence points from file reference_points.in
ref<-Read.reference.points()
blim<-ref[1,"Blim"]
bpa<-ref[1,"Bpa"]
T1<-blim
T2<-bpa

print.result<-function(act.year=last.assessmet.year+1) {
  comma<-','
  if (act.year==last.assessment.year+1) {
    cat(act.year,'\n',file=short.out)
    cat("Biomass,SSB,FMult,FBar,Landings\n",file=short.out,append=T)
    cat(act.year,'\n',file=short.out.ICES)
    cat("Biomass,SSB,FMult,FBar,Landings\n",file=short.out.ICES,append=T)

  }

  tmp<-subset(short.results[['result']],Year==act.year)
  ref.F<-short.results[['ref.F']]

  if (!is.null(percentiles)) {
    p.TSB<-tapply(tmp$TSB/SSB.fac,list(tmp$option), function(x) quantile(x,probs = percentiles))
    p.SSB<-tapply(tmp$SSB/SSB.fac,list(tmp$option), function(x) quantile(x,probs = percentiles))
    p.Yield<-tapply(tmp$Yield/Landings.fac,list(tmp$option), function(x) quantile(x,probs = percentiles))
    p.mean.F<-tapply(tmp$mean.F,list(tmp$option), function(x) quantile(x,probs = percentiles))
    p.TSB.plus<-tapply(tmp$TSB.plus/SSB.fac,list(tmp$option), function(x) quantile(x,probs = percentiles))
    p.SSB.plus<-tapply(tmp$SSB.plus/SSB.fac,list(tmp$option), function(x) quantile(x,probs = percentiles))
  }

  TSB<-tapply(tmp$TSB,list(tmp$option), mean)/TSB.fac
  SSB<-tapply(tmp$SSB,list(tmp$option), mean)/SSB.fac
  Yield<-tapply(tmp$Yield,list(tmp$option), mean)/Landings.fac
  mean.F<-tapply(tmp$mean.F,list(tmp$option), mean)
  SSB.plus<-tapply(tmp$SSB.plus,list(tmp$option), mean)/SSB.fac
  TSB.plus<-tapply(tmp$TSB.plus,list(tmp$option), mean)/TSB.fac

  #probability to go below Bpa and Blim
  q<-tapply(tmp$SSB.plus,list(tmp$option,tmp$Repetion,tmp$Iteration),sum)
  q[q>T1]<-0
  q[q>0]<-1
  p.Blim<-apply(q,1,sum)/(dim(q)[2]*dim(q)[3])

  q<-tapply(tmp$SSB.plus,list(tmp$option,tmp$Repetion,tmp$Iteration),sum)
  q[q>T2]<-0
  q[q>0]<-1
  p.Bpa<-apply(q,1,sum)/(dim(q)[2]*dim(q)[3])

  if (act.year==last.assessment.year+1) {
   cat(TSB[1],comma,SSB[1],comma,mean.F[1]/ref.F,comma,mean.F[1],comma,Yield[1],'\n',file=short.out,append=T)
   cat(TSB[1],comma,SSB[1],comma,mean.F[1]/ref.F,comma,mean.F[1],comma,Yield[1],'\n',file=short.out.ICES,append=T)

  }
  else {
    cat('\n',act.year,",,,,,,",act.year+1,"\n",file=short.out,append=T)
    cat("\n",file=short.out.ICES,append=T)
    cat("Biomass,SSB,FMult,FBar,Landings,,Biomass,SSB",file=short.out,append=T)
    cat("Rationale,Catch(",act.year,"),Basis,F(",act.year,"),SSB(",act.year,"),SSB(",act.year+1,"), %SSB change, %TAC change",sep='',file=short.out.ICES,append=T)

    if (incl.prob.below.SSB.refernce.point) cat(",P(SSB<Bpa),P(SSB<Blim)\n",file=short.out,append=T)
    else cat("\n",file=short.out,append=T)

    if (incl.prob.below.SSB.refernce.point) cat(",P(SSB<Bpa),P(SSB<Blim)\n",file=short.out.ICES,append=T)
    else cat("\n",file=short.out.ICES,append=T)

    for (i in (1:length(SSB))) {
     if ((i==1) | (act.year>last.assessment.year+2)) cat(TSB[i],comma,SSB[i],comma,file=short.out,append=T)
     else cat(".,.,",file=short.out,append=T)
     cat(mean.F[i]/ref.F,comma,mean.F[i],comma,Yield[i],comma,comma,TSB.plus[i],comma,SSB.plus[i],file=short.out,append=T)
     if (incl.prob.below.SSB.refernce.point) cat(comma,p.Bpa[i],comma,p.Blim[i],"\n",file=short.out,append=T)
     else cat("\n",file=short.out,append=T)
    }

    for (i in (1:length(SSB))) {
     cat(comma,Yield[i],comma,ICES.basis[i],comma,mean.F[i],comma,SSB[i],comma,SSB.plus[i],comma,round((SSB.plus[i]-SSB[i])/SSB[i]*100),comma,file=short.out.ICES,append=T)
     if (act.year==last.assessment.year+2) cat(round((Yield[i]-TACfirst)/TACfirst*100),file=short.out.ICES,append=T)
    if (incl.prob.below.SSB.refernce.point) cat(comma,p.Bpa[i],comma,p.Blim[i],"\n",file=short.out.ICES,append=T)
     else cat("\n",file=short.out.ICES,append=T)

    }
   }
}

for (y in seq(1,4)) print.result(last.assessment.year+y)


#install.packages('prophet', type="source")
#install.packages('magrittr', type="source")

library(prophet)
library(magrittr)

crimes2007_2018= read.csv("/Users/tcrokicki/Documents/WorcesterData.csv")
crimes2007_2018$ACTUAL_DTE <- as.Date(crimes2007_2018$ACTUAL_DTE, format = "%Y-%m-%d %H:%M:%S")
by_Date <- na.omit(crimes2007_2018) %>% group_by(ACTUAL_DTE) %>% summarise(Total = n())
tseries <- xts(by_Date$Total, order.by=as.POSIXct(by_Date$ACTUAL_DTE))
df <- crimes2007_2018 %>% group_by(ACTUAL_DTE) %>% summarise(y = n()) %>% mutate(y = log(y))
names(df) <- c("ds", "y")
df$ds <- factor(df$ds)
hchart(tseries, name = "Crimes") %>%
+   hc_add_theme(hc_theme_darkunica()) %>%
+   hc_credits(enabled = TRUE, text = "Sources: City of Worcester Administration and the Worcester Police Department", style = list(fontSize = "12px")) %>%
+   hc_title(text = "Times Series plot of Worcester Crimes") %>%
+   hc_legend(enabled = TRUE)


library(ggplot2)
library(reshape2)
library(rtracklayer)
library(ggpubr)
library(purrr)
library(GenomicRanges)
library(pheatmap)

source('./code/bwutils.r')
source('./code/heatmap_utils.r')

chromhmm.file <- './data/bed/ChromHMM17.bed'
bw.dir <- './data/bw/'
out.dir <- './final_figures/05_ext/'

# Keep the order
levels.order <- c('1_Txn_Elongation',
                  '2_Weak_Txn',
                  '3_Txn_Transition',
                  '4_Poised_Enhancer',
                  '5_Active_Promoter',
                  '6_Strong_Enhancer',
                  '7_Active_Promoter',
                  '8_Strong_Enhancer',
                  '9_Strong_Enhancer',
                  '10_Poised_Promoter',
                  '11_Repressed',
                  '12_Heterochrom',
                  '13_Heterochrom',
                  '14_Heterochrom',
                  '15_Insulator',
                  '16_H3K9_Hetero',
                  '17_H3K9_H33_Hetero')

# Panel 1: ESC H3.3 SNAP time log2 fold change normalized to input replicate 1
files <- paste0(bw.dir, c(
  'Deaton_2016/ES_H33_00h_rep1.bw',
  'Deaton_2016/ES_H33_03h_rep1.bw',
  'Deaton_2016/ES_H33_06h_rep1.bw',
  'Deaton_2016/ES_H33_12h_rep1.bw'
))

files.inp <- paste0(bw.dir, c(
  'Deaton_2016/ES_H33_inp_rep1.bw'
))

summaries <- map(files, summarize.by.bed, bed.file <- chromhmm.file, drop.name.col=F)
df.fg <- Reduce(function(...) merge(..., all=TRUE), summaries)
rownames(df.fg) <- df.fg$name
df.fg$name <- NULL

input <- summarize.by.bed(files.inp[[1]], chromhmm.file)
df.logfc <- log2(sweep(df.fg, 1, input$ES_H33_inp_rep1.bw, `/`))

colnames(df.logfc) <- c('0h','3h', '6h', '12h')
out.file <- paste0(out.dir, 'ES_SNAP_logfc_cov_enrichment_rep1.pdf')
summarized.heatmap(t(df.logfc[levels.order, ]), out.file, "ESC H3.3-SNAP Time-ChIP (Replicate 1)")

# Panel 2: ESC H3.3 SNAP time log2 fold change normalized to input replicate 2
files <- paste0(bw.dir, c(
  'Deaton_2016/ES_H33_00h_rep2.bw',
  'Deaton_2016/ES_H33_03h_rep2.bw',
  'Deaton_2016/ES_H33_06h_rep2.bw',
  'Deaton_2016/ES_H33_12h_rep2.bw'
))

files.inp <- paste0(bw.dir, c(
  'Deaton_2016/ES_H33_inp_rep2.bw'
))

summaries <- map(files, summarize.by.bed, bed.file <- chromhmm.file, drop.name.col=F)
df.fg <- Reduce(function(...) merge(..., all=TRUE), summaries)
rownames(df.fg) <- df.fg$name
df.fg$name <- NULL

input <- summarize.by.bed(files.inp[[1]], chromhmm.file)
df.logfc <- log2(sweep(df.fg, 1, input$ES_H33_inp_rep2.bw, `/`))

colnames(df.logfc) <- c('0h','3h', '6h', '12h')
out.file <- paste0(out.dir, 'ES_SNAP_logfc_cov_enrichment_rep2.pdf')
summarized.heatmap(t(df.logfc[levels.order, ]), out.file, "ESC H3.3-SNAP Time-ChIP (Replicate 2)")

# Panel 2: ESC H3.3 SNAP time log2 fold change normalized to input replicate 3
files <- paste0(bw.dir, c(
  'Deaton_2016/ES_H33_00h_rep3.bw',
  'Deaton_2016/ES_H33_03h_rep3.bw',
  'Deaton_2016/ES_H33_06h_rep3.bw',
  'Deaton_2016/ES_H33_12h_rep3.bw'
))

files.inp <- paste0(bw.dir, c(
  'Deaton_2016/ES_H33_inp_rep2.bw'
))

summaries <- map(files, summarize.by.bed, bed.file <- chromhmm.file, drop.name.col=F)
df.fg <- Reduce(function(...) merge(..., all=TRUE), summaries)
rownames(df.fg) <- df.fg$name
df.fg$name <- NULL

input <- summarize.by.bed(files.inp[[1]], chromhmm.file)
df.logfc <- log2(sweep(df.fg, 1, input$ES_H33_inp_rep2.bw, `/`))

colnames(df.logfc) <- c('0h','3h', '6h', '12h')
out.file <- paste0(out.dir, 'ES_SNAP_logfc_cov_enrichment_rep3.pdf')
summarized.heatmap(t(df.logfc[levels.order, ]), out.file, "ESC H3.3-SNAP Time-ChIP (Replicate 3)")