#https://www.mbr-pwrc.usgs.gov/site/communitymodeling/software-code/
#The model code below is written for program R and uses the R2WinBUGS package
#to run WinBUGS as well as the reshape package to format the occurrence data.

#It is designed to estimate static species-specific occupancy and detection,
#constant across sampling locations using the community model. The model also
#estimates the total species richness N, using data augmentation.
#The data are found in the file "occ data.csv".

#Read in the occurence data
data1 <- read.table("basic_MSOM_example/occ data.csv", header=TRUE,sep=",",na.strings=TRUE)
data1$Occ <- rep(1, dim(data1)[1])
#See the first ten lines of data
data1[1:10,]
#How many citings for each species
total.count = tapply(data1$Occ, data1$Species, sum)

#Find the number of unique species
uspecies = as.character(unique(data1$Species))
#n is the number of observed species
n=length(uspecies)

#Find the number of unique sampling locations
upoints = as.character(unique(data1$Point))
#J is the number of sampled points
J=length(upoints)

#Reshape the data using the R package "reshape"
library(reshape)

#The detection/non-detection data is reshaped into a three dimensional
#array X where the first dimension, j, is the point; the second
#dimension, k, is the rep; and the last dimension, i, is the species.
junk.melt=melt(data1,id.var=c("Species", "Point", "Rep"), measure.var="Occ")
X=cast(junk.melt, Point ~ Rep ~ Species)

#Add in the missing lines with NAs
for (i in 1: dim(X)[3]) {
   b = which(X[,,i] > 0)
   X[,,i][b] = 1
   X[,,i][-b] = 0
   X[,,i][1:36,4] = NA;  X[,,i][38:56,4] = NA;
   X[,,i][59:61,4] = NA;  X[,,i][66:70,4] = NA;
}

#Create all zero encounter histories to add to the detection array X
#as part of the data augmentation to account for additional
#species (beyond the n observed species).

#nzeroes is the number of all zero encounter histories to be added
  nzeroes = 50
#X.zero is a matrix of zeroes, including the NAs for when a point has not been sampled
  X.zero = matrix(0, nrow=70, ncol=4)
  X.zero[1:36,4] = NA;  X.zero[38:56,4] = NA;
  X.zero[59:61,4] = NA;  X.zero[66:70,4] = NA;
#Xaug is the augmented version of X.  The first n species were actually observed
#and the n+1 through nzeroes species are all zero encounter histories
  Xaug <- array(0, dim=c(dim(X)[1],dim(X)[2],dim(X)[3]+nzeroes))
  Xaug[,,(dim(X)[3]+1):dim(Xaug)[3]] = rep(X.zero, nzeroes)
  dimnames(X)=NULL
  Xaug[,,1:dim(X)[3]] <-  X

#K is a vector of length J indicating the number of reps at each point j
KK <- X.zero
a=which(KK==0); KK[a] <- 1
K=apply(KK,1,sum, na.rm=TRUE)
K=as.vector(K)

################

#Write the model code to a text file (used to run WinBUGS)
cat("
	model{

#Define prior distributions for community-level model parameters
omega ~ dunif(0,1)

u.mean ~ dunif(0,1)
mu.u <- log(u.mean) - log(1-u.mean)

v.mean ~ dunif(0,1)
mu.v <- log(v.mean) - log(1-v.mean)

tau.u ~ dgamma(0.1,0.1)
tau.v ~ dgamma(0.1,0.1)

for (i in 1:(n+nzeroes)) {

#Create priors for species i from the community level prior distributions
    w[i] ~ dbern(omega)
    u[i] ~ dnorm(mu.u, tau.u) # prob that species i occurs in the community on logit scale which varies normally among species
    v[i] ~ dnorm(mu.v, tau.v) # prob that species i is detected on logit scale and varies normally among species

#Create a loop to estimate the Z matrix (true occurrence for species i
#at point j.
   for (j in 1:J) {
       logit(psi[j,i]) <- u[i]

  mu.psi[j,i] <- psi[j,i]*w[i]
  Z[j,i] ~ dbern(mu.psi[j,i])

#Create a loop to estimate detection for species i at point k during #sampling period k.
     for (k in 1:K[j]) {
    	logit(p[j,k,i]) <-  v[i]
       mu.p[j,k,i] <- p[j,k,i]*Z[j,i]
       X[j,k,i] ~ dbern(mu.p[j,k,i])
}   	}		}

#Sum all species observed (n) and unobserved species (n0) to find the
#total estimated richness
n0 <- sum(w[(n+1):(n+nzeroes)])
N <- n + n0

#Finish writing the text file into a document called basicmodel.txt
}
",file="basicmodel.txt")

#Load the R2Winbugs library
library(R2WinBUGS)

#Create the necessary arguments to run the bugs() command
#Load all the data
sp.data = list(n=n, nzeroes=nzeroes, J=J, K=K, X=Xaug)

#Specify the parameters to be monitored
sp.params = list('u', 'v', 'mu.u', 'mu.v', 'tau.u', 'tau.v', 'omega', 'N')

#Specify the initial values
    sp.inits = function() {
    omegaGuess = runif(1, n/(n+nzeroes), 1)
    psi.meanGuess = runif(1, .25,1)
    list(omega=omegaGuess,w=c(rep(1, n), rbinom(nzeroes, size=1, prob=omegaGuess)),
               u=rnorm(n+nzeroes), v=rnorm(n+nzeroes),
               Z = matrix(rbinom((n+nzeroes)*J, size=1, prob=psi.meanGuess),
		   nrow=J, ncol=(n+nzeroes))
               )
           }

#Run the model and call the results ?fit?
fit = bugs(sp.data, sp.inits, sp.params, "basicmodel.txt", debug=TRUE,
         n.chains=3, n.iter=10000, n.burnin=5000, n.thin=5)

#The model code below is written in the R language and designed to be run
#after the ?covariate model code? for summary of the model results

#See a summary of the parameter estimates
fit$summary

#See baseline estimates of species-specific occupancy and detection in one of
#the habitat types (CATO)
species.occ = fit$sims.list$u
species.det = fit$sims.list$v

#Show occupancy and detection estimates for only the observed species (1:n)
psi = plogis(species.occ[,1:n])
p   = plogis(species.det[,1:n])

occ.matrix <- cbind(apply(psi,2,mean),apply(psi,2,sd))
colnames(occ.matrix) = c("mean occupancy", "sd occupancy")
rownames(occ.matrix) = uspecies
det.matrix <- cbind(apply(p,2,mean),apply(p,2,sd))
colnames(det.matrix) = c("mean detection", "sd detection")

round(occ.matrix, digits=2)

#See estimates of total richness (N)
N = fit$sims.list$N
mean(N)
summary(N)
table(N)
plot(table(N))


#script to create 'access' capital maps

#requires maps output from createSingleLCMap.r
#note: for singleLC_Nature_2001_PastureB_Disagg.asc this took approx 8 hours to complete (2.5 hours for Agri)

library(raster)

#assumes focal value = 1
buf_width <- 5000  #width of buffer in m
BKGs <- list(0.05,0.05,0.0)  #background valeus
BUFs <- list(0.95,0.95,0.75) #buffer values
LCs <- list("Agri","OAgri","Nature") #the maps to work through
years <- c(2005, 2010)
suffix <- "_PastureB_Disagg.asc"

for(yr in years){

  for(i in seq_along(LCs)){

    print(yr)
    print(LCs[[i]])
    print(paste0("Start: ",Sys.time()))

    #create single LC map for the appropriate LC createSingleLCMap.r
    lc <- raster(paste0("Data/ObservedLCmaps/singleLC_",LCs[[i]],"_",yr,suffix))  #land cover from LandCoverMap.r (or ClassifyDisaggregateMap.r)

    crs(lc) <- latlong <- "+proj=longlat +ellps=WGS84 +towgs84=0,0,0,0,0,0,0 +no_defs "

    #crop (for testing)
    #e <- extent(-60,-55,-15,-10)
    #lc <- crop(lc,e)
    #plot(lc)

    lc[lc == 0] <- NA  #set 0 to NA for buffer

    bf <- buffer(lc, width=buf_width, doEdge=T)  #buffer width of 5km

    s <- stack(lc, bf)

    s[is.na(s)] <- BKGs[[i]]
    #plot(s)

    setB <- function(a , b){
      ifelse(a != 1 & b == 1, BUFs[[i]], a)
    }

    out <- overlay(s, fun=setB)

    writeRaster(out, paste0("Data/",LCs[[i]],"Access_",yr,suffix), format = 'ascii', overwrite=T)

    print(paste0("End: ",Sys.time()))
  }
}


#Title: phastcons_score_heatmap
#Auther: Naoto Imamachi
#ver: 1.0.0
#Date: 2015-06-10

#library
require(ggplot2)
require(data.table)
require(reshape2)

#file_path
setwd("C:/Users/Naoto/Documents/github/MIRAGE/data/PhastCons46Ways/")
input_file_path = "C:/Users/Naoto/Documents/github/MIRAGE/data/PhastCons46Ways/phastCons46way_miRBase_v21_hg38Tohg19.txt"
output_file_path = "C:/Users/Naoto/Documents/github/MIRAGE/data/PhastCons46Ways/phastCons46way_miRBase_v21_hg38Tohg19_heatmap.png"

#read_files
label <- c('name','1','2','3','4','5','6','7','8','9','10','11','12','13','14','15','16','17','18','19','20','21','22','23','24','25','26','27','28')
setnames(input_data <- fread(input_file_path,header=F)[1:1000],label)
input_data.melt <- melt(input_data)

p1 <- ggplot(input_data.melt, aes(variable,name))
p1 <- p1 + geom_tile(aes(fill=value),colour="white")
p1 <- p1 + scale_fill_gradient(low="black",high="steelblue")
plot(p1)


# Read in ITRDB data

adjustLW <- function(lw, ew){
  cores = names(lw)
  lwadj = data.frame(matrix(ncol = dim(lw)[2], nrow = dim(lw)[1]))
  names(lwadj) <- names(lw)
  row.names(lwadj) <- row.names(lw)
  for(j in 1:length(cores)){
    if(names(lw)[j] %in% names(ew)){
      idx = match(names(lw)[j], names(ew))
      mdl1 = lm(lw[,j]~ew[,idx])
      mdl2 = lm(lw[,j]~ew[,idx]+I(ew[,idx]^2))
      if(AIC(mdl2)<AIC(mdl1) & mdl2$coefficients[2]>0 & mdl2$coefficients[3]>0){
        lwadj[!is.na(lw[,j])&!is.na(ew[,idx]), j] = mdl2$residuals+1
      } else lwadj[!is.na(lw[,j])&!is.na(ew[,idx]), j] = mdl1$residuals+1
    }
  }
  return(lwadj)
}

##### ITRDB operations #####

setwd("C:\\Users\\dannenberg\\Documents\\Data_Analysis\\ITRDB_update092717") ## Change to ITRDB directory on local machine!!!
library(dplR)

# List text files
files <- list.files()                             # List all files
txtfiles <- files[grep(glob2rx("*.txt"), files)]  # List txt files

n = length(txtfiles)
trdata <- data.frame(matrix(ncol = 10, nrow = n))
names(trdata) <- c("SITE", "START", "END", "PI", "NAME", "LOCATION", "SPECIES", "LAT", "LON", "ELEV")

for(i in 1:n){
  file = txtfiles[i]
  site = unlist(strsplit(file, "[.]"))[1]
  site = unlist(strsplit(site, "[_]"))[1] # some with "_gap"
  fc = file(file)
  mylist <- strsplit(readLines(fc), ": ")
  e = "great!"
  idx = 1
  idxn = length(mylist)
  repeat{
    testline = mylist[[idx]][1]
    test = grepl("Beginning", testline)
    if(idx==idxn){
      e = "crap!"
      break()
    }
    if(test==TRUE) break()
    idx = idx+1
  }
  trdata$SITE[i] = site
  if(e != "crap!"){
    trdata$START[i] = as.numeric(mylist[[idx]][2])
    trdata$END[i] = as.numeric(mylist[[idx+1]][2])
    trdata$PI[i] = mylist[[idx+2]][2]
    trdata$NAME[i] = mylist[[idx+3]][2]
    trdata$LOCATION[i] = mylist[[idx+4]][2]
    trdata$SPECIES[i] = substring(mylist[[idx+5]][2], 1, 4)

    if(grepl("S", mylist[[idx+6]][2])==TRUE){ lat = -1*as.numeric(gsub("\\D", "", mylist[[idx+6]][2])) / 100
    } else lat = as.numeric(gsub("\\D", "", mylist[[idx+6]][2])) / 100

    if(!is.na(lat)){
      dsign = sign(lat)
      degree = floor(abs(lat))
      minute = round(100*(abs(lat)-degree))

      if(minute < 60) trdata$LAT[i] = dsign*degree + dsign*(minute/60)
      else trdata$LAT[i] = lat
    } else trdata$LAT[i] = NA

    if(grepl("W", mylist[[idx+7]][2])==TRUE){ lon = -1*as.numeric(gsub("\\D", "", mylist[[idx+7]][2])) / 100
    } else lon = as.numeric(mylist[[idx+7]][2]) / 100

    if(!is.na(lon)){
      dsign = sign(lon)
      degree = floor(abs(lon))
      minute = round(100*(abs(lon)-degree))

      if(minute < 60) trdata$LON[i] = dsign*degree + dsign*(minute/60)
      else trdata$LON[i] = lon
    } else trdata$LON[i] = NA

    trdata$ELEV[i] = as.numeric(gsub("\\D", "", mylist[[idx+8]][2]))
  }

  ## Insert code to detrend, chronologize, and export to csv
    # Include exceptions for when it can't find the *.rwl file (write names to txt file)
  rwlFile = paste(c(site, ".rwl"), collapse="")
  if(!length(grep(rwlFile, files))){
    txtToWrite = paste(c(site, "\n"), collapse="")
  } else{

    scratchRWL <- tryCatch(
      {
        rwl = read.rwl(rwlFile)
        spl = detrend(rwl, method="Spline")

        ids = read.ids(spl)
        window.length = min(50, nrow(spl))
        window.overlap = window.length - 10
        stats <- tryCatch(
          {
            stats = rwi.stats.running(spl, ids=ids, window.length=window.length, window.overlap=window.overlap)

          }, error=function(cond){
            stats = rwi.stats.running(spl, window.length=window.length, window.overlap=window.overlap)

          }, warning=function(cond){
            stats = rwi.stats.running(spl, window.length=window.length, window.overlap=window.overlap)

          }, finally = {
            temp = NULL
          }
        )

        write.csv(stats, paste(c(site, "w_stats.csv"), collapse=""))

        res = chron(spl, prefix="", prewhiten=TRUE)
        write.csv(res, paste(c(site, "w_crn.csv"), collapse=""))
      }, error=function(e){})

    ## EW
    site = unlist(strsplit(site, "[w]"))[1]
    rwlFile = paste(c(site, "e.rwl"), collapse="")
    scratchEW <- tryCatch(
      {

        ew = read.rwl(rwlFile)
        ew_spl = detrend(ew, method="Spline")

        ids = read.ids(ew_spl)
        window.length = min(50, nrow(ew_spl))
        window.overlap = window.length - 10
        stats <- tryCatch(
          {
            stats = rwi.stats.running(ew_spl, ids=ids, window.length=window.length, window.overlap=window.overlap)

          }, error=function(cond){
            stats = rwi.stats.running(ew_spl, window.length=window.length, window.overlap=window.overlap)

          }, warning=function(cond){
            stats = rwi.stats.running(ew_spl, window.length=window.length, window.overlap=window.overlap)

          }, finally = {
            temp = NULL
          }
        )

        write.csv(stats, paste(c(site, "e_stats.csv"), collapse=""))

        ewres = chron(ew_spl, prefix="", prewhiten=TRUE)
        write.csv(ewres, paste(c(site, "e_crn.csv"), collapse=""))
      }, error=function(e){})

    ## LW
    rwlFile = paste(c(site, "l.rwl"), collapse="")
    scratchLW <- tryCatch(
      {

        lw = read.rwl(rwlFile)
        lw_spl = detrend(lw, method="Spline")

        ids = read.ids(lw_spl)
        window.length = min(50, nrow(lw_spl))
        window.overlap = window.length - 10
        stats <- tryCatch(
          {
            stats = rwi.stats.running(lw_spl, ids=ids, window.length=window.length, window.overlap=window.overlap)

          }, error=function(cond){
            stats = rwi.stats.running(lw_spl, window.length=window.length, window.overlap=window.overlap)

          }, warning=function(cond){
            stats = rwi.stats.running(lw_spl, window.length=window.length, window.overlap=window.overlap)

          }, finally = {
            temp = NULL
          }
        )

        write.csv(stats, paste(c(site, "l_stats.csv"), collapse=""))

        lwres = chron(lw_spl, prefix="", prewhiten=TRUE)
        write.csv(lwres, paste(c(site, "l_crn.csv"), collapse=""))

        ## Adjusted LW (following Griffin et al. 2011, Tree-Ring Res)
        if(dim(lw_spl)[1]==dim(ew_spl)[1] & dim(lw_spl)[2]==dim(ew_spl)[2]){
          lwadj = adjustLW(lw_spl, ew_spl)
          ids = read.ids(lwadj)
          window.length = min(50, nrow(lwadj))
          window.overlap = window.length - 10
          stats <- tryCatch(
            {
              stats = rwi.stats.running(lwadj, ids=ids, window.length=window.length, window.overlap=window.overlap)

            }, error=function(cond){
              stats = rwi.stats.running(lwadj, window.length=window.length, window.overlap=window.overlap)

            }, warning=function(cond){
              stats = rwi.stats.running(lwadj, window.length=window.length, window.overlap=window.overlap)

            }, finally = {
              temp = NULL
            }
          )
          write.csv(stats, paste(c(site, "la_stats.csv"), collapse=""))

          lwadjres = chron(lwadj, prefix="", prewhiten=TRUE)
          write.csv(lwadjres, paste(c(site, "la_crn.csv"), collapse=""))

        } else {
          commonYrs = intersect(row.names(lwres), row.names(ew))
          lwadjres = data.frame(matrix(nrow = length(commonYrs), ncol=3))
          names(lwadjres) <- names(lwres)
          row.names(lwadjres) <- commonYrs
          lwadjres[,3] = lwres[row.names(lwres) %in% commonYrs,3]

          # STD adjustment
          lwtemp = lwres[row.names(lwres) %in% commonYrs,1]
          ewtemp = ewres[row.names(ewres) %in% commonYrs,1]
          mdl = lm(lwtemp~ewtemp)
          lwadjres[,1] = mdl$residuals +1

          # RES adjustment
          lwtemp = lwres[row.names(lwres) %in% commonYrs,2]
          ewtemp = ewres[row.names(ewres) %in% commonYrs,2]
          naidx = !is.na(lwtemp)&!is.na(ewtemp)
          mdl = lm(lwtemp~ewtemp, na.action = na.exclude)
          lwadjres[naidx,2] = mdl$residuals +1

          write.csv(lwadjres, paste(c(site, "la_crn.csv"), collapse=""))

        }

      }, error=function(e){})

  }

  close(fc)
}


#coverage/inst/shiny/coverage1/server.r
#*current version*
#andy south 12/5/16

#https://andysouth.shinyapps.io/coverage1/

library(shiny)
#library(devtools)
#install_github('AndySouth/coverage')
library(coverage)
library(png)

shinyServer(function(input, output, session) {

  ################################
  output$plot_feed <- renderPlot({

    #add dependency on the button
    #if ( input$aButtonRun > 0 )
    #{
      #isolate reactivity of other objects
    #  isolate({

        plot_feeding( man = input$feed_man,
                      #cow = 1-input$feed_man,
                      indoor = input$feed_in,
                      #outdoor = 1-input$feed_in,
                      intervene_indoor = input$intervene_indoor,
                      intervene_outdoor = input$intervene_outdoor,
                      intervene_cow = input$intervene_cow )
                      #intervention = input$intervention,
                      #coverage = input$target_coverage )

      #}) #end isolate
    #} #end if ( input$aButtonRun > 0 )
  })

  ####################################
  output$plot_pie_feed <- renderPlot(width = 150, height = 150,{
  #output$plot_pie_feed <- renderPlot({

    plot_pie_feeding( man = input$feed_man,
                  #cow = 1-input$feed_man,
                  indoor = input$feed_in,
                  #outdoor = 1-input$feed_in,
                  intervene_indoor = input$intervene_indoor,
                  intervene_outdoor = input$intervene_outdoor,
                  intervene_cow = input$intervene_cow )
  })

  ####################################
  output$plot_pie_expose <- renderPlot(width = 150, height = 150,{
  #output$plot_pie_expose <- renderPlot({

    plot_pie_exposure(man = input$feed_man,
                      #cow = 1-input$feed_man,
                      indoor = input$feed_in,
                      #outdoor = 1-input$feed_in,
                      intervene_indoor = input$intervene_indoor,
                      intervene_outdoor = input$intervene_outdoor,
                      intervene_cow = input$intervene_cow )
    #intervention = input$intervention,
    #coverage = input$target_coverage )
  })

  #to update values based on changes in others

  #stop feed_man going below feed_indoors
  #not needed now that human feed is a proportion of indoors
  #observe({ if ( input$feed_man < input$feed_in ) updateSliderInput(session, "feed_man", value = input$feed_in ) })

  #stop feedindoors going above feed_man
  # observe({ updateNumericInput(session, "feed_man", value = 1-input$feed_cow) })
  # observe({ updateNumericInput(session, "feed_cow", value = 1-input$feed_man) })
  # observe({ updateNumericInput(session, "feed_in", value = 1-input$feed_out) })
  # observe({ updateNumericInput(session, "feed_out", value = 1-input$feed_in) })

})


# wahpenayo at gmail dot com
# 2018-01-21
#-----------------------------------------------------------------
# explore the data
#-----------------------------------------------------------------
if (file.exists('e:/porta/projects/taigabench')) {
  setwd('e:/porta/projects/taigabench')
} else {
  setwd('c:/porta/projects/taigabench')
}
source('src/scripts/r/functions.r')
#-----------------------------------------------------------------
dataset <- 'ontime'
dataf <- ontime.data
#suffixes <- c('32768','131072','524288','2097152','8388608','33554432')
suffix <- '8388608' # OOM with 33554432 records
trainfile <- train.file(dataset=dataset,suffix=suffix)
dtrain <- dataf(trainfile)
#-----------------------------------------------------------------
summary(dtrain)
#-----------------------------------------------------------------
for (col in colnames(dtrain)) {
  print(col)
  if (is.numeric(dtrain[[col]])) {
    hist.numeric(
      data=dtrain,col=col,dataset='ontime',problem='l2')
  } else {
    hist.factor(
      data=dtrain,col=col,dataset='ontime',problem='l2')
  }
}
#-----------------------------------------------------------------
quantile(
  x=dtrain$arrdelay,
  probs=seq(from=0.01,to=0.99,by=0.01))
quantile(
  x=dtrain$arrdelay,
  probs=seq(from=0.90,to=0.999,by=0.001))
#-----------------------------------------------------------------
# => use 3 hours =180 min for cancelled/delayed
filtered <- dtrain[dtrain$arrdelay<2*60,]
summary(filtered)
quantile(
  x=filtered$arrdelay,
  probs=seq(from=0.90,to=0.999,by=0.001))
dev.on(
  file=plot.file(
    dataset='ontime',
    problem='l2',
    prefix='arrdelay-filtered'),
  aspect=0.5,
  width=1280)
ggplot(data=filtered, aes(filtered$arrdelay)) +
  geom_histogram(bins=1000) +
  # scale_y_log10() +
  scale_x_continuous(breaks = scales::pretty_breaks(n = 20))
dev.off()
#-----------------------------------------------------------------


# Goal: Make pictures in PDF files that can be put into a paper.

xpts <- seq(-3,3,.05)

# Here is my suggested setup for a two-column picture --
pdf("demo2.pdf", width=5.6, height=2.8, bg="cadetblue1", pointsize=8)
par(mai=c(.6,.6,.2,.2))
plot(xpts, sin(xpts*xpts), type="l", lwd=2, col="cadetblue4",
     xlab="x", ylab="sin(x*x)")
grid(col="white", lty=1, lwd=.2)
abline(h=0, v=0)

# My suggested setup for a square one-column picture --
pdf("demo1.pdf", width=2.8, height=2.8, bg="cadetblue1", pointsize=8)
par(mai=c(.6,.6,.2,.2))
plot(xpts, sin(xpts*xpts), type="l", lwd=2, col="cadetblue4",
     xlab="x", ylab="sin(x*x)")
grid(col="white", lty=1, lwd=.2)
abline(h=0, v=0)

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/g2.r


#' Network Delineation
#'
#' Identifies flowlines upstream from a COMID
#'
#' @param comid COMID at network outlet
#' @param flow NHDPlusV2 flow table, PlusFlow.dbf
#' @param vaa NHDPlusV2 value added attributes table, PlusFlowlineVAA.dbf"

#' @return vector of upstream COMIDs
#'
#' @export

net_delin <- function(comid, flow = flow, vaa = vaa){

  names(flow) <- toupper(names(flow))
  names(vaa) <- toupper(names(vaa))

  fcomid <- comid
  VPUOUT <- vaa[vaa$COMID %in% fcomid, c("VPUOUT")]
  net <- data.frame(fcomid, VPUOUT)

  # delineate upstream until the full net is delineated or 5 wbs are found
  while (any(flow$TOCOMID %in% fcomid) & #the fcomid has somthing upstream
         all(!is.na(net$fcomid)) & #na might occur if missmatch
         all(net$VPUOUT == 0))# if network leaves the vpu stop the loop
  {
    #upstream comid's
    fcomid <- flow[flow[, "TOCOMID"] %in% fcomid, "FROMCOMID"] #upstream comids
    fcomid <- unique(fcomid[fcomid != 0])

    #vaa of upstream COMID
    VPUOUT <- vaa[vaa$COMID %in% fcomid, c("VPUOUT")]

    if(length(VPUOUT) > 0){
      #Identify whether lake network travels outside vpu
      if(any(VPUOUT == 1)){VPUOUT = 1} else {VPUOUT = 0}
    }

    temp <- data.frame(VPUOUT, fcomid)
    net <- rbind(temp[!temp$fcomid %in% net$fcomid, ], net)

    if (nrow(net) > 5e+05) {
      stop(print("There is a problem"))
    }
  }

  if(any(net$VPUOUT != 0)){
    warning("Stream Network Left VPU")
  }

  net <- net$fcomid

  return(net)
}

#' Basin Shape Metrics
#'
#' Calculates metrics the describe the shape of a networks waterhsed.
#'
#' @param network a single network extracted from NHDPlusV2
#' @param NHDCatchments NHDPlusV2 catchment coverage, Catchment.shp
#'
#' @return sf object of watershed attributed with
#'  width (\code{width}), maximum length (\code{mxln}),
#'  area (\code{area}), parimeter (\code{prmt}),
#'  compactedness coefficient (\code{CmpC}),
#'  circularoty ratio (\code{CrcR}), and elongation
#'  ratio (\code{ElnR}). Where applicable, units = m
#'
#' @details Compactness coefficient (CmpC) is defined as the ratio of the
#' watershed perimeter to the circumference of equivalent circular area.
#'
#' Elongation ratio (ElnR) is defined as the ratio of diameter of a circle of the same area as
#' the watershed to the maximum watershed length. The numerical value varies
#' from 0 (in highly elongated shape) to 1 (in circular shape).
#'
#' Circulatory ratio (CrcR) is defined as the ratio of watershed area to the area of the circle
#' having the same perimeter as the watershed perimeter. The numeric value
#' may vary in between 0 (in line) and 1 (in a circle).
#'
#' @export

cat_shp <- function(network, NHDCatchments){

  cats <- NHDCatchments[NHDCatchments$FEATUREID%in%network$COMID,]
  #project to albers

  cats <- sf::st_transform(cats, 5070)
  cats <- sf::st_cast(sf::st_union(cats), "POLYGON")

  box <- sf::st_bbox(cats)

  vert <- sf::st_linestring(as.matrix(rbind(c(box$xmin,box$ymin), c(box$xmin,box$ymax))))
  vert <- sf::st_length(vert)

  horiz <- sf::st_linestring(as.matrix(rbind(c(box$xmin,box$ymin),c(box$xmax,box$ymin))))
  horiz <- sf::st_length(horiz)

  width <- min(horiz, vert)
  mxln <- max(horiz, vert)
  area <- sf::st_area(cats)
  prmt <- lwgeom::st_perimeter(cats)

  #Perimeter of watershed/Perimeter of circle of watershed area
  #Circle Perimeter (P) = √(4πA)
  #circle area (A) = P^2 / 4π
  #circle diameter D = 2r; r=√(A/π)

  #Compactness coefficient is defined as the
  #ratio of the watershed perimeter to the
  #circumference of equivalent circular area.
  CmpC <- prmt/sqrt(4* base::pi *area)

  #Circulatory ratio is defined as the
  #ratio of watershed area to the area of
  #the circle having the same perimeter as the watershed perimeter
  CrcR <- area/(prmt^2 / 4 * base::pi)

  #Elongation ratio is defined as the
  #ratio of diameter of a circle of the same area as the watershed
  #to the maximum watershed length.
  #The numerical value varies from 0 (in highly elongated shape) to
  #1 (in circular shape). These values can be
  ElnR <- (2*sqrt(area / base::pi))/mxln

  cats <- sf::st_as_sf(data.frame(cbind(width = width/1000, mxln = mxln/1000,
                                        area = area/1e6, prmt = prmt/1000,
                                        CmpC, CrcR, ElnR), geometry = cats),
                       crs = 5070)

  #transform back into network crs
  cats <- sf::st_transform(cats, crs = sf::st_crs(network))

  return(cats)
}

#' Network Shape Metrics
#'
#' Calculates metrics the describe the shape of a network
#'
#' @param network a single network extracted from NHDPlusV2
#' @param vaa NHDPlusV2 value added attributes table, PlusFlowlineVAA.dbf"
#'
#' @return data.frame with network stream order (\code{Ord}),
#' Mainstem Length (\code{Ord}), total length (\code{TL}), Drainage
#' Density (\code{Dd}), Horton Laws: bifurcation ratio (\code{Rb}),
#' length Ratio (\code{Rl}) and area Ratio (\code{Ord})
#'
#' @details Horton ratios estimated as semilog relationships
#'
#' @export

net_shp<-function (network, vaa){

  net <- sf::st_set_geometry(network, NULL)
  names(net) <- toupper(names(net))
  names(vaa) <- toupper(names(vaa))

  #remove diveregences
  vaa <- vaa[vaa$STREAMORDE == vaa$STREAMCALC & vaa$COMID %in% net$COMID,]

  #split each path - more accurately represents stream reaches in calcuations
  #z<-dat[[1]][,c("COMID", "STREAMORDE", "LEVELPATHI")]
  #plot(st_geometry(network))
  #plot(st_geometry(network[network$COMID%in%z$COMID,]), col = "red", add = T)

  dat <- split(vaa, as.character(vaa$LEVELPATHI))

  #calculate Mainstem Length (while we are here)
  MSL <- max(unlist(lapply(dat, function(x) sum(x$LENGTHKM))))

  dat <- do.call(rbind, lapply(dat, function(z)
    do.call(rbind, lapply(split(z, z$STREAMORDE), function(x)
      data.frame(STREAMORDE = unique(x$STREAMORDE),
                 TOTDASQKM = max(x$TOTDASQKM),
                 LENGTHKM = sum(x$LENGTHKM))))))

  #summarise by stream order
  dat <- split(dat, as.character(dat$STREAMORDE))
  dat <- do.call(rbind, lapply(dat, function(x)
    data.frame(STREAMORDE = unique(x$STREAMORDE),
               N = nrow(x),logN = log(nrow(x)) ,
               A = mean(x$TOTDASQKM), logA = log(mean(x$TOTDASQKM)),
               L = mean(x$LENGTHKM), logL = log(mean(x$LENGTHKM)))))

  #y = log(c(60,13,9,4,1))
  #x = c(1:5)
  #1/exp(coef(lm(y~x))[2])

  # estimate log(Rb) as slope
  #plot(dat$STREAMORDE,dat$logN)
  #abline(lm(dat$logN~dat$STREAMORDE))
  #fit semilog model
  lmRb <- stats::lm(logN ~ STREAMORDE, data = dat)
  # slove for Rb w/base e
  Rb <- 1/exp(stats::coef(lmRb)["STREAMORDE"])
  Rb_rsq <- summary(lmRb)$r.squared

  #length
  #plot(dat$STREAMORDE, dat$logL)
  #abline(lm(dat$logL~dat$STREAMORDE))
  lmRl <- stats::lm(logL ~ STREAMORDE, data = dat)
  # slove for Rb w/base e
  Rl <- exp(stats::coef(lmRl)["STREAMORDE"])
  Rl_rsq <- summary(lmRl)$r.squared

  #area
  #plot(dat$STREAMORDE, dat$logA)
  #abline(lm(dat$logA~dat$STREAMORDE))
  lmRa <- stats::lm(logA ~ STREAMORDE, data = dat)
  # slove for Rb w/base e
  Ra <- exp(stats::coef(lmRa)["STREAMORDE"])
  Ra_rsq <- summary(lmRa)$r.squared

  TL <- sum(vaa$LENGTHKM)
  Dd <- sum(vaa$LENGTHKM)/max(vaa$TOTDASQKM)
  Ord <- max(vaa$STREAMORDE)

  out <- data.frame(Ord, MSL, TL, Dd, Rb,Rb_rsq, Rl, Rl_rsq, Ra, Ra_rsq, row.names = NULL)

  return(out)
}


source('2020-08-31-jsa-type-v2-ch2/02-model/init.r')

model_analyse <- "BGY-E0-C4-I8000-A0.8-T12-F25-V0"
model_predict <- "BGY-E1-C4-I20000-A0.9-T12-F10-V0"

# Get graph from model_predict
dir_model_folder <- paste0(dir_analysis_edie_model, model_predict, "/")

# Load posterior simulation
load(paste0(dir_model_folder, "post.data"))     # as "allsim"

# Load forecast predictions
load(paste0(dir_model_folder, "forecast.data")) # as "forecast"

# Original data
data_raw <- read.csv(
    paste0(dir_model_folder, "data.csv"),
    na.strings=c(""),
    stringsAsFactor = TRUE
)

# R data
data <- read_rdump(paste0(dir_model_folder, "count_info.data.R"))

# Map model indices to original variables
mapping <- unique(data.frame(
    groupname = as.character(data_raw$group),
    group = as.numeric(data_raw$group)
))

# Forecast information

forsim <- data.table(convert_forecast_to_df(data, data_raw, forecast))

head(forsim)

forsim <- forsim[, list(
    for_cml_value_pred_median = as.integer(median(value)),
    for_cml_value_pred_lwrCI95 = as.integer(quantile(value, 0.025)),
    for_cml_value_pred_uprCI95 = as.integer(quantile(value, 0.925)),
    for_cml_value_pred_mean = as.integer(mean(value))
), by=c("index", "group")]

names(forsim)[names(forsim) == "index"] <- "year"

# Up till year 2019

li_df <- summarize_simulations_observed(data, allsim)
Z <- li_df$Z                      # Counts for each year for sim and actual, df

Y <- data.table(Z)
sim_median <- Y[sim != 0, list(
    cml_value_pred_median = as.integer(median(cml_value)),
    cml_value_pred_lwrCI95 = as.integer(quantile(cml_value, 0.025)),
    cml_value_pred_uprCI95 = as.integer(quantile(cml_value, 0.925)),
    cml_value_pred_mean = as.integer(mean(cml_value))
), by=c("year", "group")]
obs <- Y[sim == 0, c("year", "group", "cml_value")]
names(obs)[3] <- "cml_value_obs"

# sanity check
check <- data.table(data_raw)[, .N, by=c("group", "year")][order(group, year)]
check[, cml:= cumsum(N), by="group"]
head(check[group=="NA"], 20)

all <- merge(obs, sim_median, by=c("year", "group"))

# Combine with forecasts
head(all)
head(forsim)

final_counts <- all[year==max(year),list(
    count = max(cml_value_obs)
), by= c("year", "group")]
final_counts$year <- NULL

forsim <- merge(forsim, final_counts, by=c("group"), all.x=T, all.y=T)

forsim$for_cml_value_pred_median <-
    forsim$for_cml_value_pred_median + forsim$count
forsim$for_cml_value_pred_lwrCI95 <-
    forsim$for_cml_value_pred_lwrCI95 + forsim$count
forsim$for_cml_value_pred_uprCI95 <-
    forsim$for_cml_value_pred_uprCI95 + forsim$count
forsim$for_cml_value_pred_mean <-
    forsim$for_cml_value_pred_mean + forsim$count
forsim$count <- NULL

head(all)

all <- merge(all, forsim, by=c("year", "group"), all.x=T, all.y=T)

all <- merge(all, mapping, by="group", all.x=T, all.y=F)
all$group <- NULL

wfile <- paste0(v2_dir_data_webapp, "ch2-fig-01-data.csv")
fwrite(all, wfile, na="")

# show the mean!

# Get results.csv from model_analyse
dir_model_folder <- paste0(dir_analysis_edie_model, model_analyse, "/")
rfile <- paste0(dir_model_folder, "output/results.csv")
results <- fread(rfile)

results$expected_median <- NULL
results$expected_CI_lower <- NULL
results$expected_CI_higher <- NULL
results$fore_mu <- NULL
results$fore_lower <- NULL
results$fore_upper <- NULL
results$group <- NULL

dir_model_folder <- paste0(dir_analysis_edie_model, model_predict, "/")
rfile <- paste0(dir_model_folder, "output/results.csv")
results_pred <- fread(rfile)

results_pred$expected_median <- NULL
results_pred$expected_CI_lower <- NULL
results_pred$expected_CI_higher <- NULL
results_pred$slowdown<- NULL
results_pred$slowdown_CI_lower <- NULL
results_pred$slowdown_CI_higher <- NULL
results_pred$group <- NULL

results <- merge(results, results_pred, on="groupname")

names(results)[grep("for_", names(results))] <-
    paste0(names(results)[grep("for_", names(results))], "_10y")

wfile <- paste0(v2_dir_data_webapp, "ch2-fig-02-data.csv")
fwrite(results, wfile, na="")


args <- commandArgs(TRUE)

N <- args[1]
x <- rnorm(N,0,1)

png(filename="C:/xampp/htdocs/recommender/temp.png", width=500, height=500)
hist(x, col="lightblue")
dev.off()


############################################################
# For macaque paper, 08.19
# Compares chromosome lengths and # of CNVs
# Gregg Thomas
############################################################

this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

library(ggplot2)
library(reshape2)
library(plyr)
library(grid)
library(ggpubr)
library(cowplot)

source("../lib/read_svs.r")
source("../lib/filter_svs.r")
source("../lib/subset_svs.r")
source("../lib/design.r")

############################################################

savefiles = T
rm_alus = T
in_data = read.csv("../cnv-calls/macaque-cnv-chrome-counts.csv")

if(rm_alus){
  in_data = subset(in_data, Length < 275 | Length > 325)
}
# For Alu stuff

######################

######################
# All CNVs and chromosome length
figS2a = ggplot(in_data, aes(Length, Num.CNVs)) +
  geom_point(size=3, color="#666666") +
  geom_smooth(method="lm", fullrange=T, size=0.75, linetype="dashed", alpha=0, color="#333333") +
  labs(x="Chromosome length", y="# CNVs") +
  bartheme()
print(figS2a)
######################

######################
# Deletions and chromosome length
figS2b = ggplot(in_data, aes(Length, Num.dels)) +
  geom_point(size=3, color="#666666") +
  geom_smooth(method="lm", fullrange=T, size=0.75, linetype="dashed", alpha=0, color="#333333") +
  labs(x="Chromosome length", y="# Deletions") +
  bartheme()
print(figS2b)
######################

######################
# Duplications and chromosome length
figS2c = ggplot(in_data, aes(Length, Num.dups)) +
  geom_point(size=3, color="#666666") +
  geom_smooth(method="lm", fullrange=T, size=0.75, linetype="dashed", alpha=0, color="#333333") +
  #ggtitle("Gene family changes vs SV duplications") +
  #scale_color_manual(name="", values=c('#490092','#920000'), labels=c("Macaque","Human"), drop=FALSE) +
  #scale_y_continuous(limits=c(0, 5)) +
  labs(x="Chromosome length", y="# Duplications") +
  bartheme()
print(figS2c)
######################

######################
# Making the figure

p = plot_grid(figS2a, figS2b, figS2c, nrow=1, labels=c("A","B","C"), label_size=24)

print(p)

if(savefiles){
  outfile = "figS2.pdf"
  cat(" -> ", outfile, "\n")
  ggsave(filename=outfile, p, width=14, height=4, units="in")
}

######################


# Libraries
library(raster)
library(maptools)

# Params
directory = 'data/geo'
map_crs = '+proj=longlat +datum=WGS84'

# Initialize
data(wrld_simpl)

################ Geospatial functions ################

# Read master grid
file <- paste0(directory, '/0_manual/anthropogenic_biomes/anthromes-v2-2000-global-geotif/a2000_global.tif')
x1 <- raster::raster(file)

# Read shp 1
file <- c('/0_manual/soil_map/DSMW/DSMW.shp')
x2 <- raster::shapefile(paste0(directory, file[1]))
raster::projection(x2) <- map_crs
plot(x2)

# Rasterize shp
file <- paste0(directory, '/0_manual/plant_wcmc/Centres_of_Plant_Diversity_2013/Centres_of_Plant_Diversity_2013/CPD_2013.shp')
x4 <- raster::shapefile(file)

rst <- raster(matrix(runif(20), 5, 4))
extent(rst) <- extent(-180, 180, -90, 90)
res(rst) <- 0.5 # 1 deg cell size

rasterized <- raster::rasterize(x4, rst)
# attribute_t <- levels(rasterized)[[1]]
head(levels(rasterized)[[1]]); dim(levels(rasterized)[[1]])
head(unique(levels(rasterized)[[1]])); unique(dim(levels(rasterized)[[1]]))
# rasterized <- raster::ratify(rasterized) # reset raster attribute table

# Resample to same extent/resolution/grid (for categorical)
x5 <- raster::resample(rasterized, x1, method='ngb')
par(mfrow=c(2,1)); plot(rasterized, col=rev(topo.colors(50))); plot(x3, col=rev(heat.colors(50)))

plot(x3)
plot(wrld_simpl, add=T)

raster::stack(x1, x5) # now it is able to stack

# Resample to same extent/resolution/grid (for continuous)
# aggregate (fun=mean) -> resample
# TODO:

# Tutorial on vector
# https://cengel.github.io/rspatial/2_spDataTypes.nb.html

# sp package
library(sp)
ln <- sp::Line(matrix(runif(6), ncol=2))
str(ln)

lns <- sp::Lines(list(ln), ID = "a") # this contains just one Line!
str(lns)

sp_lns <- sp::SpatialLines(list(lns))
str(sp_lns)

dfr <- data.frame(id = "a", use = "road", cars_per_hour = 10) # note how we use the ID from above!
sp_lns_dfr <- sp::SpatialLinesDataFrame(sp_lns, dfr, match.ID = "id")
str(sp_lns_dfr)

# sf package
library(sf)
lnstr_sfg <- sf::st_linestring(matrix(runif(6), ncol=2))
class(lnstr_sfg)

(lnstr_sfc <- sf::st_sfc(lnstr_sfg)) # just one feature here
class(lnstr_sfc)

(lnstr_sf <- st_sf(dfr, lnstr_sfc))
class(lnstr_sf)

# Test
folders <- list.files(directory)
folder_dir <- paste0(directory, "/", folders[1])
list.files(folder_dir)


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')

setwd("/Users/mengmengjiang/all datas/voltage")
library(xlsx)

##raeding datas of flow rates
eq<-read.xlsx("voltage.xls",sheetName="ethanol_q",header=TRUE)
aq<-read.xlsx("voltage.xls",sheetName="acetone_q",header=TRUE)
iq<-read.xlsx("voltage.xls",sheetName="iso_q",header=TRUE)

##
yan<-c("red","blue","green3")

## layout

par(mfrow = c(2,2), mar = c(2.4,3.4,1,1), oma = c(1,1,1,1))
layout(matrix(c(1,2,3),3,1,byrow = TRUE))

## flow rates
plot(eq$f, eq$va,  col=0, xaxs="i", xlim=c(-0.002, 0.032), ylim=c(0.4,1.2),
     xlab=expression(italic(Q)(ml/min)),mgp=c(1.8, 0.5, 0),tck=0.01,cex.lab=1.6,cex.axis=1.6,
     ylab=expression(italic(V)(kv)))

mtext("Flow rate",col="black",3,line=-1.4,font=2,cex=1.2)

lines(eq$f,eq$seva,col=yan[1],pch=0,lwd=2,lty=4,type="b")
lines(aq$f,aq$seva,col=yan[2],pch=1,lwd=2,lty=4,type="b")
lines(iq$f,iq$seva,col=yan[3],pch=2,lwd=2,lty=4,type="b")

leg<-c("ethanol","acetone","iso")

legend("bottomright",legend=leg, col=yan, pch=c(0,1,2),bty="n",lwd=2,lty=2,inset=.01,cex=1.5)

## Distance

eq<-read.xlsx("voltage.xls",sheetName="ethanol_d",header=TRUE)
aq<-read.xlsx("voltage.xls",sheetName="acetone_d",header=TRUE)
iq<-read.xlsx("voltage.xls",sheetName="iso_d",header=TRUE)

plot(eq$d, eq$va,  col=0, xaxs="i", xlim=c(0.5,4.5), ylim=c(0.6,1.4),xlab=expression(italic(Distance)(mm)),mgp=c(1.7, 0.5,0),tck=0.01,cex.lab=1.6,cex.axis=1.6,ylab=expression(italic(V)(kv)))

mtext("Distance",col="black",3,line=-1.4,font=2,cex=1.2)

lines(eq$d,eq$seva,col=yan[1],pch=0,lwd=2,lty=4,type="b")
lines(aq$d,aq$seva,col=yan[2],pch=1,lwd=2,lty=4,type="b")
lines(iq$d,iq$seva,col=yan[3],pch=2,lwd=2,lty=4,type="b")

leg<-c("ethanol","acetone","iso")

legend("bottomleft",legend=leg, col=yan, pch=c(0,1,2),bty="n",lwd=2,lty=2,inset=.01,cex=1.5)

## Nozzle diameter ###

eq<-read.xlsx("voltage.xls",sheetName="ethanol_r",header=TRUE)
aq<-read.xlsx("voltage.xls",sheetName="acetone_r",header=TRUE)
iq<-read.xlsx("voltage.xls",sheetName="iso_r",header=TRUE)

plot(eq$r, eq$va,  col=0, xaxs="i", xlim=c(0.25,0.85), ylim=c(0.6,1.4),xlab=expression(paste(italic(Nozzle)," ",italic(diameter),(mm))),mgp=c(1.7, 0.5,0),tck=0.01,cex.lab=1.6,cex.axis=1.6,ylab=expression(italic(V)(kv)))

mtext("Nozzles",col="black",3,line=-1.4,font=2,cex=1.2)

lines(eq$r,eq$seva,col=yan[1],pch=0,lwd=2,lty=4,type="b")
lines(aq$r,aq$seva,col=yan[2],pch=1,lwd=2,lty=4,type="b")
lines(iq$r,iq$seva,col=yan[3],pch=2,lwd=2,lty=4,type="b")
g
leg<-c("ethanol","acetone","iso")

legend("topleft",legend=leg, col=yan, pch=c(0,1,2),bty="n",lwd=2,lty=2,inset=.01,cex=1.5)


#function to process the simulated data,
# feng@BU 12/15/2016
#
#1) read the data from the disk
#2) process to see the linear regress results
#		pick the top portions to see the identification performance
#		fdr
#		roc
#
#3) do the ordinary t test to compare the performance of linear regression model
#4) sumarize the results
#5) plotting and reporting
###############################
library(ARPPA)
library(qvalue)
#install.packages("pROC")
library(pROC)

#filename is the base name of the file. the file should be
#		r data file (".RData"). filename="result_"
#sample.size, used for t test, the sample size for each group
#percent.nonZero, indicate the proportion of nonzero interaction in the simulation
#object.load, used to indicate the loaded object name
#mode, 1 for comparison with either negative control or isotype control, other values for no control
analyzeData<-function(path,filename="result_", repeats=1,
					sample.size=5,
					proportion.nonZero=0.02,
					object.load="lstToSave",
					mode=1
			)

{
#path<-filePath
sampleSize=sample.size;
prob.nonZero=proportion.nonZero;
cat("start doing the data reading......\n");
flush.console();
repeats<-repeats
setwd(path)
#("E:\\feng\\LAB\\hg\\proteinArray_Masa\\ARPPA\\data\\EqualVar_NegativeCon");
#setwd("~/Desktop/arppr/EqualVar_NegativeCon/")
i<-19
portions<-seq(0.000, 1.0, 0.001)
stats_df<-data.frame("portions"=portions);
stats_qval_tpr<-data.frame("cutoff"=portions)
stats_qval_fpr<-data.frame("cutoff"=portions)

stats_qval_tpr_ordT<-data.frame("cutoff"=portions)
stats_qval_fpr_ordT<-data.frame("cutoff"=portions)

roc.auc<-rep(0,repeats)
roc_ordT.auc<-rep(0,repeats)
for(i in c(1:repeats))
{

	cat("reading the ",i, "/", repeats," data sets.....\n")
	#load(paste(filename, i,"_rlm.RData",sep=""))
	load(paste(filename, i,".RData",sep=""))

	cat("count the correct ones.....\n");
	flush.console();
	#depending on which data,
	lstData<-get(object.load);#lstToSave
	eval(paste("rm(",object.load,")",sep=""))

	#try to know which one is nonZero as the true values
	gammaTrue<-lstData$data$gamma
	if(mode==1)
	{
		gammaTrueIndex<-which(gammaTrue[,2]!=0)
	} else
	{
		gammaTrueIndex<-which(gammaTrue[,2]!=0|gammaTrue[,1]!=0)
	}

	#now need to sort the p-value of the
	#and pick top n genes to be the significant ones as the analysis results
	#
	lr_coe<-lstData$lregCoef
	lr_coe_names<-rownames(lr_coe)
	lr_coe_gamma_index<-which(grepl("gene\\d*:group2",lr_coe_names)); #indices for interaction terms only
	lr_coe_int<-lr_coe[lr_coe_gamma_index,];#get entries for interaction terms
	lr_coe_int_names<-lr_coe_names[lr_coe_gamma_index];

	#sort the array according to the prob
	lr_coe_int_prob<-lr_coe_int[,"Pr(>|t|)"]
	#lr_coe_int_prob<-(1-pt(abs(lr_coe_int[,"t value"]),df=2000*2*5-4000))*2

	lr_coe_int_sort_order<-order(lr_coe_int_prob) #NOTE:the names is one more than its index, eg. 811 is gene812:group2
	#lr_coe_int_sort<-lr_coe_int[lr_coe_int_sort_order,]

	#lr_coe_int_prob_qvalue<-qvalue(lr_coe_int_prob[lr_coe_int_sort_order])$qvalue
	lr_coe_int_prob_qvalue<-tryCatch(
		qvalue(lr_coe_int_prob)$qvalue,   #(lr_coe_int_prob[lr_coe_int_sort_order])$qvalue,
		error=function(c){
		cat("******ERROR in calling \"qvalue\"\n")
		cat("\t",c$message,"\n")
		cat("calling p.adjust instead\n")
		lr_coe_int_prob_qvalue<- p.adjust(lr_coe_int_prob, method="BH")#(lr_coe_int_prob[lr_coe_int_sort_order], method="BH")
		},
		warning = function(c) c$message,
		message = function(c) c$message
	)

	roc_response<-rep(0, length(gammaTrue[,1]))
	roc_response[gammaTrueIndex]<-1

	roc_predict<-lr_coe_int_prob_qvalue #qvalue(lr_coe_int_prob)$qvalue
	roc.obj<-roc(roc_response[-1], roc_predict)
	roc.auc[i]<-roc.obj$auc

	#now we have everything, just need to collect statistics
	p_correct<-portions;#initialize the vector
	p_correct_byQ<-portions;#initialize the vector
	p_fpr_byQ<-portions;#initilize

	p_correct_byQ_ordT<-portions;#initialize the vector
	p_fpr_byQ_ordT<-portions;#initialize

	#now we are doing -->ordinary t tests<--
	#get the data first
	dtExp<-lstData$data$exp
	prob_ordT<-rep(0,length(dtExp[,1]))
	#run t.test
	for(nn in c(1:length(dtExp[,1])))
	{
		prob_ordT[nn]<-t.test(dtExp[nn,c(1:sampleSize)],dtExp[nn,c((1+sampleSize):(sampleSize+sampleSize))])$p.value
	}
	prob_ordT_Q<-	tryCatch(
		qvalue(prob_ordT)$qvalue,
		error=function(c){
		cat("******ERROR in calling \"qvalue\"\n")
		cat("\t",c$message,"\n")
		cat("calling p.adjust instead\n")
		prob_ordT_Q<- p.adjust(prob_ordT, method="BH")
		},
		warning = function(c) c$message,
		message = function(c) c$message
	)
	roc_ordT<-roc(roc_response, prob_ordT_Q)

	roc_ordT.auc[i]<-roc_ordT$auc
	j<-1
	for(j in c(1:length(portions)))
	{
		if(mode==1)
			factors<-1
		else
			factors<-2
		#for each portion, we need to check what is percentage to be correct
		numToPick<-floor(lstData$data$params[1]*portions[j]*factors)
		#picking from the order array
		genesToPick_byProb<-lr_coe_int_sort_order[c(1:numToPick)]+1 #see NOTE above, index is one more less than the name
		#now we got the genes, just need to check whether the genes so far are the TRUE ones
		numOfCorrect<-sum(is.element(genesToPick_byProb, gammaTrueIndex));
		p_correct[j]<-numOfCorrect/numToPick

		#now doing the q value, using the portion as the qvalue cutoff
		numToPick_byQ<-floor(portions[j]*lstData$data$params[1]*factors);#sum(lr_coe_int_prob_qvalue<=portions[j])
		lr_coe_int_Q_sort_order<-order(lr_coe_int_prob_qvalue)
		genesToPick_byQ<-lr_coe_int_Q_sort_order[c(1:numToPick_byQ)]+1
		#now we got the genes, just need to check whether the genes so far are the TRUE ones
		numOfCorrect_byQ<-sum(is.element(genesToPick_byQ, gammaTrueIndex));
		p_correct_byQ[j]<-numOfCorrect_byQ/floor(lstData$data$params[1]*lstData$data$params[3]*factors)
		p_fpr_byQ[j]<-(length(genesToPick_byQ)-numOfCorrect_byQ)/floor(lstData$data$params[1]*(1-lstData$data$params[3]*factors))

		#now doing ordinary T tests<--------
		numToPick_byQ_ordT<-numToPick_byQ;#sum(prob_ordT_Q<=portions[j])
		prob_ordT_Q_sort<-order(prob_ordT_Q)
		geneToPick_byQ_OrdT<-prob_ordT_Q_sort[c(1:numToPick_byQ_ordT)]#this is different, there is +1 here!!!!!!!
		numOfCorrect_byQ_ordT<-sum(is.element(geneToPick_byQ_OrdT, gammaTrueIndex));

		p_correct_byQ_ordT[j]<-numOfCorrect_byQ_ordT/floor(lstData$data$params[1]*lstData$data$params[3]*factors)
		p_fpr_byQ_ordT[j]<-(length(geneToPick_byQ_OrdT)-numOfCorrect_byQ_ordT)/floor(lstData$data$params[1]*(1-lstData$data$params[3]*factors))
	}
	stats_df[,paste("repeat_",i, sep="")]<-p_correct;
	stats_qval_tpr[,paste("repeat_",i,sep="")]<-p_correct_byQ;
	stats_qval_fpr[,paste("repeat_",i,sep="")]<-p_fpr_byQ;

	stats_qval_tpr_ordT[,paste("repeat_",i,sep="")]<-p_correct_byQ_ordT;
	stats_qval_fpr_ordT[,paste("repeat_",i,sep="")]<-p_fpr_byQ_ordT;
	cat("done!\n")
}
cat("start doing the plotting and reporting...\n")
flush.console();
#statistics with the stats_df array
mean_correct<-portions
max_correct<-portions
min_correct<-portions
std_correct<-portions
m_stats_df<-as.matrix(stats_df)
for(k in c(1:length(portions)))
{
	mean_correct[k]<-mean(m_stats_df[k,c(-1)])
	max_correct[k]<-max(m_stats_df[k,c(-1)])
	min_correct[k]<-min(m_stats_df[k,c(-1)])
	std_correct[k]<-sqrt(var(m_stats_df[k,c(-1)]))
}

stats_df[,"mean"]<-mean_correct
stats_df[,"min"]<-min_correct
stats_df[,"max"]<-max_correct
stats_df[,"std"]<-std_correct
#op<-par(mfrow=c(2,1),
#	pty="s" #"s" for square, "m" for maximal plot area
#	)
plot(c(0.001,0.51),c(0.02, 1.1), type="n", main="true discovery rate for protein selection",
	xlab="portion of protein selected", ylab="portion of true discovery", log="x")
lines(stats_df[,1], stats_df[,"mean"], col=1, lty=1, lwd=2)
lines(stats_df[,1], stats_df[,"min"], col="grey", lty=2, lwd=1)
lines(stats_df[,1], stats_df[,"max"], col="grey", lty=2, lwd=1)
lines(c(prob.nonZero, prob.nonZero), c(0,1.2), col=2, lty=3)

#show stats
stats_df[c(1:30),c("portions", "mean", "min", "max", "std")]
############adding code to do FDR

#statistics with the roc array
mean_tpr<-portions
mean_fpr<-portions
for(k in c(1:length(portions)))
{
	mean_tpr[k]<-median(as.matrix(stats_qval_tpr[k,c(-1)]))
	mean_fpr[k]<-median(as.matrix(stats_qval_fpr[k,c(-1)]))
}

plot(c(0,1), c(0,1),type="n", main="C: No Control", ylab="True Positive Rate", xlab="False Positive Rate")
#for(ii in c(1:repeats))
#{
#	lines( stats_qval_fpr[,ii+1],stats_qval_tpr[,ii+1],col="red", lty="dotted")
#}
lines(mean_fpr,mean_tpr, col="red",lty=1,lwd=2)
#legend(0.7,0.2,c("mean ROC"),col=c("red"), lty=c(2),lwd=c(2))
#text(0.7,0.3,labels=paste("AUC:",mean(roc.auc)))

#statistics with the roc array for ---->ordT
mean_tpr_ordT<-portions
mean_fpr_ordT<-portions
for(k in c(1:length(portions)))
{
	mean_tpr_ordT[k]<-median(as.matrix(stats_qval_tpr_ordT[k,c(-1)]))
	mean_fpr_ordT[k]<-median(as.matrix(stats_qval_fpr_ordT[k,c(-1)]))
}

#plot(c(0,1), c(0,1),type="n", main="ROC", ylab="True Positive Rate", xlab="False Positive Rate")
#for(ii in c(1:repeats))
#{
#	lines( stats_qval_fpr_ordT[,ii+1],stats_qval_tpr_ordT[,ii+1],col="light green", lty="dotted")
#}
lines(mean_fpr_ordT,mean_tpr_ordT, col="green",lty=1,lwd=2)
legend(0.7,0.2,c("model", "ordinary t"),col=c("red", "green"), lty=c(2, 2),lwd=c(2,2))
text(0.7,0.25,labels=paste("AUC ordinary t:",mean(roc_ordT.auc)))
text(0.7,0.35,labels=paste("AUC model:",mean(roc.auc)))
#par(op);

####starting here, prepare the output

	retDataList<-list("roc.auc.model"=roc.auc,"roc.auc.t"=roc_ordT.auc,
				"qvalule.tpr.model"=stats_qval_tpr, "qvalule.fpr.model"=stats_qval_fpr,
				"qvalule.tpr.t"=stats_qval_tpr_ordT, "qvalule.fpr.t"=stats_qval_fpr_ordT,
				"fdr"=stats_df
				#, "param.alpha"=lstData$data$alpha,"param.beta"=lstData$data$beta,
				#"param.gamma"=lstData$data$gamma,
				);
	return(retDataList)
}#end of function


nb=function(y=1930) {
    debut=1816
    MatDFemale=matrix(D$Female,nrow=111)
    colnames(MatDFemale)=debut+0:198
    cly=(y-debut+1):111
    deces=diag(MatDFemale[:,cly[cly%in%1:199]])
    return(c(B$Female[B$Year==y],deces))
}


library(lpSolve)
library(irr)
library(dplyr)
library(tidyr)

options(stringsAsFactors = FALSE)

getResult <- function(name) {
  con <- gzcon(url(paste("https://pyt.blob.core.windows.net/data/results/v2/latest/", name, ".csv.gz", sep="")))
  txt <- readLines(con)
  return(read.csv(textConnection(txt), header=TRUE, quote="\""))
}

# helpfull articles
# simple explanation http://neoacademic.com/2011/11/16/computing-intraclass-correlations-icc-as-estimates-of-interrater-reliability-in-spss/
# specific to irr https://www.r-bloggers.com/k-is-for-cohens-kappa/
# another irr one.maybe cappa is better http://www.cookbook-r.com/Statistical_analysis/Inter-rater_reliability/

results = data.frame(tag=character(), subjects=integer(), raters=integer(),
                     kap=numeric(), kap_p=numeric(),
                      icc=numeric(), icc_p=numeric(), icc_lbound=numeric(),icc_ubound=numeric(),
                        agreement=numeric())

addResult <- function(name, ratings) {
  agree = agree(ratings)
  kap = kappam.fleiss(ratings)
  icc = icc(ratings, model="twoway", type="agreement")
  df = data.frame(name=name, subjects=kap$subjects, raters=kap$raters,
                  kap = kap$value, kap_p = kap$p.value,
                  icc = icc$value, icc_p = icc$p.value, icc_lbound=icc$lbound, icc_ubound=icc$ubound,
                  agreement = agree$value)
  rbind(results, df)
}

#
# lr ICC
#

lr = getResult("icc_lr")

reviwers = c("Ac", "os", "zY") #  filter out reviewers with only a handfull of classifications
lrCodes = c( "L" = -1, "C" = 0, "R" = 1)

lrRatings = lr %>%
  filter(REVIEWER %in% reviwers) %>%
  mutate(REVIEWER_LR = lrCodes[REVIEWER_LR]) %>%
  spread(REVIEWER, REVIEWER_LR, sep="_") %>%
  select(starts_with("REVIEWER"))

results = addResult("Left/Center/Right", lrRatings)

#
# tag ICC
#
tag = getResult("icc_tags")
uniqueTags = unique(tag$TAG)

for(t in uniqueTags) {
  tagRatings = tag %>%
    filter(REVIEWER %in% reviwers & TAG == t) %>%
    mutate(REVIEWER_HAS_TAG = as.logical(REVIEWER_HAS_TAG)) %>%
    spread(REVIEWER, REVIEWER_HAS_TAG, sep="_") %>%
    select(starts_with("REVIEWER"))

  results = addResult(t, tagRatings)
}

print(results)

write.csv(results, "reviewer_reliability.csv", row.names = FALSE, sep = ",")


source("make_precip_inputs.r")

"
MADD  = Mean Annual Dry Days
MADDM = Mean Annual Dry Days of the Driest Month
MADM  = Mean Annual Prciep of Dryiest Month
MConc = Mean Annual Seasonal Concentration
"
extent = c(-180, 180, -30, 30)

data_dir  = "../LimFIRE/outputs/"
variables = c("TreeCover" = "treecover2000-2014.nc",
              "nonTreeCover" = "nontree2000-2014.nc",
              "MaxWind" = "../../savanna_fire_feedback_test/data/CRUNCEP.wspeed.r0d5.1997.2013.nc",
              "MAT" = "Tas2000-2014.nc",
              "MTWM" = "../data/cru_ts4.03/cru_ts4.03.1901.2018.tmx.dat.nc",
              "MTCM" = "../data/cru_ts4.03/cru_ts4.03.1901.2018.tmn.dat.nc",
	      "SW" = "cld2000-2014.nc",
              "BurntArea_GFED_four_s" = "fire2000-2014.nc",
              "BurntArea_GFED_four" = "../../fireMIPbenchmarking/data/benchmarkData/GFED4.nc",
              "BurntArea_meris" = "../../fireMIPbenchmarking/data/benchmarkData/meris_v2.nc",
              "BurntArea_MODIS" = "../../fireMIPbenchmarking/data/benchmarkData/MODIS250_q_BA_regridded0.5.nc",
              "BurntArea_MCD_forty_five" = "../../fireMIPbenchmarking/data/benchmarkData/MCD45.nc",
	      "urban" = "urban_area2000-2014.nc", "crop" = "cropland2000-2014.nc",
              "pas" = "pasture2000-2014.nc",
	      "PopDen" = "population_density2000-2014.nc",
	      "MAP_CRU" = "Prc2000-2014.nc",
              "MADD_CRU" = "Wet2000-2014.nc", "MDDM_CRU" = "Wet2000-2014.nc",
	      "MADM_CRU" = "Prc2000-2014.nc", "MConc_CRU" = "Prc2000-2014.nc",
              "buffalo" = "../../savanna_fire_feedback_test/data/livestock/buffaloLivestock0.5.nc",
              "cattle" = "../../savanna_fire_feedback_test/data/livestock/cattleLivestock0.5.nc",
              "goat" = "../../savanna_fire_feedback_test/data/livestock/goatLivestock0.5.nc",
              "sheep" = "../../savanna_fire_feedback_test/data/livestock/sheepLivestock0.5.nc")

annualAverage <- function(...) mean(...)

annualAverage12 <- function(...) 12 * annualAverage(...)

annualAverageMax <- function(r, ...) {
	nyr = nlayers(r)/12
	annualMax <- function(yr) {
		mn = ((yr-1)*12 + 1):(yr*12)
		return(max(r[[mn]]))
	}

	ra = layer.apply(1:nyr, annualMax)
	return(mean(ra))
}

temp_max <- function(r, ...)
   annualAverageMax(r[[1195:1362]])

temp_min <- function(r, ...)
    annualAverageMax(r[[1195:1362]]*(-1))*(-1)

AllMax <- function(r, ...) r = max(r)

sunshineHours <- function(r, Q00 = 1360, ...) {
	midDay = 2 * pi * seq(15, 345, 30)/360
	Q0 = Q00 * (1 + 2 * 0.01675 * cos(midDay))

	lat = r[[1]]
	lat[] = yFromCell(lat, 1:length(lat))
	lat = 2 * lat * pi / 360

	delta = -23.4 * cos(midDay + pi * 2 * 10/360) * 2 * pi / 360

	cz = layer.apply(sin(delta) , function(i) i * sin(lat)) + layer.apply(cos(delta) , function(i) i * cos(lat))/pi
	cz[cz < 0] = 0
	cz = cz * Q0

        r = r / 100
	SW2 = mean(cz * r) # defuse
	SW1 = mean(cz * (1 - r)) # direct
	return(list(SW1, SW2))
}

MADD <- function(r, ...) {
	#out = PolarConcentrationAndPhase(r)[[2]]
	out = annualAverageMax(r*(-1))
	out = 1-(out * (-1)/mean(r))

	names(out) = "layer"
	return(out)
}

MDDM = function(r, ...) {
	out =  1 + annualAverageMax(r * (-1))
	return(out)
}

MADM = function(r, ...) {
	out = annualAverageMax(r * (-1))
	out = (out/annualAverage(r)) + 1
	return(out)
}

MConc = function(r, ...) {
	print("MConc")
	out = PolarConcentrationAndPhase(r)[[2]]
	return(out)
}

makeWind <- function(r, ...)
    max(r[[55:198]])

layer1GT0 <- function(r, ...) {
    r = r[[1]]
    r[r<0] = 0.0
    return(r)
}

FUNS = c("TreeCover" = annualAverage, "nonTreeCover" = annualAverage,
         "MaxWind" = makeWind,
         "MAT" = annualAverage,
         "MTWM" = temp_max,
         "MTCM" = temp_min,
	 "sunshine" = sunshineHours,
         "BurntArea_GFED_four_s" = annualAverage12,
         "BurntArea_GFED_four"  = annualAverage12,
         "BurntArea_meris"  = annualAverage12,
         "BurntArea_MODIS"  = annualAverage12,
         "BurntArea_MCD_forty_five"  = annualAverage12,
	 "urban" = annualAverage, "crop" = annualAverage, "pas" = annualAverage,
         "PopDen" = annualAverage,
	 "MAP_CRU" = annualAverage12, "MADD_CRU" = MADD, "MDDM_CRU" = MDDM,
	 "MADM_CRU" = MADM, "MConc_CRU" = MConc,
         "buffalo" = layer1GT0, "goat" = layer1GT0, "cattle" = layer1GT0, "sheep" = layer1GT0)

scaling = c("TreeCover" = 1, "nonTreeCover" = 1, "MaxWind" = 1, "MAT" = 1, "MTWM" = 1,
            "MTCM" = 1,
	    "sunshine" = 1,
            "BurntArea_GFED_four_s" = 1,
            "BurntArea_GFED_four"  = 1,
            "BurntArea_meris"  = 1,
            "BurntArea_MODIS"  = 1,
            "BurntArea_MCD_forty_five"  = 1,
	    "urban" = 1, "crop" = 1, "pas" = 1, "PopDen" = 1,
	    "MAP_CRU" = 1, "MADD_CRU" = 1, "MDDM_CRU" = 1,
	    "MADM_CRU" = 1, "MConc_CRU" = 1,
            "buffalo" = 1, "goat" = 1, "cattle" = 1, "sheep" = 1)

MinPoint = c("TreeCover" = 0, "nonTreeCover" = 0, "MaxWind" = 0, "MAT" = 0, "MTWM" = 0,
             "MTCM" = 0,
	     "sunshine" = 0,
             "BurntArea_GFED_four_s" = 0,
             "BurntArea_GFED_four"  = 0,
             "BurntArea_meris"  = 0,
             "BurntArea_MODIS"  = 0,
             "BurntArea_MCD_forty_five"  = 0,
	     "urban" = 0, "crop" = 0, "pas" = 0, "PopDen" = 0,
	     "MAP_CRU" = 0, "MADD_CRU" = 1, "MDDM_CRU" = 1,
	     "MADM_CRU" = 1, "MConc_CRU" = 1,
             "buffalo" = 0, "goat" = 0, "cattle" = 0, "sheep" = 0)

makeVar <- function(filename, FUN) {
	print(filename)
	r = brick(paste(data_dir, filename, sep = '/'))
	r = FUN(r)
	return(r)
}

ins = mapply(makeVar, variables, FUNS)

ins_all = c(unlist(ins))#, unlist(pr_ins))

mask = is.na(ins_all[[1]][[1]])

for (i in ins_all[-1]) {
    i0 = i
    mask = raster::crop(mask, i)
    i = raster::crop(i, mask)
    i = raster::resample(i, mask)
    mask = mask + is.na(i)
}
mask = mask > 3

n96_mask = raster('../UKESM-ConFire/data/n96e_orca1_mask.nc')
writeVar <- function(nme, r, sc, mp = 0.0) {

	writeSub <- function(nmei, ri) {
                ri = raster::crop(ri, mask)
                ri = raster::resample(ri, mask)
		ri[mask] = NaN
		ri[!mask & is.na(ri)] = mp
		names(ri) = NULL
		fname = paste('data/driving_Data/', nmei, '.nc', sep = '')
		print(fname)
		ri =  crop(ri, extent(extent))
		ri = ri * sc

		ri = writeRaster.gitInfo(ri, fname, varname = "layer",
                                         comment = list(src_file = 'make_inputs.r'),
                                         overwrite = TRUE)

                rr = convert_regular_2_pacific_centric(ri)
                rr = raster::resample(rr, n96_mask)

		fnamer = paste('data/driving_Data/N96/', nmei, '.nc', sep = '')

                rr = writeRaster.gitInfo(rr, fnamer, varname = nme,
                                         comment = list(src_file = 'make_inputs.r'),
                                         overwrite = TRUE)
		return(ri)
	}
	if (is.raster(r)) r = writeSub(nme, r)
	else {
		nme = paste(nme, 1:length(r), sep = '')
		r = mapply(writeSub, nme, r)
	}
	return(r)
}

mapply(writeVar, names(variables), ins, scaling, MinPoint)

maskAndReout_pr <- function(r) {
    fname = filename(r)
    r = raster::crop(r, mask)
    r[mask] = NaN
    r = writeRaster.gitInfo(r, fname, zname = 'layer',
                            comment = list(source='Based on data the amazing Li G processed for me. Regridded for 0.25 to 0.5',
                                           src_file = 'make_inputs.r'),
                            overwrite = TRUE)
    return(r)
}

lapply(unlist(pr_ins), maskAndReout_pr)


#  James Rekow

aggDensityComparativeMultiplot = function(aggDOCDF, densLim = 20){

  #  ARGS: aggDOCDF - an aggregate data frame containing DOC points from multiple replicates labeled
  #                   by replicate number and the number of interacting samples corresponding to each
  #                   point
  #        densLim - maximimum density displayed in the output density multiplot. Regions where the density
  #                  exceeds the maximum are displayed in grey
  #
  #  RETURNS: a plot of six 2D DOC density plots arranged into two columns and three rows. Each row
  #           corresponds to a distinct replicate (for 3 total replicates). The left column plots 2D
  #           densities of DOC points corresponding to 0 interacting samples, and the right column
  #           plots 2D densities of DOC points corresponding to 2 interacting samples

  library(ggplot2)
  library(gridExtra)
  library(grid)
  source("DOCDensity_2d.r")

  #  create vector with all replicate IDs present in the aggregate data frame
  replicateIDs = unique(aggDOCDF$replicateID)

  #  randomly select the replicate IDs of the three replicates used in the density multiplot
  displayedReplicateIDs = sample(replicateIDs, 3)

  #  select only DOC points corresponding to 0 or 2 interacting samples, respectively
  aggDOCDF_IC0 = aggDOCDF[aggDOCDF$intCount == 0, ]
  aggDOCDF_IC2 = aggDOCDF[aggDOCDF$intCount == 2, ]

  replicateDensity = function(n){

    #  ARGS: n - replicate ID
    #
    #  RETURNS: replicateDensList - list of two ggplot objects of 2D DOC density plots. The first element
    #           in the list, repDensGrob_IC0, is the density plot for DOC points from replicate n
    #           corresponding to 0 interacting samples. The second element, repDensGrob_IC2, is the
    #           density plot for DOC points from replicate n corresponding to 2 interacting samples

    #  select DOC points from replicate n
    replicateDOCDF_IC0 = subset(aggDOCDF_IC0, replicateID == n, select = c("over", "diss"))
    replicateDOCDF_IC2 = subset(aggDOCDF_IC2, replicateID == n, select = c("over", "diss"))

    #  create the ggplot objects corresponding to the 2D DOC density plots for the points from replicate n
    #  with 0 and 2 interacting samples, respectively
    repDensGrob_IC0 = DOCDensity_2d(doc = replicateDOCDF_IC0, densLim = densLim)
    repDensGrob_IC2 = DOCDensity_2d(doc = replicateDOCDF_IC2, densLim = densLim)

    #  create a list to store the two ggplot objects
    replicateDensList = list(repDensGrob_IC0, repDensGrob_IC2)

    return(replicateDensList)

  } #  end replicateDensity function

  #  create a replicate density list for each of the three displayed replicates
  densGrobList = lapply(as.list(displayedReplicateIDs), replicateDensity)

  #  put all 6 ggplot objects in a single list
  densGrobList = unlist(densGrobList, recursive = FALSE)

  #  create title object for the multiplot (must manually change this to include correct M, lambda values)
  titleText = textGrob("DOC Densities of 3 Replicates, M = 400, 1 - exp(-lambda/M) = 0.5")

  #  arrange and plot all 6 density plots in a new graphics device
  dev.new()
  grid.arrange(arrangeGrob(densGrobList[[1]], densGrobList[[3]], densGrobList[[5]],
                           top = "0 Interacting Samples"),
              arrangeGrob(densGrobList[[2]], densGrobList[[4]], densGrobList[[6]],
                          top = "2 Interacting Samples"), ncol = 2, top = titleText)

} #  end aggDensityComparativeMultiplot function


library(ggplot2)

table <- read.table("stacked.data", header = TRUE, sep = "", quote = "\"")
counts <- table(table$Status, table$Engine)

vector <- c(counts["2-Confirmed","Chakra"],
            counts["2-Confirmed","JSC"],
            counts["2-Confirmed","V8"],
            counts["2-Confirmed","Hermes"],
            counts["2-Confirmed","SpiderMonkey"],
            counts["3-Fixed","Chakra"],
            counts["3-Fixed","JSC"],
            counts["3-Fixed","V8"],
            counts["3-Fixed","Hermes"],
            counts["3-Fixed","SpiderMonkey"],
            counts["1-New","Chakra"],
            counts["1-New","JSC"],
            counts["1-New","V8"],
            counts["1-New","Hermes"],
            counts["1-New","SpiderMonkey"])

df <- data.frame(status=rep(c("2-Confirmed", "3-Fixed", "1-New"), each=5),
                 engine=rep(c("Chakra", "JSC", "V8", "Hermes", "SpiderMonkey"), each=1),
                 number=vector)

ggplot(data=df, aes(x=engine, y=number, fill=status)) +
  geom_bar(stat="identity")  +
  scale_fill_grey(start = 0, end = .9) +
  theme_bw() +
  theme(axis.text=element_text(size=14), axis.title.x=element_blank(), axis.title.y=element_blank(), legend.text=element_text(size=14), aspect.ratio=0.3, panel.border = element_blank())


#  Edge_Simulate_Visualize
#  A simple program to generate 50-1000 Edge Nodes, so we can
#  (a) Create some 'medium' simulation data (b) play with Visualization Methods (c) Start to get a feel for policy Driven State

library(ggplot2) # for the viz
library(wesanderson)  # for GGPLOT colors  # # Install # install.packages("wesanderson") # for GGPLOT colors
library(treemapify) # for tree map example way down below

library(kohonen) # old but good. Self organizing maps
library(SOMbrero)  # first time I've tried this package - looks pretty cool

## 1 START WITH MATRIX BONES - node_count number of rows
node_count <- 1001# later, this will be a user input , for "size of test set to gen"

nodes_df <- as.data.frame(matrix(1:node_count, nrow = node_count, ncol = 13))# let's get started
colnames(nodes_df) <- c("index","type","name","size","servers","cpus","cores","range_x","range_y","magnitude","angle","capacity_utilization","policy_noncompliant") # name columns

head(nodes_df,10) # what do we have?  show first 10 rows

## 2 LET'S GROUP the set into N Groups (1=SMALL (e.g. Raspi); 2=Medium (e.g. Edge Gateway), (3) = Large Edge Device (e.g. ICP on Prem))
# See: https://wiki.akraino.org/pages/viewpage.action?pageId=1147248 for model outlining Cruiser, Rover, Tricycle concept
# CAVEAT - THIS iS FOR DISCUSSION ONLY - handle with care!
node_type_lookup <- data.frame("type" = 1:5,
                               "name" = c("rover","satellite", "unicycle", "tricycle", "cruiser"),
                               "size" = c(1,5,50,100,1000),
                               "servers" = c(0,2,42,126,252), ## Approx. SME needs to REVIEW THIS (!)
                               "cpus" = c(1,2,200,800,1600), ## Approx. SME needs to REVIEW THIS (!)
                               "cores" = c(0,16,1600,6400,10000), ## Approx. SME needs to REVIEW THIS (!)
                               "pct_allocation" = c(0.944,0.04,0.01,0.005,0.001), # later; make more configurable
                               "count" = c(0,0,0,0,0) # will calculate this later
                               )
# " Can we relate to processors and architecture? Like rover = Armv6, Armv7hf, Arm Cortex 4, up to four cores. Next class up = Atom, next class = Xeon-class x86_64, and so on?"

# check our Allocation % add up to 100%
sum(node_type_lookup$pct_allocation)
if (sum(node_type_lookup$pct_allocation)==1){print("pct_allocation = OK - sums to 1 ")} else {print("pct_allocation Check = BAD - node sums dont line up")}

# calculate number of whole number nodes in each TYPE category given user input
node_type_lookup$count <- round(node_type_lookup$pct_allocation * node_count)
node_type_lookup
sum(node_type_lookup$count)
node_count
node_count == sum(node_type_lookup$count) # True if we've done work well here (and rounded well)

# different ways to count types in table (5 here)
dim(node_type_lookup)[1] # how many types /rows
nrow(node_type_lookup) # also 5

## BIG MOMENT OF TYPE ASSIGMENT  - DID this with loop in case you have lots of types (you can hand code this sectio nif hless than 10)
index_prior = 1
index_new = 1
for (i in 1:nrow(node_type_lookup)){
  print("---")
  print(i)
  index_new <- (node_type_lookup$count[i]+index_prior) # add our new range to old range

  ## DO THE ALLOCATION - BIG MOMENT
  print(index_prior)
  print(index_new-1)
  nodes_df$type[index_prior:(index_new-1)] <- node_type_lookup$type[i] # SETS THE TYPE
  nodes_df$name[index_prior:(index_new-1)] <- paste(node_type_lookup$name[i]) # SETS THE NAME

  nodes_df$size[index_prior:(index_new-1)] <- paste(node_type_lookup$size[i]) # SETS THE SIZE
  nodes_df$servers[index_prior:(index_new-1)] <- paste(node_type_lookup$servers[i]) # SETS THE SERVERS
  nodes_df$cpus[index_prior:(index_new-1)] <- paste(node_type_lookup$cpus[i]) # SETS THE CPU (LATER MAY BE VARIETY HERE)
  nodes_df$cores[index_prior:(index_new-1)] <- paste(node_type_lookup$cores[i]) # SETS THE CORES (LATER MAY BE VARIETY HERE)

  ## Set up for next time
  index_prior <- index_new # set up for next loop
}

## CHECK
node_table <- table(nodes_df$type) # check this worked like you expect
node_table
sum(table(nodes_df$type))
sum(table(nodes_df$type)) == node_count # hopefully true - if you did this right
table(nodes_df$name) # check this worked like you expect
plot(sort(table(nodes_df$name),decreasing=TRUE))

## PRIME Number fucntion - purely to allocate "Red" state (Non Compiance)
is.prime <- function(num) {
  if (num == 2) {TRUE} else if (any(num %% 2:(num-1) == 0)) {FALSE}
  else {TRUE}}
## test - is.prime(8)

###

## 4 LOCATION - SEMI RANDOM - ZONING FOR VIZ CORE = BIG, Cruiser - EDGES = Rovers
head(nodes_df,20) # check first 20
tail(nodes_df,20) # check last 20

## let's get stared with some plus and minus coordinate data (scale by type later)
nodes_df$range_x <- sample(-100:100,node_count,replace=TRUE)
nodes_df$range_y <- sample(-100:100,node_count,replace=TRUE)

head(nodes_df,20) # check first 20
tail(nodes_df,20) # check last 20

#nodes_df$range_x <- nodes_df$range_x*1000/nodes_df$size

# SCALE RANGE TO EDGE - there's a more elegant way to do this in R - so improve later ()
# for (i in 1:node_count)
#   {
#   nodes_df$range_x[i] <- nodes_df$range_x[i]*100/as.numeric(nodes_df$size[i])
#   nodes_df$range_y[i] <- nodes_df$range_y[i]*100/as.numeric(nodes_df$size[i])
# } # this centralizes the big stuff

# rnorm(1, mean=10, sd=1)/10    # provide our own mean and standard deviation

# ANGLES For Polar coordinates  - not sure we need this (may remove later if not used)
nodes_df$angle <- sample(0:359,node_count,replace=TRUE)

nodes_df$capacity_utilization <- sample(0:100,node_count,replace=TRUE)

# Magnutude seeds for polar coords (like the length of the Minutes hand in clock)
nodes_df$magnitude <- sample(50:100,node_count,replace=TRUE)

# TRY ANOTHER METHOD FOR DONUT POINT CLOUD GENERATE
for (i in 1:node_count)
{
  nodes_df$magnitude[i] <- nodes_df$magnitude[i]/as.numeric(nodes_df$type[i]) # divide them down by 'bands'
  nodes_df$range_x[i] <- round(nodes_df$magnitude[i] * sin(pi*nodes_df$angle[i]/180)/as.numeric(nodes_df$type[i]))
  nodes_df$range_y[i] <- round(nodes_df$magnitude[i] * cos(pi*nodes_df$angle[i]/180)/as.numeric(nodes_df$type[i]))

  #for some color - let's tag all PRIME Number magnitudes as non-compliant (Paint Red)
  nodes_df$policy_noncompliant[i] <- is.prime(nodes_df$index[i])
} #

## PLOT   - Light BLUES are problems (works)
ggplot(nodes_df, aes(x=range_x, y=range_y, size=type, color=policy_noncompliant)) + geom_point()

# Shades of Life Aquatic (works but hard to read)
pal <- wes_palette("Zissou1", 100, type = "continuous")
# Add some color
ggplot(nodes_df, aes(x = range_x, y = range_y , size=type, fill = type)) +
  geom_tile() +
  scale_fill_gradientn(colours = pal) +
  coord_equal()

# Add some color
ggplot(nodes_df, aes(x = range_x, y = range_y , size=type, fill = policy_noncompliant)) +
  geom_tile() +
  scale_fill_gradientn(colours = pal) +
  coord_equal()

# works (by size)
ggplot2::ggplot(nodes_df, ggplot2::aes(area = type, fill = size)) +
  geom_treemap()

# works (by policy_noncompliant)
sp <- ggplot2::ggplot(nodes_df,
                ggplot2::aes(area = type,
                fill = policy_noncompliant))+
                geom_treemap()
sp

# works (by CPU)
ggplot2::ggplot(nodes_df, ggplot2::aes(area = type, size = cpus, fill = cpus)) +
  geom_treemap()

# works - by LFEdge/Akraino Label
ggplot2::ggplot(nodes_df, ggplot2::aes(area = type, size = type, fill = name )) +
  geom_treemap()

# works - by LFEdge/Akraino Label  (sort of works - but labels EVERY box, so zone lable better if we can figure out)
# ggplot2::ggplot(nodes_df, ggplot2::aes(area = type, size = type, fill = name, label = name)) +
#   geom_treemap() +
#   geom_treemap_text()

#########  KOHONEN
namelist <- data.frame(names(nodes_df))
namelist  # in case you want to see which numbers map (for selection)
### OK - for now, use this line below to CHERRY PICK your TRAITS/VALUES for explirng
data <- nodes_df[c(2,4,5,6,7,12,13)] # the countable and sortable stuff
names(data) # OK - here is what we selected (from the 52 traits/values)

head(data)
data <- data.matrix(data)

## what do we have?
head(data)
data.sc <- scale(data)
head(data.sc)

set.seed(7)
data.som <- som(data.sc, grid = somgrid(10, 8, "hexagonal"))

# add rows / node count to TITLE
title_cluster = paste("\n System Summary \n", nrow(data), "ICP/Edge Nodes Clustered")
title_count = paste("\n System Summary \n", nrow(data), "ICP/Edge Nodes COUNT")

## Fancy Colors
coolBlueHotRed <- function(n, alpha = 1) { rainbow(n, end=4/6, alpha=alpha)[n:1] } ## palette for nicer color scheme

## Let's Plot
plot(data.som, main = title_cluster, palette.name =  coolBlueHotRed)
plot(data.som, main = title_count, type = "counts", palette.name = coolBlueHotRed, heatkey = TRUE)
plot(data.som, type = "mapping", pchs = 20, main = "Mapping Type SOM")

# Good documentation here https://clarkdatalabs.github.io/soms/SOM_NBA

## GOOD TO HERE
sommap <- som(scale(data), grid = somgrid(6, 4, "hexagonal"))
plot(data.som, type = "mapping", property = getCodes(sommap, 1)[,1],
     main = colnames(getCodes(sommap, 1))[1])

plot(kohmap, type="codes", main = c("Codes X", "Codes Y"))
add.cluster.boundaries(sommap, som.hc)

##
# temp <- as.factor(nodes_df$name) # where vintages used to go
# kohmap <- xyf(scale(data), temp,
#               grid = somgrid(10, 10, "hexagonal"), rlen=100)
# plot(kohmap, type="changes")
# counts <- plot(kohmap, type="counts", shape = "straight")
# add.cluster.boundaries(sommap, som.hc)

## show both sets of codebook vectors in the map
#par(mfrow = c(1,2))

## add background colors to units according to their predicted class labels
xyfpredictions <- classmat2classvec(getCodes(kohmap, 2))
bgcols <- c("gray", "pink", "lightgreen")
plot(kohmap, type="mapping",
     col = as.integer(temp),
     pchs = as.integer(temp),
     bgcol = bgcols[as.integer(xyfpredictions)],
     main = "another mapping plot", shape = "straight", border = NA)

bgcols <- c("gray", "pink", "lightgreen")
plot(data.som, type="mapping",
     col = as.integer(temp),
     pchs = as.integer(temp),
     bgcol = bgcols[as.integer(xyfpredictions)],
     main = "another mapping plot", shape = "straight", border = NA)

##
name_lfedge <- as.factor(nodes_df$name) # where vintages used to go
plot(data.som,
     type = "mapping",
     pchs = as.integer(name_lfedge),
     col = as.integer(name_lfedge),
     main = "Mapping Type SOM",
     bgcols <- c("gray", "pink", "lightgreen"),
     palette.name = coolBlueHotRed,
     heatkey = TRUE)

## FRESH TRY
data.som <- som(data.sc, grid = somgrid(10, 8, "hexagonal"))
plot(data.som,
     main = title_cluster,
     # type = "mapping",
     pchs = as.integer(name_lfedge),
     col = as.integer(name_lfedge),
     palette.name = coolBlueHotRed,
     heatkey = TRUE)


suppressPackageStartupMessages(library(edgeR))
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(tibble))
suppressPackageStartupMessages(library(sva))

source("/mnt/webrepo/fr-s-bsg-onc-d/htdocs/clinomics/app/scripts/ComBat_seq.R")

makeMatrix <- function(x){
  #print(paste(x))
  #count_table <- read.csv(paste(x, sep=""), sep="\t", header=FALSE, stringsAsFactors = FALSE)
  #data <- read.table(x, head=T, sep="\t")
  data <- as.data.frame(data.table::fread(x, sep="\t", header = TRUE))
  colnames(data) <- c(gsub("\\.rsem.*.", "", basename(x)))
  return(data)
}

fpkmToTpm <- function(fpkm){
    exp(log(fpkm) - log(sum(fpkm)) + log(1e6))
  }

normalize <- function(countObj, workdir="", annotName = "", method="", fileName="", annotationRDS="", Refcol =1, priorCount=0, merge=T, saveFiles=F,
                        condition="",batch=NULL, group=NULL){

    Annotation <- data.frame(readRDS(annotationRDS))

    #drop       <- which( apply(countObj,1,sum) <= 1); print(paste("Droping ", length(drop))) ; countObj <- countObj[-drop,]
    #Annotation <- Annotation[-drop,]

    if(priorCount == 0) { tolog = FALSE}  else{ tolog = TRUE }

    ########################################### Choose the Annotation
    #print(paste("Chooseing the Annotation"))
    if( annotName == "exon")
    {
      #print(paste("I am Exon"))
      rownames(Annotation) <- Annotation$ExonID
      Annotation$ExonID    <- factor(Annotation$ExonID, levels=rownames(countObj))
      Annotation           <- Annotation %>% dplyr::arrange(ExonID)

      genesObj <- Annotation[,c("ExonID", "Length")]
    }
    else if(annotName == "trans"){
      rownames(Annotation) <- Annotation$TranscriptID
      Annotation$TranscriptID <- factor(Annotation$TranscriptID, levels=rownames(countObj))
      Annotation <- Annotation %>% dplyr::arrange(TranscriptID)
      genesObj <- Annotation[,c("TranscriptID", "Length")]
    }
    else{
    	 genesObj <- Annotation %>% dplyr::select(GeneName, Length) %>% group_by(GeneName) %>% summarize(Length=mean(Length)) %>% dplyr::arrange(GeneName)
       genesObj <- genesObj[match(rownames(countObj), genesObj$GeneName), ]
       write.table(genesObj, "genesObj.txt", quote=F,sep="\t")
    	 #rownames(Annotation) <- Annotation$GeneID
      #Annotation$GeneID <- factor(Annotation$GeneID, levels=rownames(countObj))
      #Annotation           <- Annotation %>% dplyr::arrange(GeneID)
      #Annotation <- Annotation %>% dplyr::filter(GeneID %in% rownames(countObj))
      #genesObj <- Annotation[,c("GeneID", "Length")]
    }

    ########################################### Choose the Method
    #print(paste("Chooseing the Normalization Method"))
    if( method=="EdgeR") {

   #### EdgeR
      ##  Make EdgeR Object
      colnames(genesObj) <- c("GeneID", "Length")
      #print(nrow(countObj))
      #print(nrow(genesObj))
      GeneDF_EdgeR       <- DGEList(counts=countObj, genes=genesObj)
      ## Estimate Normalising Factors
      GeneDF.Norm  <- calcNormFactors(GeneDF_EdgeR, refColumn = Refcol) ;
      ## Regularized Log Transformation using CPM, FPKM & TPM values
      #GeneDF.tpm   <- as.data.frame(cpm(GeneDF.Norm,  normalized.lib.sizes = TRUE,log = tolog, prior.count = priorCount))
      GeneDF.rpkm  <- as.data.frame(rpkm(GeneDF.Norm, normalized.lib.sizes = T, gene.length=genesObj$Length))
      GeneDF.lrpkm  <- log2(GeneDF.rpkm + 1)
      GeneDF.tpm   <- apply(rpkm(GeneDF.Norm, normalized.lib.sizes = T, gene.length=genesObj$Length), 2 , fpkmToTpm)
      GeneDF.lcpm <- cpm(GeneDF.Norm, log=T)
      #print(nlevels(batch))
      if (!is.null(batch) && nlevels(batch) > 1) {
          print("removing library type effect")
          design <- matrix(1,ncol(GeneDF.Norm),1)
          if (!is.null(group) && nlevels(group) > 1) {
            x <- data.frame("group"=as.factor(as.character(group)))
            design <- model.matrix(~group, data=x)
          }
          #GeneDF.voom <- voom(GeneDF.Norm, design=design)
          #GeneDF.lcpm <- log2(GeneDF.cpm + 1)
          GeneDF.lcpm <- removeBatchEffect(GeneDF.lcpm, batch, design=design)
          GeneDF.lrpkm <- removeBatchEffect(GeneDF.lrpkm, batch, design=design)
          GeneDF.lrpkm <- ifelse(GeneDF.lrpkm < 0, 0, GeneDF.lrpkm)
          GeneDF.rpkm <- 2^GeneDF.lrpkm - 1

      }
      GeneDF.lrpkm <- round(GeneDF.lrpkm, 2)
      GeneDF.rpkm <- round(GeneDF.rpkm, 2)
      #GeneDF.ScaledTpm <- t(t(GeneDF.tpm) / GeneDF.Norm$samples$norm.factors)
      #GeneDF.ScaledTpm <- GeneDF.tpm
    }
    else if( method == "DESeq") {
    #### DESeq
      ##Make DESeq Object
      GeneDF_DESeq      <- DESeqDataSetFromMatrix(countData = as.matrix(countObj), colData = DataFrame(condition), design = ~ condition)
      mcols(GeneDF_DESeq)$basepairs <- genesObj$Length-175+1
      ## Estimate SizeFactors
      GeneDF.Norm <- estimateSizeFactors(GeneDF_DESeq)
      ## Regularized Log Transformation using CPM, FPKM & TPM values
      GeneDF.fpm   <- as.data.frame(fpm(object = GeneDF.Norm,  robust = TRUE))
      GeneDF.rpkm  <- as.data.frame(fpkm(object = GeneDF.Norm,  robust = TRUE))
      GeneDF.tpm   <- apply(GeneDF.rpkm, 2 , fpkmToTpm)
    }

    ########################################### Prepare final files
    if( annotName == "Exon")
    {
      #GeneDF_Norm_CPM  <- cbind(data.frame(Annotation[,c("Chr","Start","End","GeneID", "GeneName","TranscriptID","ExonID")]), GeneDF.CPM )
      GeneDF_Norm_rpkm <- cbind(data.frame(Annotation[,c("Chr","Start","End","GeneID", "GeneName","TranscriptID","ExonID")]), GeneDF.rpkm )
      GeneDF_Norm_tpm  <- cbind(data.frame(Annotation[,c("Chr","Start","End","GeneID", "GeneName","TranscriptID","ExonID")]), GeneDF.tpm )

    }
    else if(annotName == "trans"){

      #GeneDF_Norm_CPM  <- cbind(data.frame(Annotation[,c("Chr","Start","End","GeneID","GeneName","TranscriptID")]), GeneDF.CPM )
      GeneDF_Norm_rpkm <- cbind(data.frame(Annotation[,c("TranscriptID", "GeneID", "GeneName")]), GeneDF.rpkm )
      GeneDF_Norm_tpm  <- cbind(data.frame(Annotation[,c("TranscriptID", "GeneID", "GeneName")]), GeneDF.tpm)

    }
    else{
      #GeneDF_Norm_CPM  <- cbind(data.frame(Annotation[,c("Chr","Start","End","GeneID","GeneName")]), GeneDF.CPM)
      #GeneDF_Norm_rpkm <- cbind(data.frame(Annotation[,c("GeneID", "GeneID", "GeneName")]), GeneDF.rpkm)
      GeneDF_Norm_rpkm <- GeneDF.rpkm
      #GeneDF_Norm_tpm  <- cbind(data.frame(Annotation[,c("GeneID", "GeneID", "GeneName")]), GeneDF.tpm)
      GeneDF_Norm_tpm <- GeneDF.tpm
    }

    ########################################### Choose approprite folder and write files
    if(merge) {   RawCount=FPKM=CPM=TPM="/MergedFiles/" }
    else { RawCount="/RawCount/"; FPKM="/FPKM/" ; CPM="/CPM/" ; TPM="/TPM"}

    if(saveFiles)
    {
      #write.table(countObj, paste(workdir,fileName,"_Count_",annotName,".txt", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)
      #write.table(GeneDF_Norm_rpkm, paste(workdir,fileName,"_Norm_rpkm_",annotName,".txt", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)
      #write.table(GeneDF_Norm_CPM, paste(workdir, fileName,"_Norm_cpm_",annotName,".txt", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)
      #write.table(GeneDF_Norm_tpm, paste(workdir,fileName,"_Norm_tpm_",annotName,".txt", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)
    }
    #print(paste("lcpm row",nrow(GeneDF.lcpm)))
    #print(paste("lcpm col",ncol(GeneDF.lcpm)))
    return(list("tpm" = GeneDF_Norm_tpm, "rpkm" = GeneDF_Norm_rpkm, "lrpkm"=GeneDF.lrpkm, "lcpm"=GeneDF.lcpm))

}

runPCA <- function(lcpm, file_prefix, var_gene_num=2000) {

    print("Running PCA")
    mat <- as.matrix(lcpm)
    mat<-t(mat)
    class(mat)<-"numeric"
    lib_type <- "all"
    #norm_type <- "tmm-rpkm"
    sd_gene <- apply(mat, 2, sd)

    mat <- mat[,which(sd_gene > sort(sd_gene, decreasing=T)[var_gene_num])]
    res<-prcomp(mat)
    loading_file<-paste(file_prefix, "-loading.tsv", sep="");
    coord_file<-paste(file_prefix, "-coord.tsv", sep="");
    std_file<-paste(file_prefix, "-std.tsv", sep="");
    z_loading_file<-paste(file_prefix, "-loading.zscore.tsv", sep="");
    z_coord_file<-paste(file_prefix, "-coord.zscore.tsv", sep="");
    z_std_file<-paste(file_prefix, "-std.zscore.tsv", sep="");

    s <- min(30, ncol(res$rotation))
    if (s > 3) {
      write.table(res$rotation[,1:s], file=loading_file, sep='\t', col.names=FALSE, quote = FALSE);
      write.table(res$x[,1:3], file=coord_file, sep='\t', col.names=FALSE, quote = FALSE);
      write.table(res$sdev, file=std_file, sep='\t', col.names=FALSE, quote = FALSE);
    }

    res_z<-prcomp(mat, center=T, scale=T)
    s <- min(30, ncol(res_z$rotation))
    if (s > 3) {
      write.table(res_z$rotation[,1:s], file=z_loading_file, sep='\t', col.names=FALSE, quote = FALSE);
      write.table(res_z$x[,1:3], file=z_coord_file, sep='\t', col.names=FALSE, quote = FALSE);
      write.table(res_z$sdev, file=z_std_file, sep='\t', col.names=FALSE, quote = FALSE);
    }
}

getColName <- function(x){
  sample <- gsub("Sample_", "", gsub(".*\\.(.*)\\.star_.*", "\\1", c(x)))
  idx <- grep(sample,f[,1])
  if ( identical(idx, integer(0)) ) {
    return (sample)
  }
  return (f[idx[1],2])
}

Args<-commandArgs(trailingOnly=T)
inFile<-Args[1]
geneID_file <- Args[2]
coding_file <- Args[3]
annotationRDS <- Args[4]
annotationType <- Args[5]
outDIR <- Args[6]
outFile <- Args[7]

f<-read.table(inFile, header=F, sep="\t", fill=T)
batch <- f$V4
tissue_type <- f$V5
f<-as.matrix(f)
print("merging count files")
countObj<- do.call(cbind,lapply(paste(f[,3], ".count.txt", sep=""),makeMatrix))
colnames(countObj) <- f[,2]
print("merging TPM files")
tpmObj<- do.call(cbind,lapply(paste(f[,3], ".tpm.txt", sep=""),makeMatrix))
colnames(countObj) <- f[,2]
geneIDs <- read.table(geneID_file, head=T, sep="\t")
coding_genes <- read.table(coding_file, head=F, sep="\t")
rownames(countObj) <- geneIDs[,1]
rownames(tpmObj) <- geneIDs[,1]
coding_list <- as.character(coding_genes$V1)
countCodingObj <- na.omit(subset(countObj, rownames(countObj) %in% coding_list))
tpmCodingObj <- na.omit(subset(tpmObj, rownames(tpmObj) %in% coding_list))
#countCodingObj <- na.omit(countObj[coding_list,])
#tpmCodingObj <- na.omit(tpmObj[coding_list,])
countCodingObj <- countCodingObj[ order(row.names(countCodingObj)), ]
tpmCodingObj <- tpmCodingObj[ order(row.names(tpmCodingObj)), ]
#ltpmObj <- round(log2(tpmObj+1),2)
#ltpmCodingObj <- round(log2(tpmCodingObj+1),2)
#fileList=c("/mnt/webrepo/fr-s-bsg-onc-d/htdocs/onco.data/ProcessedResults/clinomics/CL0045/20160415/CL0045_T2R_T/TPM_UCSC/CL0045_T2R_T_counts.Gene.fc.RDS","/mnt/webrepo/fr-s-bsg-onc-d/htdocs/onco.data/ProcessedResults/clinomics/CL0045/20160415/CL0045_T1R_T4/TPM_UCSC/CL0045_T1R_T4_counts.Gene.fc.RDS")
#annotationRDS = "/mnt/webrepo/fr-s-bsg-onc-d/htdocs/clinomics_dev/app/storage/data/AnnotationRDS/annotation_UCSC_gene.RDS"
#countObj <- ComBat_seq(countObj, batch=batch, group=tissue_type)
GeneDF_Norm<-normalize(countObj=countCodingObj, workdir=outDIR, annotName=annotationType, method="EdgeR", annotationRDS=annotationRDS ,
  priorCount=0, fileName=outFile, merge=T, saveFiles=T, batch=batch, group=tissue_type)

runPCA(GeneDF_Norm$lcpm, paste(outDIR,outFile,sep=""))
old_cols <- colnames(GeneDF_Norm$tpm, do.NULL = FALSE)
new_cols <-lapply(old_cols, getColName)
colnames(GeneDF_Norm$tpm) <- new_cols
colnames(GeneDF_Norm$lrpkm) <- new_cols

print("Saving RDS files")
saveRDS(tpmCodingObj, paste(outDIR,outFile,".coding.tpm.RDS", sep= ""))
saveRDS(GeneDF_Norm$rpkm, paste(outDIR,outFile,".coding.tmm-rpkm.RDS", sep= ""))
#write.table(GeneDF_Norm$tpm, paste(outDIR,outFile,".tpm.tsv", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)
print(paste("Saving ", outDIR,outFile,".all.count.tsv", sep= ""))
write.table(countObj, paste(outDIR,outFile,".all.count.tsv", sep= ""), sep="\t",row.names = T, quote = FALSE)
print(paste("Saving ", outDIR,outFile,".coding.count.tsv", sep= ""))
write.table(countCodingObj, paste(outDIR,outFile,".coding.count.tsv", sep= ""), sep="\t",row.names = T, quote = FALSE)
print(paste("Saving ", outDIR,outFile,".all.tpm.tsv", sep= ""))
write.table(tpmObj, paste(outDIR,outFile,".all.tpm.tsv", sep= ""), sep="\t",row.names = T, quote = FALSE)
#print(paste("Saving ", outDIR,outFile,".all.tpm.log2.tsv", sep= ""))
#write.table(ltpmObj, paste(outDIR,outFile,".all.tpm.log2.tsv", sep= ""), sep="\t",row.names = T, quote = FALSE)
print(paste("Saving ", outDIR,outFile,".coding.tpm.tsv", sep= ""))
write.table(tpmCodingObj, paste(outDIR,outFile,".coding.tpm.tsv", sep= ""), sep="\t",row.names = T, quote = FALSE)
#print(paste("Saving ", outDIR,outFile,".coding.tpm.log2.tsv", sep= ""))
#write.table(ltpmCodingObj, paste(outDIR,outFile,".coding.tpm.log2.tsv", sep= ""), sep="\t",row.names = T, quote = FALSE)
print(paste("Saving ", outDIR,outFile,".coding.tmm-rpkm.tsv", sep= ""))
write.table(GeneDF_Norm$rpkm, paste(outDIR,outFile,".coding.tmm-rpkm.tsv", sep= ""), sep="\t",row.names = T, quote = FALSE)
#print(paste("Saving ", outDIR,outFile,".coding.tmm-rpkm.log2.tsv", sep= ""))
#write.table(GeneDF_Norm$lrpkm, paste(outDIR,outFile,".coding.tmm-rpkm.log2.tsv", sep= ""), sep="\t",row.names = T, quote = FALSE)


size.at.maturity = function(r) {

  require (doBy)

	outputvector = NULL

     res = coef(summary(r))
#      res2 = confint(r)
#      fin = cbind(res[,c("Estimate","Std. Error")],res2)
#      colnames(fin) = c("Estimate","Std. Error", colnames(res2))
      cw50 = dose.LD50(r, lambda=c(1,NA)) # lambda is a vector of model coef, with NA for inverse prediction variable.
      names(cw50) = c("cw50", "cw50lower", "cw50upper")
      olist = c("Estimate","Std. Error")
      r1 = res[1,olist] ; names(r1) = c("a0", "a0.se" )
      r2 = res[2,olist] ; names(r2) = c("a1", "a1.se" )
      r3 = c(length(i), r$deviance, r$aic); names(r3)=c("n", "deviance", "aic")
      r4 = c(floor(r$converged)); names(r4)="converged"

      outputvector = c( r1, r2, r3, r4, cw50)

}


#' Use binary tree metrics to compare two inferred ancestries (ARGs) over a genomic region
#'
#' Runs genome.trees.dist(..., randomly.resolve.polytomies=TRUE) multiple times on the same
#' two tree sequences, breaking polytomies in the second tree sequence differentially (at random)
#' each time.
#' See ?genome.trees.dist for more information.
#' @param treeseq.a The base multiPhylo object, or a path to a .nex file
#' @param treeseq.b The multiPhylo object (or path to .nex files) containing a nonbinary tree
#' to compare to treeseq.a.
#' @param replicates The number of times to run genome.trees.dist()
#' @param seed The random seed to give to set.seed before starting random polytomy breaking
#' @param acceptable.length.diff.pct How much difference in sequence length is allowed between the 2 trees? (Default: 0.1 percent)
#' @param variant.positions A list of positions of each variant (not implemented)
#' @return an average of the metrics over each of the replicates
#' @export
#' @examples
#' genome.trees.dist.forcebin()

genome.trees.dist.forcebin.b <- function(treeseq.a, treeseq.b, replicates=1, seed=NA, acceptable.length.diff.pct = 0.1, variant.positions=NULL, threads=1) {
   require(ape)
   require(parallel) #always available, as this is in R base
   if (class(treeseq.a) != "multiPhylo") {
        a <- read.nexus(treeseq.a, force.multi=TRUE)
    } else {
        a <- treeseq.a
    }
    if (class(treeseq.b) != "multiPhylo") {
         b <- read.nexus(treeseq.b, force.multi=TRUE)
    } else {
         b <- treeseq.b
    }

    if (!is.na(seed)) {
        set.seed(seed)
        seeds <- sample.int(2^31-1, replicates) #pick an integer seed - see ?sample.int
    } else {
        seeds <- TRUE
    }
    return(colMeans(do.call(rbind,mcmapply(
        function(r, seed) genome.trees.dist(treeseq.a, treeseq.b, randomly.resolve.b=seed,
                             acceptable.length.diff.pct = acceptable.length.diff.pct,
                             variant.positions = variant.positions),
        1:replicates,
        seeds,
        SIMPLIFY = FALSE, mc.cores=threads))))
}


#' Perform FET for all elements in needle, haystack
#'
#' @param set1
#' @param set2
#' @param valid
fishers_exact_test = function(set1, set2, valid) {
    stop("this is not working yet")

    tp = length(intersect(set1, set2))
    fp = length(setdiff(set1, set2))
    tn = length(intersect(set1, setdiff(set2, valid)))
    fn = length(setdiff(set2, set1))
    stats::fisher.test(matrix(c(tp, fp, fn, tn), ncol=2))
}

if (is.null(module_name())) {
    re = fishers_exact_test(1:10, 2:11, 1:100)
}


#!/usr/bin/env R
#
# r_bonferroni.R
#
# author = thomas huber
# mail = thomas.huber@evobio.eu
#
# script to analyze HyDe (python package phyde) outputs
# previously set p_values will be corrected after bonferroni
#

args = commandArgs(trailingOnly = TRUE)
ip_name = as.character(args[1L])
dato = read.table(ip_name, header = T)
plato = dato
plato$Pvalue = p.adjust(dato$Pvalue, method = 'bonferroni')
op_name = paste(gsub('.txt','',ip_name),'-bonf.txt', sep = '')
write.table(plato, op_name, sep="\t", quote = FALSE, row.names = FALSE)


reference = "AGCATCGATCGATCGATCGATCGATTGTCGATCGATCGATGT"
pattern = "AGT"

naive <- function(ref, patt, thresh){
    occ <- vector()
    for(i in 0:(nchar(ref) - nchar(patt) + 1)){
        match = TRUE
        mismatch = 0
        for(j in 1:nchar(patt)){
             if(substr(ref, i+j, i+j) != substr(patt, j, j)){
                 mismatch = mismatch + 1
                 if(mismatch > thresh){
                     match = FALSE
                     break
                 }
             }
        }
        if(match){
            occ <- c(occ, i)
        }
    }
    return(occ)
}
print(paste(naive(reference, pattern, 1), collapse = ","))