SUPPORTED_MODELS <- c(
	"cforest", "ctree", "gam::gam", "mgcv::gam", "mgcv::gamm", "gbm", "glm",
	"glmer", "glmmadmb", "glmmML", "lm",  "lme", "lmer", "MCMCglmm",
	"randomForest", "ranger", "rpart", "svm", "tree"
)


function(input, output) {
  output$plot1 <- renderPlot({
    hist(
      rnorm(input$n),
      # color,border is added to allow for <= Rv3.6 (white) to match >= Rv 4.0 (grey)
      col = "white", border = "grey"
    )
  })

  output$textout <- renderText({
    paste("Input text is:", input$text)
  })
}


h2o.glm.1 <- function(..., alpha = 0.0) h2o.glm.wrapper(..., alpha = alpha)
h2o.glm.2 <- function(..., alpha = 0.5) h2o.glm.wrapper(..., alpha = alpha)
h2o.glm.3 <- function(..., alpha = 1.0) h2o.glm.wrapper(..., alpha = alpha)
h2o.randomForest.1 <- function(..., ntrees = 200, nbins = 50, seed = 1) h2o.randomForest.wrapper(..., ntrees = ntrees, nbins = nbins, seed = seed)
h2o.randomForest.2 <- function(..., ntrees = 200, sample_rate = 0.75, seed = 1) h2o.randomForest.wrapper(..., ntrees = ntrees, sample_rate = sample_rate, seed = seed)
h2o.randomForest.3 <- function(..., ntrees = 200, sample_rate = 0.85, seed = 1) h2o.randomForest.wrapper(..., ntrees = ntrees, sample_rate = sample_rate, seed = seed)
h2o.randomForest.4 <- function(..., ntrees = 200, nbins = 50, balance_classes = TRUE, seed = 1) h2o.randomForest.wrapper(..., ntrees = ntrees, nbins = nbins, balance_classes = balance_classes, seed = seed)
h2o.gbm.1 <- function(..., ntrees = 100, seed = 1) h2o.gbm.wrapper(..., ntrees = ntrees, seed = seed)
h2o.gbm.2 <- function(..., ntrees = 100, nbins = 50, seed = 1) h2o.gbm.wrapper(..., ntrees = ntrees, nbins = nbins, seed = seed)
h2o.gbm.3 <- function(..., ntrees = 100, max_depth = 10, seed = 1) h2o.gbm.wrapper(..., ntrees = ntrees, max_depth = max_depth, seed = seed)
h2o.gbm.4 <- function(..., ntrees = 100, col_sample_rate = 0.8, seed = 1) h2o.gbm.wrapper(..., ntrees = ntrees, col_sample_rate = col_sample_rate, seed = seed)
h2o.gbm.5 <- function(..., ntrees = 100, col_sample_rate = 0.7, seed = 1) h2o.gbm.wrapper(..., ntrees = ntrees, col_sample_rate = col_sample_rate, seed = seed)
h2o.gbm.6 <- function(..., ntrees = 100, col_sample_rate = 0.6, seed = 1) h2o.gbm.wrapper(..., ntrees = ntrees, col_sample_rate = col_sample_rate, seed = seed)
h2o.gbm.7 <- function(..., ntrees = 100, balance_classes = TRUE, seed = 1) h2o.gbm.wrapper(..., ntrees = ntrees, balance_classes = balance_classes, seed = seed)
h2o.gbm.8 <- function(..., ntrees = 100, max_depth = 3, seed = 1) h2o.gbm.wrapper(..., ntrees = ntrees, max_depth = max_depth, seed = seed)
h2o.deeplearning.1 <- function(..., hidden = c(500,500), activation = "Rectifier", epochs = 50, seed = 1)  h2o.deeplearning.wrapper(..., hidden = hidden, activation = activation, seed = seed)
h2o.deeplearning.2 <- function(..., hidden = c(200,200,200), activation = "Tanh", epochs = 50, seed = 1)  h2o.deeplearning.wrapper(..., hidden = hidden, activation = activation, seed = seed)
h2o.deeplearning.3 <- function(..., hidden = c(500,500), activation = "RectifierWithDropout", epochs = 50, seed = 1)  h2o.deeplearning.wrapper(..., hidden = hidden, activation = activation, seed = seed)
h2o.deeplearning.4 <- function(..., hidden = c(500,500), activation = "Rectifier", epochs = 50, balance_classes = TRUE, seed = 1)  h2o.deeplearning.wrapper(..., hidden = hidden, activation = activation, balance_classes = balance_classes, seed = seed)
h2o.deeplearning.5 <- function(..., hidden = c(100,100,100), activation = "Rectifier", epochs = 50, seed = 1)  h2o.deeplearning.wrapper(..., hidden = hidden, activation = activation, seed = seed)
h2o.deeplearning.6 <- function(..., hidden = c(50,50), activation = "Rectifier", epochs = 50, seed = 1)  h2o.deeplearning.wrapper(..., hidden = hidden, activation = activation, seed = seed)
h2o.deeplearning.7 <- function(..., hidden = c(100,100), activation = "Rectifier", epochs = 50, seed = 1)  h2o.deeplearning.wrapper(..., hidden = hidden, activation = activation, seed = seed)


library(dplyr)
arguments <- commandArgs(trailingOnly = TRUE)
print(arguments)
if (length(arguments) != 1) {
  #TODO: Remove hack.
  setwd("C:/Projects/Thesis/EncounterGenerationRPG")
} else {
  print(arguments[1])
  setwd(arguments[1])
}
getwd()
stopifnot(file.exists("rawdata.csv"))
rawData<-read.csv("rawdata.csv", header = FALSE, sep =";")
combatOnlyData<-filter(rawData, V1 == "Combat")
combatOnlyDataLoggedOnly<-filter(combatOnlyData, V30 == 1)
errors<-combatOnlyDataLoggedOnly$V26 - combatOnlyDataLoggedOnly$V27
png(file="errorGraph.png", width = 800, height = 450)
plot(errors,
     type = "b",
     main="Algorithm error over time",
     ylab="Estimate Error",
     xlab = "Combat index",
     col="blue",
     lwd = 2,
     ylim = c(-3,3))
abline(a = 0, b = 0)
dev.off()


# Define functions to use in hb-migration code
require(chron)
require(mgcv)
require(Rmisc)
require(spaa)
require(ggplot2)
require(SDMTools)

PlotRecords = function(yeardata, species) {
  #plots the number of records across the years

  t = as.data.frame(table(yeardata))
  names(t) = c('year', 'count')

  barplot = ggplot(data = t, aes(year, count)) + geom_bar(fill="cadetblue2", stat="identity") + theme_bw() +
    ggtitle(species) + theme(text = element_text(size=20)) + xlab("time") + ylab("number checklists") +
    theme(axis.text.x=element_text(angle = -60, hjust = 0))

  print(barplot)

  return(t)
}

AlternateMeanLocs = function(dat, species, hexdat, yreffort) {
  #input is a yearly data frame for a species
  #output is a new dataframe with mean lat and long, calculated from hexagon centers, after placing daily observed
  #lat and long onto the isacohedron equal-area cells map, sensu La Sorte et al. 2013
  df = data.frame("jday"=1, "month"=1, "numobs"=1, "numcells"=1, "centerlon"=1, "centerlat"=1, "sdlon"=1, "sdlat"=1)
  outcount = 1

  #count the number of days in the year
  year = dat$YEAR[1]
  numdays = as.numeric(as.POSIXlt(paste(year, "-12-31", sep = "")) - as.POSIXlt(paste(year, "-01-01", sep="")) + 1)
  julian = seq(1:numdays)

  #merge data on POLYFID so it includes the center of each hex cell (LONGITUDE.y, LATITUDE.y)
  dat_merged = merge(dat, hexdat, by.x = "POLYFID", by.y = "POLYFID")

  #aggregate daily info by mean centroid location
  dailyHexes = count(dat_merged, vars=c("DAY", "POLYFID", "LONGITUDE.y", "LATITUDE.y"))

  #calculate weighted mean (weights based on number of obs per hex and total effort per hex) LAT and LON
  for (j in 1:length(julian)){
    jdata = dailyHexes[which(dailyHexes$DAY == j),]
    jeffort = yreffort[which(yreffort$DAY == j),]
    jdata = merge(jdata, jeffort, by.x = c("POLYFID", "DAY"), by.y = c("POLYFID", "DAY"))
    if (nrow(jdata) > 0){
      numcells = nrow(jdata)
      numobs = sum(jdata$freq)
      mo = as.numeric(months(j))
      wtmean_lon = wt.mean(jdata$LONGITUDE.y, jdata$freq/jdata$COUNT)
      wtmean_lat = wt.mean(jdata$LATITUDE.y, jdata$freq/jdata$COUNT)
      lon_sd <- wt.sd(jdata$LONGITUDE.y, jdata$freq/jdata$COUNT)
      lat_sd <- wt.sd(jdata$LATITUDE.y, jdata$freq/jdata$COUNT)
      df[outcount,] = c(j, mo, numobs, numcells, wtmean_lon, wtmean_lat,lon_sd, lat_sd)
      outcount = outcount + 1
    }
    else {
      mo = as.numeric(months(j))
      df[outcount,] = c(j, mo, 0, 0, NA, NA, NA, NA)
      outcount = outcount + 1
    }
  }
  return(df)
}

DailyTravel = function(meanlocs, loncol, latcol, species, year, migr_dates){
  #use geodist to calculate Great Circle distance between daily location centers
  require(spaa)
  require(mgcv)
  dst=c(NA)

  for(i in 1:nrow(meanlocs)){
    if (i < nrow(meanlocs)){
      dist = geodist(meanlocs[i,loncol], meanlocs[i,latcol], meanlocs[i+1,loncol], meanlocs[i+1,latcol])
      if (is.nan(dist) == TRUE) {
        dist = 0  #appaarently geodist doesn't calculate zero change in location, records as NaN
      }
      dst = c(dst, dist)
    }
  }
  distdat = cbind(meanlocs,dst)

  subdistdat = distdat[which(distdat$jday >= migr_dates[[1]] & distdat$jday <= migr_dates[[3]]),]

  print(ggplot(subdistdat, aes(jday, dst)) + geom_line(size=1, col = "#4daf4a") + theme_bw() + xlab("Julian Day") +
          ylab("Distance Traveled (km)") + ggtitle(paste(species, year, sep = " ")) +
          theme(text = element_text(size=20)) +
          #geom_vline(xintercept = c(migr_dates[1], migr_dates[2]), linetype = "dashed", size = 1) +
          geom_vline(xintercept = median(migr_dates), col = "indianred", linetype = "dashed"))

  return(distdat)
}

GetBreedingDates = function(dat, migration_dates){
  # uses a generalized additive model (GAM) on latitude to estimate the end of spring and
  # begin of fall migration, which defines the time at the breeding grounds

  #get median migration date
  med = median(migration_dates)

  #GAM model on predicted latitude of centroids by julian date
  gam1 = gam(lat ~ s(jday, k = 40), data = dat, gamma = 1.5)
  xpred = data.frame(jday = c(1:max(dat$jday)))
  dpred = predict(gam1, newdata=xpred, type="response", se.fit=TRUE)

  # cutoff based on 2 SE for the breeding period, defined as +/- 30 days from the median date,
  # based on start of spring and end of fall migration in GetMigrationDates function.
  lat_threshold = min(dpred$se.fit[c((med-30):(med+30))]*2.56 + dpred$fit[c((med-30):(med+30))])
  spring_index = (med-30):med
  fall_index = med:(med+30)
  spring_max = spring_index[which.max(dpred$fit[spring_index])]
  fall_max = fall_index[which.max(dpred$fit[fall_index])]

  #identify end of spring migration
  tst = 1000
  spring_index2 = spring_max
  while(tst > lat_threshold){
    tst = dpred$fit[spring_index2]
    if(spring_index2 == 1) break
    spring_index2 = spring_index2 - 1
  }
  spring = spring_index2 + 1

  #identify beginning of fall migration
  tst <- 1000
  fall_index2 = fall_max
  while(tst > lat_threshold){
    tst = dpred$fit[fall_index2]
    if(fall_index2==365) break
    fall_index2 <- fall_index2 + 1
  }
  fall <- fall_index2 - 1

  dates = c(spring, fall)
  return(dates)
}

GetMigrationDates = function(data) {
  # uses a generalized additive model (GAM) to define the start of spring and end of fall migration

  #GAM model on number of cells with observations by julian date
  gam1 = gam(numcells ~ s(jday, k = 40), data = data, gamma = 1.5)
  xpred = data.frame(jday = c(1:max(data$jday)))
  dpred = predict(gam1, newdata=xpred, type="response", se.fit=TRUE)

  ## cutoff based on 2 SE for spring and fall combined, following La Sorte et al. 2013 methods
  # Spring migration should be between 11 Jan and 9 July
  # Fall migration should be between 8 August and 21 Dec
  spring_threshold = min(dpred$se.fit[c(1:120)]*2.56 + dpred$fit[c(1:120)])
  fall_threshold = min(dpred$se.fit[c(280:365)]*2.56 + dpred$fit[c(280:365)])
  spring_index = 11:190
  fall_index = 220:355
  spring_max = spring_index[which.max(dpred$fit[spring_index])]
  fall_max = fall_index[which.max(dpred$fit[fall_index])]

  #identify beginning of spring migration
  tst = 1000
  spring_index2 = spring_max
  while(tst > spring_threshold){
    tst = dpred$fit[spring_index2]
    if(spring_index2 == 1) break
    spring_index2 = spring_index2 - 1
  }
  spring = spring_index2 + 1

  #identify end of fall migration
  tst <- 1000
  fall_index2 = fall_max
  while(tst > fall_threshold){
    tst = dpred$fit[fall_index2]
    if(fall_index2==365) break
    fall_index2 <- fall_index2 + 1
  }
  fall <- fall_index2 - 1

  dates = c(spring, fall)
  return(dates)
}

PlotOccurrences = function(data, species, year, migration) {
  #takes a dataframe with julian dates, and the number of cells, and returns a plot with lines fitted
  # for a gam and for the onset of spring and end of fall migration
  # sensu La Sorte and Fink code from 2013 paper + new segmented approach

  occ = ggplot(data, aes(jday, numcells)) + geom_point() + xlab("julian day") + ylab("number of cells") +
    geom_smooth(se=T, method='gam', formula=y~s(x, k=40), gamma=1.5) +
    theme_bw() + ggtitle(paste(species, year, sep=" ")) + scale_x_continuous(breaks = seq(0, 365, by = 25)) +
    scale_y_continuous(breaks = seq(0, 80, by = 5)) +
    geom_vline(xintercept = migration[1], col = "cadetblue", size = 1) +
    geom_vline(xintercept = migration[3], col = "orange", size = 1) +
    geom_vline(xintercept = migration[2], col = "olivedrab3", size = 1) +
    theme(text = element_text(size=12))+
    theme(axis.text.x=element_text(angle = -60, hjust = 0))

  print(occ)
  return(occ)
}

EstimateDailyLocs = function(dat) {
  #input a dataframe with the mean daily locations for the year, and uses a GAM smoothing function
  # to estimate daily occurrence lat and long separately. Binds the fitted lat and long values together,
  # with standard errors. Returns a dataframe.
      #check choice of k and gamma in the GAM function - same as FAL 2013
  #find the best fit line for the data, for longitude and latitude separately
  lon_gam = gam(centerlon ~ s(jday, k=20), data = dat, gamma = 1.5) # TODO: consider upping gamma? and changing basis? (adaptive spline or penalized spline?)
  lat_gam = gam(centerlat ~ s(jday, k=20), data = dat, gamma = 1.5)

  #predict values along the smoothing line
  xpred = data.frame(jday=sort(unique(dat$jday)))
  lonpred = predict(lon_gam, newdata = xpred, type="response", se.fit=T)
  latpred = predict(lat_gam, newdata = xpred, type="response", se.fit=T)

  #bring the data back together
  preds =  data.frame(spname = species, jday = xpred$jday, month = dat$month, lon = lonpred$fit,
                      lat = latpred$fit, lon_se = lonpred$se.fit, lat_se = latpred$se.fit)

  return(preds)
}

PlotChecklistMap = function(humdat, hexdat, dirpath){
  require(fields)
  #plots the hexmap with the number of checklist over the entire time period color coded.
  #saves a pdf file in the species directory

  #find the number of obs in each cell
  t = table(as.factor(humdat$POLYFID))

  #Merge the count data for the hexes with all the hexes in the map
  df = data.frame(POLYFID = names(t), count=as.numeric(t))
  df2 = data.frame(POLYFID = unique(hexdat$POLYFID))
  df3 = merge(df2, df, all.x=TRUE)

  #matches colors with the number of observations
  cols = data.frame(id=c(NA,sort(unique(df3$count))), cols=tim.colors(length(unique(df3$count))), stringsAsFactors=FALSE)
  df4 = merge(df3, cols, by.x="count", by.y="id")
  df5 = merge(hexdat, df4, by.x="POLYFID", by.y="POLYFID", all.x=TRUE)

  #hexes with no counts are white
  df5$cols = ifelse(is.na(df5$count), "white", df5$cols)
  df5 = df5[order(df5$POLYFID),]

  #set scale for legend
  vls = sort(unique(round(cols$id/500)*500))
  vls[1] = 1
  cols2 = tim.colors(length(vls))

  #make a map with hexes colored by the number of times the species was observed in a given hex
  setEPS()
  postscript(paste(dirpath,"/", "ChecklistMap.eps", sep=""), width=10, height=7)
  plot(hexdat, col=df5$cols, border="gray50", lwd=0.25, xlim=c(-170,-50), ylim=c(15,75), las=1)
  axis(side=1)
  axis(side=2, las=1)
  box()
  mtext("Longitude", side=1, cex=1.4, line=2.5)
  mtext("Latitude", side=2, cex=1.4, line=2.5)
  ## legend
  legend("bottomleft", legend=vls, pch=22, pt.bg=cols2, pt.cex=1, cex=0.75, bty="",
         col="black", title="Number of checklists", x.intersp=1, y.intersp=0.5, bg="white")
  map("worldHires", c("usa", "canada", "mexico"), add=TRUE)
  dev.off()

  return(df5)
}

PlotMigrationPath = function(dat, map, species, year) {
  # makes a nice figure showing the migration trajectory of the GAM predicted daily locations, with se for longitude
  dat$month = as.factor(dat$month)

  map = ggmap(map) + geom_line(data = dat, aes(lon, lat, col=month)) +
    geom_errorbarh(data = dat, aes(xmin = lon - lon_se, xmax = lon + lon_se, col = month)) +
    xlab("Longitude") + ylab("Latitude") + ggtitle(paste(species, year, sep = " "))

  print(map)
  return(map)
}

PlotMeanLatitude = function(dat, species, year){
  #plot mean latitude for each julian day, point size represents number of checklists, returns the map object
  meanlat = ggplot(dat, aes(jday, meanlat, col=as.factor(month))) + geom_point(aes(size=count)) +
    ggtitle(paste(species, year, "latitudinal migration", sep = " ")) + xlab("Julian Day") + ylab("Mean Latitude") +
    theme_bw() +  scale_x_continuous(breaks = seq(0, 365, by = 25)) +
    scale_y_continuous(breaks = seq(15, 75, by = 5)) +
    geom_smooth(se=T, method='gam', formula=y~s(x), color='indianred')
  return(meanlat)
}

PlotAllPoints = function (dat, map, species, year){
  #plots all observed locations for hummingbird sightings
  dat$month = as.factor(dat$month)
  sitemap = ggmap(map) + geom_point(data=dat, aes(LONGITUDE, LATITUDE, col=month)) +
            ggtitle(paste(species, year, sep = " "))
  print(sitemap)
  return(sitemap)
}

MigrationSpeed = function(dat, migration){
  # estimates daily migration speed for spring and fall, separately
  # takes the top 5 fastest migration speeds for each time period, and assigns the median as the migration speed
  # migration has two elements, beginning of spring migration and end of fall migration
  # breeding has two elements, end of spring migration and beginning of fall migration from breeding grounds

  springdat = dat[which(dat$jday >= migration[[1]] & dat$jday <= migration[[2]]),]
  falldat = dat[which(dat$jday >= migration[[2]] & dat$jday <= migration[[3]]),]

  springspeed = median(sort(springdat$dst, decreasing=TRUE)[1:5])
  fallspeed = median(sort(falldat$dst, decreasing=TRUE)[1:5])

  return(c(springspeed,fallspeed))
}

FindMismatch = function(dat, species, hexdat, yreffort, map) {
  #input is a yearly data frame for a species
  #output is a new dataframe with mean lat and long, calculated from hexagon centers, after placing daily observed
  #lat and long onto the isacohedron equal-area cells map, sensu La Sorte et al. 2013

  #count the number of days in the year
  year = dat$year[1]
  numdays = as.numeric(as.POSIXlt(paste(year, "-12-31", sep = "")) - as.POSIXlt(paste(year, "-01-01", sep="")) + 1)
  julian = seq(1:numdays)

  #To find the POLYFID for the hexes for each observation, identify observed lon and lat
  # Matches observations with the polygon hexes in the map
  ID <- over(SpatialPoints(dat[,c(10,9)]), hexdat)  #TODO: Check with TAC that this is working correctly based on map projection
  names(ID) = c("JOIN_COUNT", "AREA", "PERIMETER", "BOB_", "BOB_ID", "ID", "POLYFID", "HEX_LONGITUDE", "HEX_LATITUDE")
  coords <- cbind(dat, ID)

  #aggregate daily info by mean centroid location
  dailyHexes = count(coords, vars=c("julian", "POLYFID", "HEX_LONGITUDE", "HEX_LATITUDE"))

  #calculate weighted mean (weights based on number of obs per hex) lat and long
  missingdat = data.frame("julian"=1, "POLYFID"=1, "H"=1, "numcells"=1, "centerlon"=1, "centerlat"=1, "sdlon"=1, "sdlat"=1)
  outcount = 1

  for (j in 1:length(julian)){
    jdata = dailyHexes[which(dailyHexes$julian == j),]
    jeffort = yreffort[which(yreffort$DAY == j),]
    hexes = unique(jeffort$POLYFID)
    misses = jdata[which(!jdata$POLYFID %in% hexes),]
    if(j == 1){
      missing = misses
    }
    else {
      missing = rbind(missing, misses)
    }
    }
  missing = missing[complete.cases(missing),] #TODO: Are the missing points because of some mismatch in what is being counted towards effort?
  nadat = missing[!complete.cases(missing),] #TODO: Are the NA points coming from the coast? TAC found some coastal mismatch - worth trying to put into nearest neighbor cell?

  errmap = ggmap(map) + geom_point(data=missing, aes(HEX_LONGITUDE, HEX_LATITUDE)) +
    ggtitle(paste(species, year, sep = " "))

  print(errmap)
  return(list(missing, nadat))
}

LinearMigration = function(seasondat, year){
  # takes the data from a single season and runs a linear regression on the lat or lon
  # returns slope and r2 fit

  lm1 = lm(lat ~ jday, data = seasondat)
  lm2 = lm(lon ~ jday, data = seasondat)

  dat = data.frame("year" = year, "lat_slope" = lm1$coef[[2]], "lat_r2" = summary(lm1)$r.squared,
                   "lon_slope" = lm2$coef[[2]], "lon_r2" = summary(lm2)$r.squared)
  return(dat)
}

GroupDuplicates = function(humdat) {
  #gets rid of duplicate records that are part of the same group.
  #Takes only the first record to move to analysis, keeps all single records that are not part of a group.
  gid = sort(unique(humdat$GROUP_ID))
  #gid = gid[which(gid!=NA)]

  #open start a new dataframe with same columns as the main dataframe
  keep = humdat[1,]
  out = 0

  for (g in 1:length(gid)){
    out = out + 1
    tmp = humdat[which(humdat$GROUP_ID == gid[g]),]
    #record the first line of the data (assume the group has the same information)
    if (nrow(tmp) == 1) {
      keep[out,] = tmp
    }
    else{
      keep[out,] = tmp[1,]
    }
  }

  keepnongroup = humdat[which(is.na(humdat$GROUP_ID)),]
  keep = rbind(keep, keepnongroup)
  return(keep)
}

Est3MigrationDates = function(dat){
  #takes in predicted centroids for migration path, and estimates the beginning of spring migration,
  # the end of fall migration, and the date where the species reaches maximum latitude.

  #GAM model on predicted latitude of centroids by julian date
  gam1 = gam(centerlat ~ s(jday, k = 40), data = dat, gamma = 1.5)
  xpred = data.frame(jday = c(1:max(dat$jday)))
  dpred = predict(gam1, newdata=xpred, type="response", se.fit=TRUE)

  ## cutoff based on 2 SE for spring and fall combined, following La Sorte et al. 2013 methods
  # Spring migration should be between 11 Jan and 9 July
  # Fall migration should be between 8 August and 21 Dec
  spring_threshold = min(dpred$se.fit[c(1:120)]*2.56 + dpred$fit[c(1:120)])
  fall_threshold = min(dpred$se.fit[c(280:365)]*2.56 + dpred$fit[c(280:365)])
  spring_index = 11:190
  fall_index = 220:355
  spring_max = spring_index[which.max(dpred$fit[spring_index])]
  fall_max = fall_index[which.max(dpred$fit[fall_index])]

  #identify beginning of spring migration
  tst = 1000
  spring_index2 = spring_max
  while(tst > spring_threshold){
    tst = dpred$fit[spring_index2]
    if(spring_index2 == 1) break
    spring_index2 = spring_index2 - 1
  }
  spring_begin = spring_index2 + 1

  #identify end of fall migration
  tst <- 1000
  fall_index2 = fall_max
  while(tst > fall_threshold){
    tst = dpred$fit[fall_index2]
    if(fall_index2==365) break
    fall_index2 <- fall_index2 + 1
  }
  fall_end <- fall_index2 - 1

  max_lat =   xpred$jday[which.max(dpred$fit[xpred$jday])]

  dates = c(spring_begin, max_lat, fall_end)
  return(dates)
}

Est4MigrationDates = function(dat){
  #takes in predicted centroids for migration path, and estimates the beginnig and end of spring migration,
  # and the beginning and end of fall migration

  #GAM model on predicted latitude of centroids by julian date
  gam1 = gam(centerlat ~ s(jday, k = 40), data = dat, gamma = 1.5)
  xpred = data.frame(jday = c(1:max(dat$jday)))
  dpred = predict(gam1, newdata=xpred, type="response", se.fit=TRUE)

  ## cutoff based on 2 SE for spring and fall combined, following La Sorte et al. 2013 methods
  # Spring migration should be between 11 Jan and 9 July
  # Fall migration should be between 8 August and 21 Dec
  spring_threshold = min(dpred$se.fit[c(1:120)]*2.56 + dpred$fit[c(1:120)])
  fall_threshold = min(dpred$se.fit[c(280:365)]*2.56 + dpred$fit[c(280:365)])
  spring_index = 11:190
  fall_index = 220:355
  spring_max = spring_index[which.max(dpred$fit[spring_index])]
  fall_max = fall_index[which.max(dpred$fit[fall_index])]

  #identify beginning of spring migration
  tst = 1000
  spring_index2 = spring_max
  while(tst > spring_threshold){
    tst = dpred$fit[spring_index2]
    if(spring_index2 == 1) break
    spring_index2 = spring_index2 - 1
  }
  spring_begin = spring_index2 + 1

  #identify end of fall migration
  tst <- 1000
  fall_index2 = fall_max
  while(tst > fall_threshold){
    tst = dpred$fit[fall_index2]
    if(fall_index2==365) break
    fall_index2 <- fall_index2 + 1
  }
  fall_end <- fall_index2 - 1

  med = median(c(spring_begin, fall_end))
  # cutoff based on 2 SE for the breeding period, defined as +/- 30 days from the median date,
  # based on start of spring and end of fall migration in GetMigrationDates function
  lat_threshold = min(dpred$se.fit[c((med-30):(med+30))]*2.56 + dpred$fit[c((med-30):(med+30))])
  spring_index = (med-30):med
  fall_index = med:(med+30)
  spring_max = spring_index[which.max(dpred$fit[spring_index])]
  fall_max = fall_index[which.max(dpred$fit[fall_index])]

  #identify end of spring migration
  tst = 1000
  spring_index2 = spring_max
  while(tst > lat_threshold){
    tst = dpred$fit[spring_index2]
    if(spring_index2 == 1) break
    spring_index2 = spring_index2 - 1
  }
  spring_end = spring_index2 + 1

  #identify beginning of fall migration
  tst <- 1000
  fall_index2 = fall_max
  while(tst > lat_threshold){
    tst = dpred$fit[fall_index2]
    if(fall_index2==365) break
    fall_index2 <- fall_index2 + 1
  }
  fall_begin <- fall_index2 - 1

  dates = c(spring_begin, spring_end, fall_begin, fall_end)
  return(dates)
}

#Base plot migration route, trimmed by migration dates
BasePlotMigration = function(preds, yrdat, migration, elev, USAborder, Mexborder, Canborder, myext){

  predpts = preds[which(preds$jday > migration[1] & preds$jday < migration[3]),]

  predpts$month = as.factor(predpts$month)
  cols3 = data.frame(id=c(sort(unique(predpts$month))), cols=tim.colors(length(unique(predpts$month))), stringsAsFactors=FALSE)
  predpts = merge(predpts, cols3, by.x="month", by.y="id")
  #set color scale
  vls = sort(unique(round(cols3$id)))
  vls[1] = 1
  cols4 = tim.colors(length(vls))

  plot(predpts$lon, predpts$lat, xlim = c(-175, -50), ylim = c(15, 75),
       xlab = "longitude", ylab = "latitude", main = "summarized migration route", cex.lab = 1.5, cex.axis = 1.5)
  plot(USAborder, ext=myext, border="gray30", add=TRUE)
  plot(Mexborder, ext=myext, border="gray30", add=TRUE)
  plot(Canborder, ext=myext, border="gray30", add=TRUE)
  points(yrdat$LONGITUDE, yrdat$LATITUDE, pch=16, col = "grey60", cex = 0.5)
  points(predpts$lon, predpts$lat, pch=19, col = predpts$cols, cex = 0.5)
  #legend("bottomleft", legend=vls, pch=22, pt.bg=cols4, pt.cex=1.25, cex=1.25, bty="n",
  #       col="black", title="", x.intersp=0.5, y.intersp=0.25)
}

ElevPlotMigration = function(preds, yrdat, migration, elev, USAborder, Mexborder, Canborder, myext) {

  predpts = preds

  predpts$month = as.factor(predpts$month)
  cols3 = data.frame(id=c(sort(unique(predpts$month))), cols=tim.colors(length(unique(predpts$month))), stringsAsFactors=FALSE)
  predpts = merge(predpts, cols3, by.x="month", by.y="id")
  #set color scale
  vls = sort(unique(round(cols3$id)))
  vls[1] = 1
  cols4 = tim.colors(length(vls))

  fun <- function(){
    plot(USAborder, ext=myext, border="gray30", add=TRUE)
    plot(Mexborder, ext=myext, border="gray30", add=TRUE)
    plot(Canborder, ext=myext, border="gray30", add=TRUE)
    #points(yrdat$LONGITUDE, yrdat$LATITUDE, pch=16, col = "black", cex = 0.25)
    points(predpts$lon, predpts$lat, col=predpts$cols, pch=19, cex=0.5)
  }

  plot.new()

  plot(elev, ext=myext, addfun=fun, ylab="Latitude", xlab="Longitude", main="summarized migration route",
       cex.lab = 1.5, cex.axis=1.5, col=gray(10:256/256))
  #legend("bottomleft", legend=vls, pch=22, pt.bg=cols4, pt.cex=1.25, cex=1.25, bty="n",
   #      col="black", title="", x.intersp=0.5, y.intersp=0.25)
}

AllMigration = function(preds, elev, myext, species) {

  predpts = preds

  predpts$month = as.factor(predpts$month)
  cols3 = data.frame(id=c(sort(unique(predpts$month))), cols=tim.colors(length(unique(predpts$month))), stringsAsFactors=FALSE)
  predpts = merge(predpts, cols3, by.x="month", by.y="id")
  #set color scale
  vls = sort(unique(round(cols3$id)))
  vls[1] = 1
  cols4 = tim.colors(length(vls))

  plot(elev, ext=myext, ylab="Latitude", xlab="Longitude", main=species,
       cex.lab = 1, cex.axis=1, col=gray(10:256/256))
  points(predpts$lon, predpts$lat, col=predpts$cols, pch=19, cex=0.25)
  legend("bottomleft", legend=vls, pch=22, pt.bg=cols4, pt.cex=0.75, cex=0.75, bty="n",
        col="black", title="", x.intersp=0.5, y.intersp=0.75)
}

# plot a color bar for legend
# http://aurelienmadouasse.wordpress.com/2012/01/13/legend-for-a-continuous-color-scale-in-r/
legend.col <- function(col, lev){
  opar <- par
  n <- length(col)
  bx <- par("usr")
  box.cx <- c(bx[2] + (bx[2] - bx[1]) / 1000,
              bx[2] + (bx[2] - bx[1]) / 1000 + (bx[2] - bx[1]) / 50)
  box.cy <- c(bx[3], bx[3])
  box.sy <- (bx[4] - bx[3]) / n
  xx <- rep(box.cx, each = 2)
  par(xpd = TRUE)
  for(i in 1:n){
    yy <- c(box.cy[1] + (box.sy * (i - 1)),
            box.cy[1] + (box.sy * (i)),
            box.cy[1] + (box.sy * (i)),
            box.cy[1] + (box.sy * (i - 1)))
    polygon(xx, yy, col = col[i], border = col[i])
  }
  par(new = TRUE)
  plot(0, 0, type = "n",
       ylim = c(min(lev), max(lev)),
       yaxt = "n", ylab = "",
       xaxt = "n", xlab = "",
       frame.plot = FALSE)
  axis(side = 4, las = 2, tick = FALSE, line = 0.25)
  par <- opar
}


# Importing and Downloading Data
# Where to find publicly available big data
# UCSC -- RefSeq genes from table browser
# Ensembl -- Mouse regulatory features MultiCell
# ENCODE -- HMM: wgEncodeBroadHmmGm12878HMM.bed

# save file route to a variable "filename"

filename <- "lesson_2/micro_array_results_table1.txt"

my_data <- read.csv(filename, sep="\t", header=TRUE)
head(my_data)

# Importing RefSeq_Genes

genes <- read.csv("lesson_2/RefSeq_Genes", sep="\t", header=TRUE)

head(genes)

#dim() tells you the rows and columns a given data frame has.
dim(genes)

regulatory_genes <- read.csv("lesson_2/mus_musculus.GRCm38.Regulatory_Build.regulatory_features.20180516.gff", sep="\t", header=FALSE)
head(regulatory_genes)
dim(regulatory_genes)

chromHMM <- read.csv("lesson_2/wgEncodeBroadHmmGm12878HMM.bed", sep="\t", header=FALSE)
head(chromHMM)
dim(chromHMM)


library(httr)
library(jsonlite)
library(tidyverse)
library(reshape2)
library(plotly)
library(scales)

day_counts = (365 * 1)
periods_size = 365 / 52
repeats = day_counts %/% periods_size
starts = round(day_counts - (periods_size * 0:repeats))
ends = lag(starts, 1)
start_ends = data.frame(starts, ends) %>% na.omit()

api_url = 'https://api.pushshift.io/reddit/search/comment/'

queries = c(
  'coronavirus', 'virus', 'covid', 'hubei',
  'thank you', 'think', 'thanks', 'cat', 'dog',
  'Biden', 'Bernie', 'Trump',
  'funny', 'kitten', 'puppy', 'happy', 'sad', 'please')

all_queries_stacked = map(1:nrow(start_ends), function(it){
  print(it/nrow(start_ends))

  row = start_ends[it,]

  queries_stacked = map(queries, function(query){
    tryCatch({
      query_results = GET(api_url, query = list(before = paste0(row$starts, 'd'),
                                                after = paste0(row$ends, 'd'),
                                                q = query, aggs = 'subreddit', size = 0)) %>%
        as.character() %>% fromJSON()

      Sys.sleep(0.5)
      mutate(query_results$aggs$subreddit, query = query) %>% return()
    }, error = function(e){
      cat('error with', query, '\n')
      print(query_results)
      print(e)
      return(NULL)
    })

  }) %>%
    bind_rows() %>%
    mutate(
      start = row$starts,
      end = row$ends,
      period = paste(end, start, sep = '-', 'days ago')
    )

  return(queries_stacked)
}) %>% bind_rows()

all_queries_clean = mutate(all_queries_stacked,
                           start_date = Sys.Date() - end, end_date = Sys.Date() - start,
                           query = str_to_title(query)
)

saveRDS(all_queries_clean, 'all_general_queries_clean.rds')

query_summary = group_by(all_queries_clean, end_date, query) %>%
  summarize(
    Total = sum(doc_count)
  )

a = ggplot(query_summary, aes(end_date, Total, colour = query)) +
  geom_line()

ggplotly(a)


#make a csv to identify cells by municipality

rm(list=ls())

#required packages
library(tidyverse)

scenario <- "Testing_2018-08-16"
runID <- "0-0"
yrs <- seq(2000, 2015, 1)

#output variables
SC_name <- paste0("Data/",scenario,"/",runID,"/",scenario,"_CRAFTYmunisServCap.csv")  #output file name for services and capitals
LC_name <- paste0("Data/",scenario,"/",runID,"/",scenario,"_CRAFTYmunisLC.csv")  #output file name for land cover data

#load the region file (used to match each cell to a municipality)
region <- read.csv(paste0("Data/",scenario,"/",runID,"/region.csv"))

i <- 1

#Load model output data
output <- read.csv(paste0("Data/",scenario,"/",runID,"/",scenario,"-",runID,"-Cell-",yrs[i],".csv"))

#load empirical map summary data (created using summarise_LCmaps.r)
lc <- read.csv(paste0("Data/SummaryTables/LCs",yrs[i],"_PastureB.csv"), header = T)

#create df containing only cell and muni data (rename columns)
munis<-data.frame(region$X, region$Y, region$muniID)
munis <- rename_all(munis, .funs = funs(substring(., 8)))  #string "region." prefix using substring function to retain only chars after 8 position (1 index)
#munis <- rename_all(munis, .funs = funs(sub("^region.", "",.)))  #or same as previos line using sub with regex

#join to add muniID to the CRAFTY output data
output <- inner_join(output, munis, by = c("X", "Y"))

write_csv(output, "Data/muniCells.csv")


# Gregory Way 2016
# NF1 Classifier GBM/LGG
# scripts/viz/viz_cv.r
#
# Visualizes cross validation results
#
# Usage:
# Run with nf1_classifier.py
#
# Output:
# Training and testing error plots for hyperparameter selection

# Load library
library(ggplot2)
library(dplyr)

# Load Command Args
args <- commandArgs(trailingOnly = T)
print(args)
data_fh <- args[1]
output_fh <- args[2]
ml <- args[3]

# Load Data
data_cv <- readr::read_tsv(data_fh)

# Multiplot name
multiplot_fh <- paste0(unlist(strsplit(output_fh, '[.]'))[1], '_multiplot.png')

# Construct classifier specific plots
if (ml == 'SVM') {
  x_label <- 'Hyperparameter: C'
  param_sweep <- ggplot(data_cv, aes(x = param, y = error, colour = class, fill = class))
  h <- 400
  w <- 600
  title <- ''
} else {
  x_label <- 'Hyperparamter: l1 Ratio'
  w <- 700
  h <- 500
  title <- 'Hyperparameter: Alpha'
  param_sweep <- ggplot(data_cv, aes(x = l1_ratio, y = error, colour = class, fill = class)) +
    facet_wrap(~ alpha)
}

##############################
# Plot Parameter Sweep
##############################
param_sweep <- param_sweep + stat_smooth(method = 'loess', se = TRUE) +
  labs(x = x_label, y = 'AUROC') +
  ggtitle(title) +
  theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.background = element_blank(),
        title = element_text(size = rel(2)),
        axis.line.x = element_line(size = rel(1), linetype = "solid", color = "black"),
        axis.line.y = element_line(size = rel(1), linetype = "solid", color = "black"),
        axis.text = element_text(size = rel(1), color = "black"),
        axis.ticks = element_line(size = rel(1), color = "black"),
        axis.ticks.length = unit(0.2, "cm"),
        axis.title = element_text(size = rel(1.2)),
        axis.title.y = element_text(vjust = 4.5),
        axis.title.x = element_text(vjust = -4.5),
        legend.key.size = unit(1, "cm"),
        legend.text = element_text(size = rel(1.2)),
        legend.title = element_text(size = rel(1.2)))

# Save
png(output_fh, height = h, width = w)
param_sweep
dev.off()

##############################
# Data subset (Plot Parameter Selection)
##############################
# What is best parameters for test set?
if (ml == 'SVM') {
  param <- data_cv[data_cv$class == 'test', ] %>% group_by(alpha) %>% summarise(avg = mean(error))
} else if (ml == 'elasticnet') {
  param <- data_cv[data_cv$class == 'test', ] %>% group_by(alpha, l1_ratio) %>% summarise(avg = mean(error))
}

# What are the best parameters with the lowest test set accuracy?
best_parameters <- param[param$avg == max(param$avg), ]

# Plot Best Alpha Range
best_alpha <- best_parameters$alpha
data_sub <- data_cv[data_cv$alpha == best_alpha, ]

best_alpha_plot <- ggplot(data_sub, aes(class, error)) +
  stat_boxplot(aes(fill = class)) +
  xlab('') + ylab('AUROC') + facet_grid(. ~ l1_ratio) +
  theme(title = element_text(size = 20),
        axis.text.x = element_blank(),
        axis.text.y = element_text(size = 20),
        legend.key = element_rect(fill = 'white'),
        legend.key.size = unit(1, "cm"),
        legend.text = element_text(size = rel(1.2)),
        panel.grid.major = element_line(color = 'grey', size = 0.3),
        panel.grid.minor = element_line(color = 'grey', size = 0.3),
        panel.background = element_rect(fill = 'white'),
        axis.line = element_line(color = 'black', size = 0.5),
        axis.ticks = element_blank(),
        title = element_text(size = 25)) +
       # plot.margin = unit(c(1.2, 2, 0, 1.5), 'cm')) +
  ggtitle(paste0('l1 Ratio', '\nalpha = ', best_alpha))

# Save
output_fh <- paste0(unlist(strsplit(output_fh, '[.]'))[1], '_alpha_', best_alpha, '.png')
png(output_fh, height = h, width = w)
best_alpha_plot
dev.off()

##############################
# Plot best overall parameters
##############################
# Subset to best l1_ratio if elasticnet
best_l1 <- best_parameters$l1_ratio

l1_sub <- data_sub[data_sub$l1_ratio == best_l1, ]

best_l1_plot <- ggplot(l1_sub, aes(class, error)) +
  stat_boxplot(aes(fill = class)) +
  xlab('') + ylab('AUROC') +
  theme(title = element_text(size = 20),
        axis.text.x = element_blank(),
        axis.text.y = element_text(size = 20),
        legend.key = element_rect(fill = 'white'),
        legend.key.size = unit(1, "cm"),
        legend.text = element_text(size = rel(1.2)),
        panel.grid.major = element_line(color = 'grey', size = 0.3),
        panel.grid.minor = element_line(color = 'grey', size = 0.3),
        panel.background = element_rect(fill = 'white'),
        axis.line = element_line(color = 'black', size = 0.5),
        axis.ticks = element_blank(),
        title = element_text(size = 25)) +
       # plot.margin = unit(c(1.2, 2, 0, 1.5), 'cm')) +
  ggtitle(paste0('l1 ratio = ', best_l1, '\nalpha = ', best_alpha))

# Save
output_fh <- paste0(unlist(strsplit(output_fh, '[.]'))[1], best_alpha,
                    '_l1ratio_', best_l1, '.png')
png(output_fh, height = 270, width = 300)
best_l1_plot
dev.off()

##############################
# Save Multiplot
##############################
all_plots <- list(param_sweep + theme(legend.position = "none"), best_alpha_plot, best_l1_plot)
layout <- matrix(c(rep(1, 20), rep(c(2, 2, 2, 3, 3), 4)), nrow = 5, ncol = 8)

png(multiplot_fh, height = 500, width = 950)
Rmisc::multiplot(plotlist = all_plots, layout = layout)
dev.off()


# The MIT License (MIT)
# Copyright (c) 2017 Louise AC Millard, MRC Integrative Epidemiology Unit, University of Bristol
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated
# documentation files (the "Software"), to deal in the Software without restriction, including without
# limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
# the Software, and to permit persons to whom the Software is furnished to do so, subject to the following
# conditions:
#
# The above copyright notice and this permission notice shall be included in all copies or substantial portions
# of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED
# TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
# CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.

# Processing integer fields, namely:
# 1) Reassigning values as specified in the data code information file
# 2) Generate a single value if there are several values (arrays) by taking the mean
# 3) Treating this field as continuous if at least 20 distinct values.
# Otherwise treat as binary or ordered categorical if 2 or more than two values.
testInteger <- function(varName, varType, thisdata) {
	cat("INTEGER || ");

	pheno = thisdata[,phenoStartIdx:ncol(thisdata)]
	isExposure = getIsExposure(varName)

	if (!is.numeric(as.matrix(pheno))) {
		cat("SKIP Integer type but not numeric",sep="");
		return(NULL)
	}

	pheno = reassignValue(pheno, varName)

	## average if multiple columns
	if (!is.null(dim(pheno))) {
                phenoAvg = rowMeans(pheno, na.rm=TRUE)

		# if participant only has NA values then NaN is generated so we convert back to NA
		phenoAvg = replaceNaN(phenoAvg)
        }
	else {
                phenoAvg = pheno
        }

	uniqVar = unique(na.omit(phenoAvg))

	# if >=20 separate values then treat as continuous
	if (length(uniqVar)>=20) {

		thisdatanew = cbind.data.frame(thisdata[,1:numPreceedingCols], phenoAvg);
		testContinuous2(varName, varType, thisdatanew)
		incrementCounter("int.continuous")
	}
	else {

		## remove categories if < 10 examples
	    	phenoAvg = testNumExamples(phenoAvg)

		## binary if 2 distinct values, else ordered categorical
		phenoFactor = factor(phenoAvg)
		numLevels = length(levels(phenoFactor))
		if (numLevels<=1) {
			cat("SKIP (number of levels: ",numLevels,")",sep="");
			incrementCounter("int.onevalue")
		}
		else if (numLevels==2) {
			incrementCounter("int.binary")

			# binary
			thisdatanew = cbind.data.frame(thisdata[,1:numPreceedingCols], phenoFactor);
			binaryLogisticRegression(varName, varType, thisdatanew, isExposure);
		}
		else {
			incrementCounter("int.catord")
			cat("3-20 values || ")

			# we don't use equal sized bins just the original integers (that have >=10 examples) as categories
			thisdatanew = cbind.data.frame(thisdata[,1:numPreceedingCols], phenoFactor);

			# treat as ordinal categorical
			testCategoricalOrdered(varName, varType, thisdatanew);
		}
	}
}


## 07022020 CKR
#Rab identification and validation
library(vegan)
library(tidyverse)
library(reshape2)
library(ggplot2)
library(stringr)
library(BisRNA)
#Stage 1
enriched<-function(country,suppl,side){
Label=read.table("../Data/TariniLabels_edit.txt", sep='\t', head = T) #read in labels
LabelCA=filter(Label,Country==country) #filter for country
CA_R=filter(LabelCA,Status=="R")%>%select(ID) #filter for recoverers
CA_NR=filter(LabelCA,Status=="NR")%>%select(ID) #filter for non-recoverers
CA_abun=read.table(suppl,sep='\t', head=T, row.names=1,check.names = F) #read in abundance
CA_abun=as.matrix(t(CA_abun)) #transpose
if(country=="SW"){
  rownames(CA_abun)=str_replace_all(rownames(CA_abun)," ","_")
} #change species name to right format
if(country=="CA"){
  rownames(CA_abun)=str_replace_all(rownames(CA_abun),"s__","")
} #change species name to right format
CA_abun=cbind(CA_abun[,as.matrix(CA_R)],CA_abun[,as.matrix(CA_NR)]) #abundance profile for recoverers and non-recoverers only
CA_abun=CA_abun[rowSums(CA_abun)>0, ] #remove species not present in recoverers and non-recoverers
a=CA_abun[,as.matrix(CA_R)]
b=CA_abun[,as.matrix(CA_NR)]
p=NULL
for(i in 1:nrow(a)){
  p=rbind(p,c(rownames(a)[i],wilcox.test(as.matrix(a[i,]),as.matrix(b[i,]),alternative=side)$p.value))
} #Wilcoxon test
colnames(p)=c("Species","pval")
return(p)
}

#get all one sided p-values
pCan=enriched("CA","../Data/Suppl1_CA_Final.txt","greater")
pSin=enriched("SG","../Data/Suppl1_SG.txt","greater")
pEN=enriched("EN","../Data/Suppl1_EN.txt","greater")
pSW=enriched("SW","../Data/Suppl1_SW.txt","greater")

pCanL=enriched("CA","../Data/Suppl1_CA_Final.txt","less")
pSinL=enriched("SG","../Data/Suppl1_SG.txt","less")
pENL=enriched("EN","../Data/Suppl1_EN.txt","less")
pSWL=enriched("SW","../Data/Suppl1_SW.txt","less")

#merge all pvalues and combine
mergeP<-function(pCan,pSin,pEN,pSW){
pAll=merge(pCan,pSin,by="Species")
colnames(pAll)=c("Species","pCA","pSG")
pAll=merge(pAll,pEN,by="Species")
colnames(pAll)=c("Species","pCA","pSG","pEN")
pAll=merge(pAll,pSW,by="Species")
colnames(pAll)=c("Species","pCA","pSG","pEN","pSW")
pAll$pCA=as.numeric(as.character(pAll$pCA))
pAll$pSG=as.numeric(as.character(pAll$pSG))
pAll$pEN=as.numeric(as.character(pAll$pEN))
pAll$pSW=as.numeric(as.character(pAll$pSW))
return(pAll)
}

pAll=mergeP(pCan,pSin,pEN,pSW) #p-value for greater
pAll_lower=mergeP(pCanL,pSinL,pENL,pSWL) #p-value for lower

#filter for BH corrected fisher combined pval<0.01
pFish=mutate(pAll,pfish=p.adjust(apply(select(pAll,-"Species"),1,fisher.method),method="BH"))%>%
  filter(pfish<0.01)
pFish_lower=mutate(pAll_lower,pfish=p.adjust(apply(select(pAll_lower,-"Species"),1,fisher.method),method="BH"))%>%
  filter(pfish<0.01) #none of the species satisfy the criteria of being significantly lower in non-recoverers
selected=as.matrix(pFish$Species)

#Stage 2
cohortfdr<-function(country,suppl,selected){
Label=read.table("../Data/TariniLabels_edit.txt", sep='\t', head = T) #read in labels
LabelCA=filter(Label,Country==country) #filter for country
CA_R=filter(LabelCA,Status=="R")%>%select(ID) #filter for recoverers
CA_NR=filter(LabelCA,Status=="NR")%>%select(ID) #filter for non-recoverers
CA_abun=read.table(suppl,sep='\t', head=T, row.names=1,check.names=F) #read in abundance
CA_abun=t(CA_abun) #transpose
if(country=="SW"){
  rownames(CA_abun)=str_replace_all(rownames(CA_abun)," ","_")
}#change species name to right format
if(country=="CA"){
  rownames(CA_abun)=str_replace_all(rownames(CA_abun),"s__","")
}#change species name to right format
CA_abun=CA_abun[selected,] #filter for species that passed stage 1
CA_abun=cbind(CA_abun[,as.matrix(CA_R)],CA_abun[,as.matrix(CA_NR)])#abundance profile for recoverers and non-recoverers only
CA_abun=CA_abun[rowSums(CA_abun)>0, ] #remove species not present in the target group
a=CA_abun[,as.matrix(CA_R)]
b=CA_abun[,as.matrix(CA_NR)]
p=NULL
for(i in 1:nrow(a)){
  p=rbind(p,c(rownames(a)[i],wilcox.test(as.matrix(a[i,]),as.matrix(b[i,]),alternative="greater")$p.value))
}#Wilcoxon test

padj=p.adjust(p[,2],method="BH",n=nrow(p))#BH correction
p=cbind(p[,1],padj)
colnames(p)=c("Species","padj")
return(p)
}

CohpCan=cohortfdr("CA","../Data/Suppl1_CA_Final.txt",selected)
CohpSG=cohortfdr("SG","../Data/Suppl1_SG.txt",selected)
CohpEN=cohortfdr("EN","../Data/Suppl1_EN.txt",selected)
CohpSW=cohortfdr("SW","../Data/Suppl1_SW.txt",selected)

#merge all p-values from different cohort
CohpAll=merge(CohpCan,CohpSG,by="Species")
colnames(CohpAll)=c("Species","pCA","pSG")
CohpAll=merge(CohpAll,CohpEN,by="Species")
colnames(CohpAll)=c("Species","pCA","pSG","pEN")
CohpAll=merge(CohpAll,CohpSW,by="Species")
colnames(CohpAll)=c("Species","pCA","pSG","pEN","pSW")
CohpAll$pCA=as.numeric(as.character(CohpAll$pCA))
CohpAll$pSG=as.numeric(as.character(CohpAll$pSG))
CohpAll$pEN=as.numeric(as.character(CohpAll$pEN))
CohpAll$pSW=as.numeric(as.character(CohpAll$pSW))

#filter for species with at least 2 cohorts fdr p-value < 0.05
filtered=CohpAll[rowSums(select(CohpAll,-"Species")<0.05)>=2,]

#include NUH cohort
Data=read.table("../Data/NUH_StoolSamples_MetaPhlAn2.txt", sep='\t', head = T, row.names=1) #read abundances
Data=filter(Data,Group=="Case") %>%
  select(PatientID,TimePoint,contains("s__"),-contains("t__")) #select for cases who took antibiotics and species profile
colnames(Data)=gsub(".*s__","s__",colnames(Data)) #changing species name to right format

##identify recoverers and non-recoverers
DataAnn=filter(Data,TimePoint=="POST")%>%
  select(-TimePoint)
DataAnn=data.frame(DataAnn,row.names=1) #set patient ID to rownames
Diversity=data.frame(Simpson=diversity((DataAnn),index='simpson'),ID=rownames(DataAnn))
Diversity=data.frame(Diversity,row.names=2)
Threshold = Diversity %>%
  summarise(IQR=IQR(Simpson),Median=median(Simpson)) %>%
  summarise(Upper=(0.1*IQR)+Median,Lower=Median-(0.1*IQR))#Define threshold
Diversity=mutate(Diversity,Lib=rownames(Diversity))
Recoverer=filter(Diversity,Simpson>as.numeric(Threshold["Upper"]))%>%
  select(-Simpson) #Define recoverer
NonRec=filter(Diversity,Simpson<as.numeric(Threshold["Lower"])) %>%
  select(-Simpson) #Define non-recoverer

#filter for abundance for R and NR
Metarec=filter(Data,PatientID%in%as.matrix(Recoverer))%>%
  select(-TimePoint,-PatientID)
MetaNon=filter(Data,PatientID%in%as.matrix(NonRec))%>%
  select(-TimePoint,-PatientID)
RecData=t(Metarec) #transpose
NonData=t(MetaNon) #transpose
p=NULL
for(i in 1:nrow(RecData)){
  p=rbind(p,c(rownames(RecData)[i],wilcox.test(as.matrix(RecData[i,]),as.matrix(NonData[i,]),alternative="greater")$p.value))
} #wilcoxon test
p[,1]=str_replace(p[,1],"s__","")#change Species name to right format
colnames(p)=c("Species","pvalue")
p=filter(data.frame(p),Species%in%selected)

#if NUH cohort included in stage 2
c_fdr=mutate(p,padj=p.adjust(as.numeric(as.character(p$pvalue)),method="BH"))%>%
  filter(padj<0.05)
c_fdr[,1]%in%filtered[,1] #add 2 more rab

#independent validation by NUH cohort on rabs
p=filter(p,as.numeric(as.character(p$pvalue))<0.1) #no corrrection
p[,1]%in%filtered[,1] #12 out of 21 validated


# the plotting funcs script comes with treemix
source("plotting_funcs.R")

# get proportion variance explained by base tree and trees with migration edges
x <- get_f("certhia_contact_10000.treemix")
x <- c(x, get_f("certhia_contact_10000_m1.treemix"))
x <- c(x, get_f("certhia_contact_10000_m2.treemix"))
x <- c(x, get_f("certhia_contact_10000_m3.treemix"))
plot(x)

plot_tree("certhia_contact_10000.treemix")
plot_tree("certhia_contact_10000_m1.treemix")

plot_tree("certhia_contact_10000_m2.treemix")


library(catR)

getSafeItem = function(item, extraFields) {
  item = as.list(item)
  item$correct = NULL

  if(is.character(item$responseOptions)) { item$responseOptions = fromJSON(item$responseOptions) }
  responseOptionsRandomOrder = item$responseOptions$optionsRandomOrder == "1"
  orderedOptions = c()

  if(length(item$responseOptions$options) > 0) {
    if(responseOptionsRandomOrder) {
      orderedOptions = item$responseOptions$options[sample(1:length(item$responseOptions$options))]
    } else {
      orderedOptions = item$responseOptions$options
    }
  }
  item$responseOptions$options = orderedOptions
  item$responseOptions = toJSON(item$responseOptions)

  extraFields = fromJSON(extraFields)
  for(extraField in extraFields) {
    if(extraField$sensitive == 1) {
      item[[extraField$name]] = NULL
    }
  }

  return(item)
}

currentIndex = length(itemsAdministered) + 1
itemsNum = dim(items)[1]
nextItemIndex = 0
itemsExcluded = itemsAdministered
if(itemsNum > 0) {
  for(i in 1:itemsNum) {
    fixedIndex = items[i,"fixedIndex"]
    if(!is.na(fixedIndex) && !is.null(fixedIndex) && fixedIndex != "" && fixedIndex != 0){
      concerto.log(fixedIndex, "fixedIndex")
      if(fixedIndex == currentIndex) {
        nextItemIndex = i
      } else {
        itemsExcluded = unique(c(itemsExcluded, i))
      }
    }
  }
}

cbGroup = NULL
cbControl = NULL
cbProps = fromJSON(settings$contentBalancing)
concerto.log(cbProps, "cbProps")
if(length(cbProps) > 0) {
  cbGroup = as.character(items[,"cbGroup"])
  cbControl = list(
    names=NULL,
    props=NULL
  )

  for(i in 1:length(cbProps)) {
    cbControl$names = c(cbControl$names, cbProps[[i]]$name)
    cbControl$props = c(cbControl$props, as.numeric(cbProps[[i]]$proportion))
  }
  concerto.log(cbControl, "cbControl")
}

if(nextItemIndex == 0) {
  result = nextItem(paramBank, model=settings$model, theta=theta, out=itemsExcluded, criterion=settings$nextItemCriterion, method=settings$scoringMethod, randomesque=settings$nextItemRandomesque, cbGroup=cbGroup, cbControl=cbControl)
  nextItemIndex = result$item
}

if(!is.na(settings$nextItemModule) && settings$nextItemModule != "") {
  nextItemIndex = concerto.test.run(settings$nextItemModule, params=list(
    nextItemIndex=nextItemIndex,
    settings = settings,
    theta = theta,
    itemsAdministered=itemsAdministered,
    itemsExcluded=itemsExcluded,
    cbGroup=cbGroup,
    cbControl=cbControl,
    session=session,
    items=items
  ))$nextItemIndex
}

concerto.log(nextItemIndex, "nextItemIndex")
nextItem = items[nextItemIndex,]
concerto.log(nextItem, "nextItem")
nextItemSafe = getSafeItem(nextItem, settings$itemBankTableExtraFields)


args<-commandArgs(trailingOnly=TRUE)
if(length(args) < 2){
  stop("R --slave < this_code.r --args <loom> <use_core> <min_expressed_cell> <min_expressed_cell_average_expression>")
}
source("/home/yuanhao/single_cell/scripts/evaluation_pipeline/evaluation/utilities.r")
library(doParallel)
library(SAVER)
starttime = Sys.time()
loom_path = args[1]
use_core = as.integer(args[2])
print(use_core)
dir_path = paste(delete_last_element(unlist(strsplit(loom_path, "/", fixed = T))), collapse = "/")
output_dir = paste0(dir_path, "/imputation")
method_dir = paste0(dir_path, "/imputation/SAVER_tmp")
dir.create(output_dir, recursive = T, showWarnings = F)
dir.create(method_dir, showWarnings = F)
print(loom_path)
if(length(args) >= 3){
  min_expressed_cell = as.integer(args[3])
}else{
  min_expressed_cell = 10
}
if(length(args) >= 4){
  min_expressed_cell_average_expression = as.numeric(args[4])
}else{
  min_expressed_cell_average_expression = 1
}
output_h5 = paste(output_dir, sub(".loom", paste0("_SAVER_mc_", min_expressed_cell, "_mce_", min_expressed_cell_average_expression, ".hdf5"), get_last_element(unlist(strsplit(loom_path, "/", fixed = T))), fixed = TRUE), sep = "/")
print(output_h5)
if(file.exists(output_h5)){
  print("pass")
  next()
}
gene_bc_mat = readh5_loom(loom_path)
gene_name = rownames(gene_bc_mat)
cell_id = colnames(gene_bc_mat)
expressed_cell = rowSums(gene_bc_mat > 0)
gene_expression = rowSums(gene_bc_mat)
gene_filter = expressed_cell >= min_expressed_cell & gene_expression > expressed_cell * min_expressed_cell_average_expression
filt_data = gene_bc_mat[gene_filter, ]
print(dim(filt_data))
print(filt_data[1:5, 1:5])
gene_name_filt = gene_name[gene_filter]
cl <- makeCluster(use_core, outfile = "")
registerDoParallel(cl)
saver_result <- saver(filt_data)
stopCluster(cl)
output_rds_name = sub(".loom", paste0("_SAVER_mc_", min_expressed_cell, "_mce_", min_expressed_cell_average_expression, ".rds"), get_last_element(unlist(strsplit(loom_path, "/", fixed = T))), fixed = TRUE)
saveRDS(saver_result, paste(method_dir, output_rds_name, sep = "/"))
gamma_res = gamma_result(saver_result, 1)
h5createFile(output_h5)
h5createDataset(file = output_h5,
                dataset = "imputation",
                dims = c(length(gene_name_filt), length(cell_id)),
                storage.mode = "double",
                chunk=c(length(gene_name_filt), 1))
h5write(cell_id, output_h5,"cell_id")
h5write(gene_name_filt, output_h5,"gene_name")
h5write(gamma_res, file=output_h5, name="imputation")
print(Sys.time() - starttime)

reproducibility/source/Running Scripts for Other Methods/SAVER.r


#Jenny Smith

#Feb. 20, 2018

#Puprpose: to create a correlation plot with samples, and provide a color bar for cytogenetics

get.CPM.Df <- function(twoGroups_DEGs.res, trend=TRUE){

  if(trend){
    CPM.DEGs <- twoGroups_DEGs.res$DE$dge %>%
      data.frame() %>%
      rownames_to_column("gene") %>%
      filter(gene %in% rownames(twoGroups_DEGs.res$DE$DE)) %>%
      column_to_rownames("gene")
  }else{
    CPM.DEGs <- twoGroups_DEGs.res$DE$Voom$E %>%
      data.frame() %>%
      rownames_to_column("gene") %>%
      filter(gene %in% rownames(twoGroups_DEGs.res$DE$DE)) %>%
      column_to_rownames("gene")
  }

  return(CPM.DEGs)
}

corPlot_withColorBar <- function(expnData,CDE,col2=NULL, meanctr=TRUE,log2=TRUE,
                                 lab.size=0,diag.point.size=15, offset=15){
  #expnData is normalized expresion data, log2 scale, with genes as rownames
  #CDE is the clinical data with a column called,"Status" and "Num.Status" for the factor levels of each cyto group as factor/and numeric,
  #and CDE has a column called "USI"for merging.
  #col2 is an optional column
  #data will be mean centered (geometric mean on log2 scale) in order to visualize the sample correlations best.

  #lab.size is a single numeric.  if > 0 will indicate to keep patient labels on the x and y axis.
  #diag.point.size is the size of the point for the patient CDE groups.
  #offset a single  numeric on the x axis to move the points for the diaganol.

  library(dplyr)
  library(RColorBrewer)
  library(cowplot)
  library(ggplot2)
  library(dplyr)
  library(reshape2)

  #Function to reorder the cor matrix using correlation as distance and ward.D2 clustering.
  reorder_cormat <- function(cormat,vector=FALSE){
    dd <- as.dist((1-cormat)/2)
    hc <- hclust(dd, method="ward.D2")
    cormat <-cormat[hc$order, hc$order]
    if (vector){
      order <- rownames(cormat)
      return(order)
    }else{
      return(cormat)
    }}

  if(!log2){
    expnData <- log2(expnData+1)
  }

  #this is geometric mean centering because the antilog of the arithmatic mean of logged values == geomtric mean of non-logged values
  #mean center the data/scale to make z-scores.
  expnData.ctr <- scale(t(expnData), center = TRUE, scale = FALSE)
  expnData.ctr <- t(expnData.ctr)
  cormat.ctr <- cor(expnData.ctr)

  #find the order of the correlation matrix using hclust with ward.D2 algorithm.
  cormat.order <- reorder_cormat(cormat.ctr, vector=TRUE)
  cormat.final <- reorder_cormat(cormat.ctr)
  cormat.final[upper.tri(cormat.final)] <- NA

  #Melt the correlation matrix and add the clinical data
  cormat.melt <- cormat.final %>%
    melt(.,na.rm=TRUE, as.is=TRUE, varnames=c("Var1","Var2")) %>%
    # melt(cormat.final, na.rm = TRUE)  #original code. The behavior of melt() changed? Now defauls to X1 and X2.
    inner_join(., CDE, by=c("Var1"="USI")) %>%
    mutate_at(c("Var1", "Var2"),funs(factor(., levels=cormat.order))) %>% #ensure factor levels are correct before plotting
    mutate(Num.USI=as.numeric(Var1),
           Num.pair=as.numeric(Var2)) %>% #convert to numeric ordering
    select(Var1,Var2,Status,Num.USI,Num.pair,Num.Status, everything())

  #Create a subset of the cormat.melt to contain just the diaganol.
  diag <- subset(cormat.melt, Num.USI==Num.pair)
  n.samp <- nrow(diag)

  #Use geom_raster to create a correlation heatmap.
  ggheatmap <- ggplot(cormat.melt, aes(x=Num.USI, y=Num.pair, fill = value))+
    geom_raster() +
    scale_fill_gradient2(low = "blue", high = "red", mid = "white", midpoint = 0,
                         limit = c(-1,1), space = "Lab",   name="Pearson\nCorrelation") +
    theme_minimal() + # minimal theme
    theme(axis.text.x = element_text(angle = 45, vjust = 1, size = lab.size, hjust = 1),
          axis.text.y = element_text(angle = 45, vjust = 1, size = lab.size, hjust = 1),
          panel.border = element_blank(),
          panel.background = element_blank(),
          panel.grid = element_blank(),
          axis.ticks = element_blank()) +
    coord_fixed(ratio = 1, xlim = c(1,n.samp), ylim=c(1,n.samp))

  if(n.samp < 50){
    heatmap2 <-  ggheatmap +
      geom_point(data = diag,
                 mapping = aes(x=Num.USI-offset, y=Num.pair, color=Num.Status), size=diag.point.size, shape=15, show.legend = FALSE)
  }else{
    heatmap2 <-  ggheatmap +
      geom_jitter(data = diag,
                  mapping = aes(x=Num.USI-offset, y=Num.pair, color=Num.Status), size=diag.point.size, shape=95, show.legend = FALSE) #shape 124 is a line or pipe shape, 95 is a dash
  }

  if (!is.null(col2)){
    #Note: this has not been tested.
    offset2 <- offset*3

    heatmap2 <- heatmap2 +
      geom_jitter(data = diag,
                  mapping = aes_(x=Num.USI-offset2, y=Num.pair, color=as.name(col2)),
                  size=15, shape=95, show.legend = FALSE)

  }

  n <- length(unique(CDE$Num.Status))

  if( n <= 2){
    col <- c("deepskyblue","navy")
  }else{
    pal <- brewer.pal(min(n,9), "Set1") %>%
      gsub("#F781BF", "burlywood2", .) %>%
      c(., "turquoise3", "blue", "black","seagreen2", "maroon",
        "orchid", "cornflowerblue",  "darkblue", "azure4", "chartreuse1",
        "darkmagenta","orange1", "deeppink", "darkslategray1",
        "green4", "navajowhite2","brown3", "darkgoldenrod3", "deepskyblue1",
        "lightcoral", "mediumorchid", "saddlebrown")
    col <- pal[1:n]
  }

  heatmap2 <- heatmap2 +
      scale_color_gradientn(colors = col )  +
      labs(x="AML Samples", y="AML Samples") +
      theme(axis.title  = element_text(size=24),
            # axis.text.x = element_blank(),
            # axis.text.y = element_blank(),
            legend.key.size = unit(30, units = "points"),
            legend.text = element_text(size=22),
            legend.title = element_text(size=24))

  #If the label point size is not zero, add the patient labels.
  if (lab.size > 0){
    heatmap2<- heatmap2 +
      scale_x_reverse(breaks=seq(1,n.samp,by=1), labels = diag$Var1) +
      scale_y_continuous(breaks=seq(1,n.samp,by=1), labels = diag$Var1)
  }else{
    heatmap2 <- heatmap2 +
      scale_x_reverse()
  }

  #create a legend for the heatmap
  subset <- CDE %>%
    select(Status, Num.Status) %>%
    arrange(Num.Status) %>%
    unique()

  color.Legend <- ggplot(subset, aes(x=Status, y=0.25, fill=Status)) +
    geom_bar(stat = "identity") +
    scale_fill_manual(values=col) +
    theme(legend.text = element_text(size=15))

  l <- cowplot::get_legend(color.Legend)

  list <- list(cormat.melt,  ggheatmap, heatmap2,l)
  names(list) <- c("cormat.melt",  "ggheatmap", "heatmap2", "legend")
  return(list)
}

#Code for the selection of highly correlated pairs of genes
maxCorrPairs <- function(expnData,cutoff){
  library(dplyr)
  library(psych)
  #expnData is genes as rows and patients as columns. must be a data frame class

  #find absolute correlation values
  gene.cor.abs <- abs(cor(t(expnData)))
  p <- corr.test(t(expnData), adjust = "BH",ci = FALSE)

  #function to pullout the highest genes correlation pair
  maxAbsCor <- function(x){
    x <- x[x < 1] #remove the correlation to itself
    x <- x[x == max(x)]
    res <- data.frame(cor=x,
                      pair=names(x),
                      stringsAsFactors = FALSE)

    return(res)
  }

  getPval <- function(gene, pair, pvalues){
    p <- pvalues[gene,pair]
    return(p)
  }

  #apply the function to each row or column (doesn't matter its a diagnol upper and lower matrix still)
  maxcors <- bind_rows(apply(gene.cor.abs,2, maxAbsCor)) %>%
    mutate(gene=colnames(gene.cor.abs)) %>%
    rowwise() %>%
    mutate(pval.BH=getPval(gene,pair,p$p)) %>%
    ungroup() %>%
    filter(!duplicated(cor)) %>%
    arrange(desc(cor)) %>%
    filter(cor >= quantile(cor, c(cutoff)) & pval.BH < 0.01) #select correlations in the 80th percentile or greater

  subset <- expnData[unique(c(maxcors$pair, maxcors$gene)),]

  list <- list(gene.cor.abs, maxcors, subset)
  names(list) <- c("gene.cor.abs", "maxcors","subset.expn")

  return(list)

}


#' @include stat-.r
NULL

#' Reference lines: horizontal, vertical, and diagonal
#'
#' These geoms add reference lines (sometimes called rules) to a plot, either
#' horizontal, vertical, or diagonal (specified by slope and intercept).
#' These are useful for annotating plots.
#'
#' These geoms act slightly differently from other geoms. You can supply the
#' parameters in two ways: either as arguments to the layer function,
#' or via aesthetics. If you use arguments, e.g.
#' `geom_abline(intercept = 0, slope = 1)`, then behind the scenes
#' the geom makes a new data frame containing just the data you've supplied.
#' That means that the lines will be the same in all facets; if you want them
#' to vary across facets, construct the data frame yourself and use aesthetics.
#'
#' Unlike most other geoms, these geoms do not inherit aesthetics from the plot
#' default, because they do not understand x and y aesthetics which are
#' commonly set in the plot. They also do not affect the x and y scales.
#'
#' @section Aesthetics:
#' These geoms are drawn using with [geom_line()] so support the
#' same aesthetics: `alpha`, `colour`, `linetype` and
#' `size`. They also each have aesthetics that control the position of
#' the line:
#'
#'   - `geom_vline()`: `xintercept`
#'   - `geom_hline()`: `yintercept`
#'   - `geom_abline()`: `slope` and `intercept`
#'
#' @seealso See [geom_segment()] for a more general approach to
#'   adding straight line segments to a plot.
#' @inheritParams layer
#' @inheritParams geom_point
#' @param mapping Set of aesthetic mappings created by [aes()] or [aes_()].
#' @param xintercept,yintercept,slope,intercept Parameters that control the
#'   position of the line. If these are set, `data`, `mapping` and
#'   `show.legend` are overridden.
#' @export
#' @examples
#' p <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
#'
#' # Fixed values
#' p + geom_vline(xintercept = 5)
#' p + geom_vline(xintercept = 1:5)
#' p + geom_hline(yintercept = 20)
#'
#' p + geom_abline() # Can't see it - outside the range of the data
#' p + geom_abline(intercept = 20)
#'
#' # Calculate slope and intercept of line of best fit
#' coef(lm(mpg ~ wt, data = mtcars))
#' p + geom_abline(intercept = 37, slope = -5)
#' # But this is easier to do with geom_smooth:
#' p + geom_smooth(method = "lm", se = FALSE)
#'
#' # To show different lines in different facets, use aesthetics
#' p <- ggplot(mtcars, aes(mpg, wt)) +
#'   geom_point() +
#'   facet_wrap(~ cyl)
#'
#' mean_wt <- data.frame(cyl = c(4, 6, 8), wt = c(2.28, 3.11, 4.00))
#' p + geom_hline(aes(yintercept = wt), mean_wt)
#'
#' # You can also control other aesthetics
#' ggplot(mtcars, aes(mpg, wt, colour = wt)) +
#'   geom_point() +
#'   geom_hline(aes(yintercept = wt, colour = wt), mean_wt) +
#'   facet_wrap(~ cyl)
geom_abline <- function(mapping = NULL, data = NULL,
                        ...,
                        slope,
                        intercept,
                        na.rm = FALSE,
                        show.legend = NA) {

  # If nothing set, default to y = x
  if (is.null(mapping) && missing(slope) && missing(intercept)) {
    slope <- 1
    intercept <- 0
  }

  # Act like an annotation
  if (!missing(slope) || !missing(intercept)) {

    # Warn if supplied mapping and/or data is going to be overwritten
    if (!is.null(mapping)) {
      cli::cli_warn("{.fn geom_abline}: Ignoring {.arg mapping} because {.arg slope} and/or {.arg intercept} were provided.")
    }
    if (!is.null(data)) {
      cli::cli_warn("{.fn geom_abline}: Ignoring {.arg data} because {.arg slope} and/or {.arg intercept} were provided.")
    }

    if (missing(slope)) slope <- 1
    if (missing(intercept)) intercept <- 0
    n_slopes <- max(length(slope), length(intercept))

    data <- new_data_frame(list(
      intercept = intercept,
      slope = slope
    ), n = n_slopes)
    mapping <- aes(intercept = intercept, slope = slope)
    show.legend <- FALSE
  }

  layer(
    data = data,
    mapping = mapping,
    stat = StatIdentity,
    geom = GeomAbline,
    position = PositionIdentity,
    show.legend = show.legend,
    inherit.aes = FALSE,
    params = list2(
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomAbline <- ggproto("GeomAbline", Geom,
  draw_panel = function(data, panel_params, coord, lineend = "butt") {
    ranges <- coord$backtransform_range(panel_params)

    if (coord$clip == "on" && coord$is_linear()) {
      # Ensure the line extends well outside the panel to avoid visible line
      # ending for thick lines
      ranges$x <- ranges$x + c(-1, 1) * diff(ranges$x)
    }

    data$x    <- ranges$x[1]
    data$xend <- ranges$x[2]
    data$y    <- ranges$x[1] * data$slope + data$intercept
    data$yend <- ranges$x[2] * data$slope + data$intercept

    GeomSegment$draw_panel(unique(data), panel_params, coord, lineend = lineend)
  },

  default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),
  required_aes = c("slope", "intercept"),

  draw_key = draw_key_abline
)


runComparison <- function() {

	options(warn = -1)

	cat("\n\n ================================================================")
	cat("\n ** Loading the required statistical software packages in R ..... \n \n")

	## load the library
	library(MSstats)

	## save sessionInfo as .txt file
	session <- sessionInfo()
	sink("sessionInfo.txt")
	print(session)
	sink()

	## Input data
	arguments <- commandArgs(trailingOnly=TRUE);
	#cat(arguments)

	cat("\n\n =======================================")
	cat("\n ** Reading the data for MSstats..... \n")

	raw <- read.csv(arguments[1])

	colnames(raw)[colnames(raw) == 'Detection.Q.Value'] <- 'DetectionQValue'
	if(!is.element(c('DetectionQValue'), colnames(raw)) || all(is.na(as.numeric(as.character(raw$DetectionQValue))))) {
	    filter.qvalue <- FALSE
	} else {
	    filter.qvalue <- TRUE
	}

	## remove the rows for iRT peptides
	raw <- SkylinetoMSstatsFormat(raw,
	                              removeProtein_with1Feature = TRUE,
	                              filter_with_Qvalue = filter.qvalue)

	## get standard protein name from StandardType column
	standardpepname <- ""
	if(sum(unique(raw$StandardType) %in% c("Normalization", "Global Standard")) !=0 ){
	    standardpepname <- as.character(unique(raw[raw$StandardType %in% c("Normalization", "Global Standard"), "PeptideSequence"]))
	}

	## check result grid missing or not
	countna<-apply(raw, 2, function(x) sum(is.na(x) | x == ""))
	naname<-names(countna[countna != 0])
	naname<-naname[-which(naname %in% c("StandardType", "Intensity", "Truncated",
	                                    "FragmentIon", "ProductCharge"))]

	if(length(naname) != 0){
		stop(message(paste("Some ", paste(naname, collapse=", "), " have no value. Please check \"Result Grid\" in View. \n", sep="")))
	}

	## -----------------------------------------------
	## Function: dataProcess
	## pre-processing data: quality control of MS runs
	## -----------------------------------------------

	cat("\n\n =======================================")
	cat("\n ** Data Processing for analysis..... \n")

	## get length of command line argument array
	len <- length(arguments)

	optionnormalize <- arguments[3]

	## input is character??
	if (optionnormalize == 0) {
		inputnormalize <- FALSE
	}
	if (optionnormalize == 1) {
		inputnormalize <- "equalizeMedians"
	}
	if (optionnormalize == 2) {
		inputnormalize <- "quantile"
	}
	if (optionnormalize == 3) {
		inputnormalize <- "globalStandards"
	}
	if (optionnormalize != 0 & optionnormalize != 1 & optionnormalize != 2 & optionnormalize != 3){
		inputnormalize <- FALSE
	}

	## missing peaks cbox
	inputmissingpeaks <- arguments[4]

	## feature selection input

	optionfeatureselection <- arguments[5]
    lastFixedArgument <- 6

	if (optionfeatureselection == "TRUE") {
		input_feature_selection <- "highQuality"
	} else {
		input_feature_selection <- "all"
	}

	## Nick, here for new option for 'allow...'
	## remove proteins with interference cbox

	inputremoveproteins <- arguments[6]

	quantData <- try(dataProcess(raw,
	                             normalization=inputnormalize,
	                             nameStandards=standardpepname,
	                             fillIncompleteRows=(inputmissingpeaks=="TRUE"),
	                             featureSubset=input_feature_selection,
	                             remove_noninformative_feature_outlier=(inputremoveproteins=="TRUE"),
	                             summaryMethod = "TMP",
	                             censoredInt="0"))

	if (class(quantData) != "try-error") {

		allfiles <- list.files()
		num <- 0
		filenaming <- "dataProcessedData"
		finalfile <- "dataProcessedData.csv"

		while (is.element(finalfile, allfiles)) {
			num <- num + 1
			finalfile <- paste(paste(filenaming, num, sep="-"), ".csv", sep="")
		}

		write.csv(quantData$ProcessedData, file=finalfile)
		cat("\n Saved dataProcessedData.csv \n")
	} else {
		stop(message("\n Error : Can't process the data. \n"))
	}

	## --------------------------------------------------------------------
	## Function: groupComparison
	## generate testing results of protein inferences across concentrations
	## --------------------------------------------------------------------

	## first, number of comparisons
	numcomparison <- 1

	## then, what comparisons?
	alllevel <- levels(quantData$ProcessedData$GROUP_ORIGINAL)

	comparison <- NULL

	for (k in 1:numcomparison) {

		temp <- NULL

		for (i in 1:length(alllevel)) {
			inputtemp <- arguments[i + lastFixedArgument]
			temp <- c(temp, as.numeric(inputtemp))
		}

		comparison <- rbind(comparison, matrix(temp, nrow=1))

		#inputrowname <- arguments[2]

		namepos <- alllevel[temp > 0]

		if(length(namepos) != 1){

			namepos <- paste(temp[temp >0][1], "(", paste(namepos, collapse = "+"), ")", sep="")

		}

		nameneg <- alllevel[temp < 0]

		if(length(namepos) != 1){

			nameneg <- paste(temp[temp >0][1], "(", paste(nameneg, collapse = "+"), ")", sep="")

		}

		inputrowname <- paste(namepos, nameneg, sep='-')

		row.names(comparison)[k] <- inputrowname
	}

	## then testing with inputs from users
	cat("\n\n ============================")
	cat("\n ** Starting comparison... \n \n")

	## here is the issues : labeled, and interference need to be binary, not character
	resultComparison <- try(groupComparison(contrast.matrix=comparison, data=quantData))

	if (class(resultComparison) != "try-error") {

		allfiles <- list.files()
		num <- 0
		filenaming <- "TestingResult"
		finalfile <- "TestingResult.csv"

		while (is.element(finalfile,allfiles)) {
			num <- num + 1
			finalfile <- paste(paste(filenaming, num, sep="-"), ".csv", sep="")
		}

		write.csv(resultComparison$ComparisonResult, file=finalfile)
		cat("\n Saved the testing result. \n")
	} else {
		cat("\n Error : Can't compare the groups. \n")
	}

	## ---------------------------------
	## Function: groupComparisonPlots
	## visualization for testing results
	## ---------------------------------

	if (class(resultComparison) != "try-error") {

		cat("\n\n =======================================")
		cat("\n ** Visualizing testing results..... \n")

		## Visualization 1: Volcano plot
		## default setup: FDR cutoff = 0.05; fold change cutoff = NA
		groupComparisonPlots(data=resultComparison$ComparisonResult, type="VolcanoPlot", address="")
		cat("\n Saved VolcanoPlot.pdf \n")

		## Visualization 2: Heatmap (required more than one comparisons)
 		if (length(unique(resultComparison$ComparisonResult$Label)) > 1) {
   			groupComparisonPlots(data=resultComparison$ComparisonResult, type="Heatmap", address="")
   			cat("\n Saved Heatmap.pdf \n")
 		} else {
   			cat("\n No Heatmap. Need more than 1 comparison for Heatmap. \n")
 		}

		## Visualization 3: Comparison plot
		groupComparisonPlots(data=resultComparison$ComparisonResult, type="ComparisonPlot", address="")
		cat("\n Saved ComparisonPlot.pdf \n \n")
	} ## draw only for comparison working
}

temp <- try(runComparison())

if (class(temp) != "try-error") {
	cat("\n Finished.")
} else {
	cat("\n Can't finish analysis.")
}


# analyze contaminated PSMs ---------

# init -------
library('readr')
library('ggplot2')
library('reshape2')

# load msms.txt -----
path.data <- '/Volumes/salamanca/GoogleDrive/SingleCell_Data/'
ev <- read_tsv(paste(c(path.data, 'All_human/MQ_exp_37-51/msms.txt'), collapse=''),
                 col_types=cols_only(
                   `Raw file`=col_character(),
                   Sequence=col_character(),
                   Proteins=col_character(),
                   PEP=col_number(),
                   `Retention time`=col_number(),
                   PIF=col_number(),
                   `Precursor Intensity`=col_number()
                 ))
names(ev)[names(ev) == 'Raw file'] <- 'Raw.file'
names(ev)[names(ev) == 'Retention time'] <- 'Retention.time'
# psm/pep -------
# Number of PSMs per contaminant peptide and per non-contaminant peptide

contam.inds <- grep('CON_', ev$Proteins)

contam.ev <- ev[contam.inds,]
uncontam.ev <- ev[-contam.inds,]

# contaminants:
contam.freq <- as.data.frame(table(contam.ev$Sequence))
with(contam.freq, hist(Freq[Freq < 50],
    breaks=c(seq(0,50,by=1)),
    main=paste('PSMs/Contaminated Peptide\n', '50+ PSMs/pep:', sum(Freq>50)),
    xlab='PSMs/Peptide'
))

# non contaminants
uncontam.freq <- as.data.frame(table(uncontam.ev$Sequence))
with(uncontam.freq, hist(Freq[Freq < 50],
    breaks=c(seq(0,50,by=1)),
    main=paste('PSMs/Uncontaminated Peptide\n', '50+ PSMs/pep:', sum(Freq>50)),
    xlab='PSMs/Peptide'
))

# get list of peptides/proteins with over 30 PSMs
pep.freq <- as.data.frame(table(ev$Sequence))
red.peps.list <- as.character(pep.freq[pep.freq$Freq>30, 'Var1'])
ev.f = subset(ev, ev$Sequence %in% red.peps.list)

row.names(ev.f) <- NULL
write.table(ev.f, '~/git/RTLib/dat/psm30.txt', sep = '\t',
            row.names = FALSE, quote = FALSE)

# condense this data
ev.f2 <- ev.f[match(red.peps.list, ev.f$Sequence), c('Sequence', 'Proteins')]
ev.f2 <- cbind(ev.f2, as.data.frame(table(ev.f$Sequence))$Freq )
names(ev.f2)[dim(ev.f2)[2]] <- 'PSMs'

row.names(ev.f2) <- NULL
write.table(ev.f2, '~/git/RTLib/dat/psm30_condensed.txt', sep = '\t',
            row.names = FALSE, quote = FALSE)

# the variance for the RTs of contaminant and non-contaminant peptides. ------

exps = unique(ev$Raw.file)
all.rt.var = data.frame(
  Raw.file=character(),
  Sequence=character(),
  RTVar=numeric(),
  Contam=logical(),
  stringsAsFactors=FALSE
)
c <- 0
for (i in exps) {
  c <- c + 1
  new.exp = subset(ev, ev$Raw.file==i)
  new.exp.peps = unique(new.exp$Sequence)

  rt.var = data.frame(
    Raw.file=as.character(rep(i, length(new.exp.peps))),
    Sequence=as.character(new.exp.peps),
    RTVar=as.numeric(rep(NA, length(new.exp.peps))),
    Contam=as.logical(rep(FALSE, length(new.exp.peps))),
    stringsAsFactors=FALSE
  )
  pep.inds <- match(new.exp.peps, new.exp$Sequence)
  rt.var$Contam[grep('CON_', new.exp[pep.inds,c('Proteins')]$Proteins)] <- TRUE
  rt.var$RTVar <- aggregate(Retention.time ~ Sequence, data=new.exp, FUN=var)$Retention.time

  all.rt.var <- rbind(all.rt.var, rt.var)

  cat('\r', 'Processing:', c, '/', length(exps), i, '                         ');
  flush.console()
}

row.names(all.rt.var) <- NULL
write.table(all.rt.var, '~/git/RTLib/dat/all.rt.var.txt', sep = '\t',
            row.names = FALSE, quote = FALSE)

## plot contam/uncontam variances ------

# experiment to use
exp <- exps[10]

new.exp = subset(all.rt.var, ev$Raw.file==exp)
par(mfrow=c(2,1))
with(new.exp, hist(RTVar[Contam==TRUE & RTVar < 1],
 breaks=seq(0,1,by=0.01),
 main=paste('RT Variance for Contaminated Peptides\n',
            'Peps w/ Variance > 1:', sum(Contam==TRUE & RTVar > 1, na.rm=TRUE),
            '(', formatC(sum(Contam==TRUE & RTVar > 1, na.rm=TRUE) /
                           sum(Contam==TRUE, na.rm=TRUE) * 100, digits=4), '%)',
            '\n', exp),
 xlab='Retention Time Variance'
))
with(new.exp, hist(RTVar[Contam==FALSE & RTVar < 1],
 breaks=seq(0,1,by=0.01),
 main=paste('RT Variance for Non-Contaminated Peptides\n',
            'Peps w/ Variance > 1:', sum(Contam==FALSE & RTVar > 1, na.rm=TRUE),
            '(', formatC(sum(Contam==FALSE & RTVar > 1, na.rm=TRUE) /
                           sum(Contam==FALSE, na.rm=TRUE) * 100, digits=4), '%)',
            '\n', exp),
 xlab='Retention Time Variance'
))

# dist ------
# A distribution of fraction of PSMs spent on contaminants. That is,
# for each file compute the fraction of PSMs mapped to a
# CON__ peptide and plot these fractions as distributions
# for at several PEP thresholds, i.e., 0.01, 0.05, 0.1, 1

exps <- unique(ev$Raw.file)
pep.thresh <- c(0.005, 0.01, 0.05, 0.1, 1)
contam.frac <- as.data.frame(matrix(data=NA, nrow=length(exps), ncol=length(pep.thresh)))
counter <- 0
for (i in exps) {
  counter <- counter + 1
  new.exp <- subset(ev, ev$Raw.file==i)

  counter.j <- 0
  # for each PEP thresh
  for (j in pep.thresh) {
    counter.j <- counter.j + 1
    # apply PEP threshold
    new.exp.pep = subset(new.exp, new.exp$PEP < j)
    # compute contaminated fraction
    contam.frac[counter,counter.j] <-
      length((grep('CON_', new.exp.pep$Proteins))) / nrow(new.exp.pep)
  }
}
colnames(contam.frac) <- paste('PEP <', as.character(pep.thresh))

ggplot(melt(contam.frac), aes(x=value, fill=variable)) +
  geom_histogram(binwidth=0.05) +
  facet_grid(variable~.) +
  labs(x='Contaminated PSM Fraction', title='Contaminated PSM Fractions')


context("caret-based model tuning")

test_that("tuning a random forest with caret works", {
  data(rftuning)
  require(randomForest)
  require(caret)
  require(doMC)

  # set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
  num_cores <- get_parallel_cores_given_os(dev=TRUE)
  registerDoMC(cores = num_cores)

  # make this repeatable - comment this out or change it to get a fresh analysis result
  seed_value <- 23581321
  set.seed(seed_value)

  # tuning grid of parameters and tuning cross-validation parameters
  fit_grid <- expand.grid(mtry=seq(from=2, to=12, by=6))
  fit_control <- trainControl(method="cv",
                              number=4,
                              allowParallel = TRUE,
                              ## Estimate class probabilities
                              classProbs = TRUE)

  # Set up sampling of train and test data sets
  training_set_fraction <- 0.8
  test_set_fraction <- 1.0 - training_set_fraction

  exclude_columns <- c("simulation_run_id", "innovation_rate", "model_class_label", "sample_size", "ta_duration")

  model <- train_randomforest(test_train, training_set_fraction, "two_class_label", fit_grid, fit_control, exclude_columns)

  observed <- length(model)
  expected <- 4

  expect_equal(expected, observed)
})

test_that("tuning a gradient boosted model with caret works", {
  data(rftuning)
  require(caret)
  require(doMC)

  # set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
  num_cores <- get_parallel_cores_given_os(dev=TRUE)
  registerDoMC(cores = num_cores)

  # make this repeatable - comment this out or change it to get a fresh analysis result
  seed_value <- 23581321
  set.seed(seed_value)

  gbm_grid <- expand.grid(.interaction.depth = 8,
                          .n.trees = 200,
                          .shrinkage = 0.05)

  training_control <- trainControl(method="cv",
                                   number=4)

  # Set up sampling of train and test data sets
  training_set_fraction <- 0.8
  test_set_fraction <- 1.0 - training_set_fraction

  exclude_columns <- c("simulation_run_id", "innovation_rate", "sample_size", "ta_duration")

  model <- train_gbm_classifier(test_train, training_set_fraction, "model_class_label", gbm_grid, training_control, exclude_columns)

  observed <- length(model)
  expected <- 4

  expect_equal(expected, observed)
})


##############################################################################
# Merge aggregate data with covariate data
##############################################################################
cat("Merging bin-wise data with covariate data...\n")
agg_cov <- merge(agg_5bp_100k, mut_cov, by=c("CHR", "BIN"))

ratiofilter <- 0
if(ratiofilter){
  agg_cov$ratio <- agg_cov$exp/agg_cov$obs
  agg_cov <- filter(agg_cov, ratio<5) %>% mutate(med=(maxn+minn)/2)
}

##############################################################################
# Get relative rates for 1bp and 3bp motifs and check for homogeneity
# among constituent motifs
##############################################################################
cat("Getting relative rates for submotifs...\n")
# Get submotifs
rates5$Seq3 <- substr(rates5$Sequence, adj, nbp-adj+1)
rates5$Seq5 <- substr(rates5$Sequence, adj-1, nbp-1)

# Recalculate rates for submotifs
rates1 <- rates5 %>%
  dplyr::select(Sequence, Category2, COUNT, num) %>%
  group_by(Category2) %>%
  summarise(COUNT1=sum(COUNT), num1=sum(num), rel_prop1=num1/COUNT1)

rates3 <- rates5 %>%
  dplyr::select(Seq3, Category2, COUNT, num) %>%
  group_by(Seq3, Category2) %>%
  summarise(COUNT3=sum(COUNT), num3=sum(num), rel_prop3=num3/COUNT3)

rates5a <- rates5 %>%
  dplyr::select(Seq5, Category2, COUNT, num) %>%
  group_by(Seq5, Category2) %>%
  summarise(COUNT5=sum(COUNT), num5=sum(num), rel_prop5=num5/COUNT5)

# Merge to single data frame
rates_full <- merge(rates5, rates1, by="Category2")
rates_full <- merge(rates_full, rates3, by=c("Seq3", "Category2"))
rates_full <- merge(rates_full, rates5a, by=c("Seq5", "Category2"))

# Identify motifs whose components have most similar relative rates
cat("Checking for homogeneity of similar motifs...\n")
hettests<-rates5 %>%
  dplyr::select(Sequence, Category2, num, COUNT, rel_prop) %>%
  filter(num>20) %>%
  mutate(SEQ7=substr(Sequence, 2, 8)) %>%
  group_by(Category2, SEQ7) %>%
  arrange(Category2, Sequence) %>%
  mutate(exp=sum(num)/sum(COUNT)*COUNT, p=exp/sum(exp), n=n()) %>%
  filter(n==16) %>%
  # filter(SEQ7=="TTTCGTT", Category2=="cpg_GC_TA") %>% data.frame()
  summarise(pval=chisq.test(num, p=p)$p.value)

##############################################################################
# Run likelihood analysis on full data
##############################################################################
# ra1a %>% filter(model=="L5")
logit_curves<-0
if(logit_curves){
  source("./R/logit_curves.r")
}

##############################################################################
# Initialize data of motif counts to use as covariates in negbin model
##############################################################################
cat("Initializing data for negbin models...\n")
dat_5bp_100k$bin$CHR <- as.integer(gsub("chr", "", dat_5bp_100k$bin$CHR))

names(dat_5bp_100k$bin) <- gsub('\\(', '_', names(dat_5bp_100k$bin))
names(dat_5bp_100k$bin) <- gsub('\\)', '_', names(dat_5bp_100k$bin))

atcols <- c(names(dat_5bp_100k$bin)[1:5],
  names(dat_5bp_100k$bin)[which(substr(names(dat_5bp_100k$bin),
    adj+1, adj+1)=="A")])

# For binsAT, etc., must subselect variables

binsAT <- dat_5bp_100k$bin %>%
  select_(.dots = atcols) %>%
	arrange(CHR, BIN)

gcdn <- c("CA", "CC", "CT")
gccols <- c(names(dat_5bp_100k$bin)[1:5],
  names(dat_5bp_100k$bin)[which(substr(names(dat_5bp_100k$bin),
    adj+1, adj+2) %in% gcdn)])

binsGC <- dat_5bp_100k$bin %>%
  select_(.dots = gccols) %>%
	arrange(CHR, BIN)

cpggccols <- c(names(dat_5bp_100k$bin)[1:5],
  names(dat_5bp_100k$bin)[which(substr(names(dat_5bp_100k$bin),
   adj+1, adj+2)=="CG")])

binscpgGC <- dat_5bp_100k$bin %>%
  select_(.dots = cpggccols) %>%
	arrange(CHR, BIN)

##############################################################################
# Run combined negbin model
##############################################################################
# Add expected #singletons per bin using 1bp motifs
# -used in comparing category-specific models with weighted mean method
a3 <- merge(agg_cov, rates1[,c(1,2,4)], by="Category2")
# a3$exp1 <- a3$nmotifs*a3$rel_prop1

logit_gcta<-read.table(paste0(parentdir, "/output/predicted/binned/GC_TA_binned.txt"), header=F, stringsAsFactors=F)
names(logit_gcta)<-c("CHR", "BIN", "GC_TA", "cpg_GC_TA")
lgcta<-logit_gcta %>% gather(Category2, LSUM, GC_TA:cpg_GC_TA)

logit_gccg<-read.table(paste0(parentdir, "/output/predicted/binned/GC_CG_binned.txt"), header=F, stringsAsFactors=F)
names(logit_gccg)<-c("CHR", "BIN", "GC_CG", "cpg_GC_CG")
lgccg<-logit_gccg %>% gather(Category2, LSUM, GC_CG:cpg_GC_CG)

logit_gcat<-read.table(paste0(parentdir, "/output/predicted/binned/GC_AT_binned.txt"), header=F, stringsAsFactors=F)
names(logit_gcat)<-c("CHR", "BIN", "GC_AT", "cpg_GC_AT")
lgcat<-logit_gcat %>% gather(Category2, LSUM, GC_AT:cpg_GC_AT)

logit_atcg<-read.table(paste0(parentdir, "/output/predicted/binned/AT_CG_binned.txt"), header=F, stringsAsFactors=F)
names(logit_atcg)<-c("CHR", "BIN", "LSUM")
latcg<-logit_atcg %>% mutate(Category2="AT_CG") %>% dplyr::select(CHR, BIN, Category2, LSUM)

logit_atgc<-read.table(paste0(parentdir, "/output/predicted/binned/AT_GC_binned.txt"), header=F, stringsAsFactors=F)
names(logit_atgc)<-c("CHR", "BIN", "LSUM")
latgc<-logit_atgc %>% mutate(Category2="AT_GC") %>% dplyr::select(CHR, BIN, Category2, LSUM)

logit_atta<-read.table(paste0(parentdir, "/output/predicted/binned/AT_TA_binned.txt"), header=F, stringsAsFactors=F)
names(logit_atta)<-c("CHR", "BIN", "LSUM")
latta<-logit_atta %>% mutate(Category2="AT_TA") %>% dplyr::select(CHR, BIN, Category2, LSUM)

ldat<-rbind(latcg, latgc, latta, lgcat, lgccg, lgcta)

a3<-merge(a3, ldat, by=c("Category2", "CHR", "BIN"))

# Aggregate across categories for total #singletons per bin
a3a <- a3 %>%
  # group_by_(.dots=lapply(names(a3)[c(2,3,5:17)], as.symbol)) %>%
  group_by_(.dots=lapply(danames, as.symbol)) %>%
  summarise(obs=sum(obs))

# Add motif counts per bin
a3a1 <- merge(a3a, dat_5bp_100k$bin, by=c("CHR", "BIN", "prop_GC"))

bases <- c("A", "C", "G", "T")
nts <- c("A", "C")

# Uses poisson regression instead of negbin, since negbin fails to converge
# with default parameters of glm.nb()
overall<-0
if(overall){
  cat("Running overall models...\n")

  cat("Formatting data...\n")
  a3a2 <- getSubMotifs(a3a1, nts, bases)

  # Create model formulas
  # Must fix to use filtered motifs
  motif_mod_form <- as.formula(paste("obs~",
  	paste(names(a3a2)[(ncol(a3a2)-511):ncol(a3a2)], collapse="+")))

  feat_mod_form <- as.formula(paste("obs~",
    paste(c(covnames, "prop_GC"), collapse="+")))

  full_mod_form <- as.formula(paste("obs~",
  	paste(names(a3a2)[c(3:15, (ncol(a3a2)-511):ncol(a3a2))], collapse="+")))

  mut_lm_m_all <- glm(motif_mod_form, data=a3a2, family="poisson")
  mut_lm_fe_all <- glm(feat_mod_form, data=a3a2, family="poisson")
  mut_lm_f_all <- glm(full_mod_form, data=a3a2, family="poisson")

  # Calculate McFadden's pseudo R-squared (unadjusted)
  mrsq <- 1-mut_lm_m_all$deviance/mut_lm_m_all$null.deviance
  fersq <- 1-mut_lm_fe_all$deviance/mut_lm_fe_all$null.deviance
  frsq <- 1-mut_lm_f_all$deviance/mut_lm_f_all$null.deviance
  maic <- AIC(mut_lm_m_all)
  feaic <- AIC(mut_lm_fe_all)
  faic <- AIC(mut_lm_f_all)

  cat("Adjusted R-squared of combined model (motifs): ", mrsq, "\n")
  cat("AIC of combined model (motifs): ", maic, "\n")

  cat("Adjusted R-squared of combined model (features): ", fersq, "\n")
  cat("AIC of combined model (features): ", feaic, "\n")

  cat("Adjusted R-squared of combined model (full): ", frsq, "\n")
  cat("AIC of combined model (full): ", faic, "\n")
}

##############################################################################
# Model each category independently
##############################################################################
ptm <- proc.time()
cat("Running per-category models...\n")
source("./R/negbin_run.r")
tottime <- (proc.time()-ptm)[3]
cat("Done (", tottime, "s)\n")

# Specify category as factor
compare.all$Category2 <- factor(compare.all$Category2)
# levels(compare.all$Category2) <- c(
	# "AT>CG", "AT>GC", "AT>TA",
	# "(CpG)GC>AT", "(CpG)GC>CG", "(CpG)GC>TA",
	# "GC>AT", "GC>CG", "GC>TA")

overallcor<-compare.all %>%
  group_by(res) %>%
  summarise(cor=cor(exp,obs), corsq=cor^2)

##############################################################################
# Plot barcharts comparing obs/exp correlation for different models
##############################################################################
mod.corr <- compare.all %>%
	# filter(exp > 100) %>%
	group_by(Category2, res) %>%
	summarise(num=length(exp),
		cor=cor(exp, obs, method="pearson"),
		cor.p=cor.test(exp, obs, method="pearson")$p.value)
mod.corr$SE <- corSE(mod.corr$cor, mod.corr$num)
limits <- aes(ymax = mod.corr$cor + mod.corr$SE,
	ymin=mod.corr$cor - mod.corr$SE)
dodge <- position_dodge(width=0.9)

mc2<-mod.corr %>%
  filter(res %in% c("full", "logit", "marginal7", "motifs5")) %>%
  mutate(gp=ifelse(res %in% c("full", "logit"), "Sequence+Features", "Sequence Only"))
mc2$res<-as.factor(mc2$res)
levels(mc2$res)<-c("K-mers+Features", "Positional+Features", "Positional", "K-mers")
mc2$res<-factor(mc2$res,levels(mc2$res)[c(3,2,4,1)])

customPalette <- brewer.pal(4, "RdBu")[c(3,4,2,1)]
# "#92C5DE" "#F4A582" "#0571B0" "#CA0020"

ggplot(mc2, aes(x=Category2, y=cor, colour=res, fill=res, group=res))+
	geom_bar(stat="identity", position=dodge)+
  # geom_point(position=dodge)+
  # scale_colour_brewer("Predictor",palette="RdBu")+
  # scale_fill_brewer("Predictor", palette="RdBu")+
  scale_colour_manual("Model", values=customPalette)+
  scale_fill_manual("Model", values=customPalette)+
	xlab("Category")+
	ylab("Correlation")+
	# geom_errorbar(limits, position=dodge, width=0.25)+
  # facet_wrap(~gp, nrow=1)+
	theme_bw()+
	theme(legend.title = element_text(size=18),
		legend.text = element_text(size=14),
    legend.position="bottom",
		# axis.title.x = element_text(size=20),
    axis.title.x = element_blank(),
		axis.title.y = element_text(size=20),
		axis.text.y = element_text(size=16, angle=90, hjust=0.5),
    axis.ticks.x = element_blank(),
    # axis.text.x = element_blank())
		axis.text.x = element_text(size=16, angle = 45,  vjust=1, hjust=1.01))

modelbar <- paste0(parentdir, "/images/gw_5bp_vs_mod_3.png")
ggsave(modelbar, width=8, height=6)

# Get AIC for each model/category
compare.aic <- compare.aic %>% spread(Category2, AIC)

mc2b<-mod.corr %>%
  filter(res %in% c("full", "logit", "marginal7", "motifs5")) %>%
  ungroup() %>%
  dplyr::select(Category2, num, res, cor) %>%
  spread(res, cor) %>%
  mutate(corpf=r.test(num, full, logit)$p,
    corps=r.test(num, marginal7, motifs5)$p)

comp.mods<-compare.all %>%
  filter(res %in% c("full", "logit", "marginal7", "motifs5")) %>%
  mutate(gp=ifelse(res %in% c("full", "logit"), "Sequence+Features", "Sequence Only"))
comp.mods$res<-as.factor(comp.mods$res)
levels(comp.mods$res)<-c("K-mers+Features", "Positional+Features", "Positional", "K-mers")
comp.mods$res<-factor(comp.mods$res,levels(comp.mods$res)[c(3,2,4,1)])

ggplot(comp.mods, aes(x=obs, y=exp, group=res, colour=res))+
  geom_point(alpha=0.3)+
  scale_colour_manual("Model", values=customPalette)+
  xlab("Observed Singletons")+
  ylab("Predicted Singletons")+
  geom_smooth(method=lm, se=F, colour="black")+
  facet_wrap(~res, scales="free")+
  theme_bw()+
  theme(legend.position="none")
ggsave(paste0(parentdir, "/images/1mb_scatter.png"), height=4, width=5.5)

##############################################################################
# Plot per-chromosome variation
##############################################################################
# Manual toggle for installing ggbio package
# Uses the install_github() function from devtools to pull latest version,
# due to issue on some clusters where using
# "source("https://bioconductor.org/biocLite.R")"
# does not properly update the installer
#
# If this is not an issue, can simply run:
# source("https://bioconductor.org/biocLite.R")
# biocLite("ggbio", suppressUpdates=TRUE)
install_ggbio <- 0
if(install_ggbio){
	install_github("Bioconductor/BiocInstaller")
	biocLite("ggbio", suppressUpdates=TRUE)
}

cat("Plotting per-chromosome variation...\n")
require(ggbio)
data(hg19IdeogramCyto, package = "biovizBase")
ic2<-as.data.frame(hg19IdeogramCyto)

# Read in chromosome lengths for specifying plot range
chrlen<-read.table(paste0(parentdir, "/reference_data/hg19.genome"), header=T, stringsAsFactors=F)

plotlist<-list()
for(i in 1:22){
  # Specify chromosome
  chrname<-paste0("chr",i)

  #Subset and update data
  d2<-compare.all %>%
    filter(CHR==i, res=="logit_nm") %>%
    mutate(ratio=exp/obs, diff=exp-obs) %>%
    filter(abs(diff)<1200)
  d2$BIN<-d2$BIN*1000000

  # Get chromosome band
  ic2chr<-ic2[ic2$seqnames==chrname,]
  ic2chr$mean<-(ic2chr$start+ic2chr$end)/2
  oetest<-t.test(d2$exp, d2$obs, conf.level=0.99)
  testmin<-oetest$conf.int[[1]]
  testmax<-oetest$conf.int[[2]]
  ic2a<-ic2chr %>%
    group_by(seqnames) %>%
    summarise(min=min(start), max=max(end))

  # Plot scatterplot & loess curve, with banding overlay
  p2<-ggplot()+
    geom_rect(data=ic2chr,
      aes(xmin=start, xmax=end,
        # ymin=min(d2$ratio)-0.3, ymax=min(d2$ratio)-0.1, fill=gieStain),
        ymin=testmin, ymax=testmax, fill=gieStain),
      alpha=0.6)+
    geom_rect(data=ic2a,
      aes(xmin=min, xmax=max,
        ymin=testmin, ymax=testmax),
      colour="black", alpha=0)+
    scale_fill_manual(values=getOption("biovizBase")$cytobandColor)+
    geom_point(data=d2[d2$ratio<2,],
        aes(x=BIN, y=diff, colour=Category2, group=Category2), alpha=0.3)+
    geom_smooth(data=d2[d2$ratio<2,],
        aes(x=BIN, y=diff, colour=Category2, group=Category2), span=0.2, se=FALSE)+
    scale_colour_manual("Category", values=myPaletteCat(9))+
    scale_x_continuous(limits=c(0,chrlen[chrlen$chrom==chrname,]$size))+
    # scale_y_continuous(limits=c(0.25,2))+
    # geom_hline(yintercept=0)+
    # geom_hline(yintercept=testmin, linetype="dashed")+
    # geom_hline(yintercept=testmax, linetype="dashed")+
    # geom_text(data=ic2chr,
    #   aes(x=mean, y=min(d2$ratio)-0.3, label=name),
    #   hjust=0, angle=90, size=3)+
    # facet_wrap(~Category2, scales="free", ncol=1)+
    ylab("Predicted-Observed")+
    xlab(NULL)+
    theme_bw()+
    theme(legend.justification = c(0, 1),
      legend.position = c(0, 1),
      legend.title=element_blank(),
      legend.text=element_text(size=14),
      axis.title.y=element_text(size=16),
      axis.text.x=element_blank(),
      axis.ticks.x=element_blank())+
    guides(fill=FALSE, colour = guide_legend(nrow = 3))
  plotlist[[i]]<-p2
  p2
  ratiofile<-paste0(parentdir, "/images/chr",i,"_ratio.png")
  ggsave(ratiofile, width=10, height=5)
}

pdf(paste0(parentdir, "/images/allchr.pdf"), onefile=T,
  width=8, height=88, paper="letter")
multiplot(plotlist=plotlist[1:4], cols=1)
multiplot(plotlist=plotlist[5:8], cols=1)
multiplot(plotlist=plotlist[9:12], cols=1)
multiplot(plotlist=plotlist[13:16], cols=1)
multiplot(plotlist=plotlist[17:20], cols=1)
multiplot(plotlist=plotlist[21:22], cols=1)
dev.off()