#~~~~~~~~~~~~~~~forecast.table~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Description: Function to create the forecast summary output
#                 table including dead & surviving discards
# Author: HD/CM
# Date:   26/3/2014
#
#  Input parameters:
#
#   wk.dir        - working directory where the input .csv file is stored & where output
#                   file will be created
#
#   fu            - string giving the name of the FU - used to title the output file & also
#                   if north minch allows for different input format
#
#   hist.sum.table - .csv file with the following columns (column names must
#                           be identical):
#                  'year' - up to and including the most recent year of survey data
#                  'mean.wt.landings' - annual individual mean weight in the landings (g)
#                  'mean.wt.discards' - annual individual mean weight in the discards (g)
#                  'dead.discard.rate'- annual discard rate - dead discards as % of
#                     removals (dead discards + landings)
#                  'adjusted.abundance'- bias corrected survey abundance in millions
#                     (if fu=="north minch",function looks for column titled
#                     'adjusted.abundance.VMS').  The last value in this column is used
#                     in the forecast calculations.
#
#   land.wt.yrs, disc.wt.yrs, disc.rt.yrs - sequences of years over which the landings mean wt,
#                   discard mean wt & dead discard rate are averaged (not weighted average)
#
#   hr.rates     - array of harvest rates (%).  Should be named to provide the information in
#                 the basis column of the summary table
#
#   d.surv       - discard survival rate, defaults to 0.25.
#
# Notes:  function does some checks on the rates - are they % or decimal? Output in tonnes,
#         provided inputs are survey in millions & weights in g.  Rounds output to whole
#         tonnes.
#
# 01/05/2015
#  Function edited from forecast.table.r to accomodate changes in the format and method of forescast for
# advice given in 2015. Landings and discards are now wanted and unwanted catches respectively (no survival).
#  Total discard rates used in place of dead discard rates.
# 04/05/2017
#  Function edited from forecast.table.2015 to give 3 forecast tables as requested by WGNSSK 2017

forecast.table.WGNSSK<- function(wk.dir, fu, hist.sum.table, mean.wts, land.wt.yrs, disc.wt.yrs, disc.rt.yrs,
                          h.rates, d.surv =0.25, latest.advice)
{

#  setwd(wk.dir)
  expl.dat<- read.csv(paste0(wk.dir, hist.sum.table))
  wts<- read.csv(paste0(wk.dir, mean.wts))

#----------------------------Inputs----------------------------------------------------------------------------

# Discard survival
  if(d.surv>1){d.surv <-d.surv/100}

  # Mean weights
  #land.mean.wt <-round(mean(expl.dat$mean.wt.landings[expl.dat$year %in% land.wt.yrs],na.rm=T),2)
  #disc.mean.wt <- round(mean(expl.dat$mean.wt.discards[expl.dat$year %in% disc.wt.yrs],na.rm=T),2)
  land.mean.wt <-round(mean(wts$mean.wt.landings.g[wts$years %in% land.wt.yrs],na.rm=T),2)
  disc.mean.wt <- round(mean(wts$mean.wt.discards.g[wts$years %in% disc.wt.yrs],na.rm=T),2)
  disc.above.MCS.mean.wt<- round(mean(wts$mean.wt.discards.over.g[wts$years %in% disc.wt.yrs],na.rm=T),2)
  disc.below.MCS.mean.wt<- round(mean(wts$mean.wt.discards.under.g[wts$years %in% disc.wt.yrs],na.rm=T),2)

# Discard rates
  disc.mean.rate <-round(mean(expl.dat$discard.rate[expl.dat$year %in% disc.rt.yrs])/100,3)
  disc.mean.rate.above.MCS<- disc.mean.rate*(disc.mean.wt-disc.below.MCS.mean.wt)/(disc.above.MCS.mean.wt-disc.below.MCS.mean.wt)
  disc.mean.rate.below.MCS<- disc.mean.rate-disc.mean.rate.above.MCS
  dead.disc.mean.rate<- disc.mean.rate*(1-d.surv)/(disc.mean.rate*(1-d.surv) + (1-disc.mean.rate))
  dead.disc.mean.rate.below.MCS<- disc.mean.rate.below.MCS*(1-d.surv)/(disc.mean.rate.below.MCS*(1-d.surv) + (1-disc.mean.rate.below.MCS))

  if(disc.mean.rate==0)
    {
      disc.mean.rate.above.MCS<- disc.mean.rate.below.MCS<- dead.disc.mean.rate<- dead.disc.mean.rate.below.MCS<- 0
      disc.mean.wt<- disc.above.MCS.mean.wt<- disc.below.MCS.mean.wt<- 0
    }

#TV Survey abundance

  if(fu %in% c("north minch", "nm", "FU11", "FU 11")){
    ab.col<- names(expl.dat)[grep("adjusted.abundance.VMS", names(expl.dat))[1]]
  } else
  {
    ab.col<- names(expl.dat)[grep("adjusted.abundance", names(expl.dat))[1]]
  }
  last.survey.year<- expl.dat[ max(which(!is.na(expl.dat[,ab.col]))),"year"]
  surv.abundance <- expl.dat[expl.dat$year %in% last.survey.year,ab.col]

#Harvest ratios
  if(!is.null(names(h.rates))){
    summary.output <-data.frame(Basis=names(h.rates), harvest.rate=h.rates)
    summary.output <-rbind(summary.output[summary.output$Basis %in% "Fmsy",],
                           summary.output[summary.output$Basis %in% "Flower",],
                           summary.output[summary.output$Basis %in% "Fmsy",],
                           summary.output[summary.output$Basis %in% "Fmsy",],
                           summary.output[!summary.output$Basis %in% c("Fmsy","Flower"),])
  }else{
    summary.output <-data.frame(Basis=rep("",length(h.rates)))
  }

  if(summary.output$harvest.rate[1]>1){
    hrs <-summary.output$harvest.rate/100
  }
  summary.output$harvest.rate<- icesRound(summary.output$harvest.rate)
#--------------------------------------------------------------------------------------------------------------

  #Catch options assuming zero discards
  summary.output1<-summary.output
  summary.output1$wanted.catch.tonnes <-round(hrs*surv.abundance*(1-disc.mean.rate)*land.mean.wt)
  summary.output1$unwanted.catch.tonnes <-round(hrs*surv.abundance*disc.mean.rate*disc.mean.wt)
  summary.output1$total.catch.tonnes <-with(summary.output1,wanted.catch.tonnes+unwanted.catch.tonnes)
  summary.output1$percentage.advice.change <- paste0(icesRound(100*(summary.output1$total.catch.tonnes-latest.advice[2])/latest.advice[2]), "%")
  summary.output1[summary.output1$Basis %in% "Flower","percentage.advice.change"]<- paste0(icesRound(100*(summary.output1[summary.output1$Basis %in% "Flower","total.catch.tonnes"]-latest.advice[1])/latest.advice[1]), "%")
  summary.output1<- summary.output1[,c("Basis", "total.catch.tonnes", "wanted.catch.tonnes", "unwanted.catch.tonnes", "harvest.rate", "percentage.advice.change")]

  #Catch options assuming discarding is allowed
  summary.output2<-summary.output
  summary.output2$landings.tonnes <-round(hrs*surv.abundance*(1-dead.disc.mean.rate)*land.mean.wt)
  summary.output2$dead.discards.tonnes <-round(hrs*surv.abundance*dead.disc.mean.rate*disc.mean.wt)
  summary.output2$surviving.discards.tonnes <-round(summary.output2$dead.discards.tonnes/((1-d.surv)/d.surv))
  summary.output2$total.catch.tonnes <-with(summary.output2,landings.tonnes+dead.discards.tonnes+surviving.discards.tonnes)
  summary.output2$dead.removals.tonnes <-with(summary.output2,landings.tonnes+dead.discards.tonnes)
  summary.output2$percentage.advice.change <- paste0(icesRound(100*(summary.output2$total.catch.tonnes-latest.advice[2])/latest.advice[2]), "%")
  summary.output2[summary.output2$Basis %in% "Flower","percentage.advice.change"] <- paste0(icesRound(100*(summary.output2[summary.output2$Basis %in% "Flower","total.catch.tonnes"]-latest.advice[1])/latest.advice[1]), "%")
  summary.output2<- summary.output2[,c("Basis", "total.catch.tonnes", "dead.removals.tonnes", "landings.tonnes", "dead.discards.tonnes", "surviving.discards.tonnes","harvest.rate", "percentage.advice.change")]

  #Discarding allowed for de minimis excemptions only
  summary.output3<-summary.output
  dead.discards.below.MCS.N<- hrs*surv.abundance*dead.disc.mean.rate.below.MCS
  surviving.discards.N<- dead.discards.below.MCS.N*d.surv/(1-d.surv)
  unwanted.above.MCS.N<- (hrs*surv.abundance+surviving.discards.N)*disc.mean.rate.above.MCS
  landings.N<- hrs*surv.abundance-(unwanted.above.MCS.N+dead.discards.below.MCS.N)
  summary.output3$landings.tonnes<- round(landings.N*land.mean.wt)
  summary.output3$unwanted.above.MCS.tonnes<- round(unwanted.above.MCS.N*disc.above.MCS.mean.wt)
  summary.output3$dead.discards.below.MCS.tonnes<- round(dead.discards.below.MCS.N*disc.below.MCS.mean.wt)
  summary.output3$surviving.discards.tonnes<- round(surviving.discards.N*disc.below.MCS.mean.wt)
  summary.output3$total.catch.tonnes <- with(summary.output3,landings.tonnes+unwanted.above.MCS.tonnes+dead.discards.below.MCS.tonnes+surviving.discards.tonnes)
  summary.output3$dead.removals.tonnes <- with(summary.output3,landings.tonnes+unwanted.above.MCS.tonnes+dead.discards.below.MCS.tonnes)
  summary.output3$percentage.advice.change <- paste0(icesRound(100*(summary.output3$total.catch.tonnes-latest.advice[2])/latest.advice[2]), "%")
  summary.output3[summary.output3$Basis %in% "Flower","percentage.advice.change"] <- paste0(icesRound(100*(summary.output3[summary.output3$Basis %in% "Flower","total.catch.tonnes"]-latest.advice[1])/latest.advice[1]), "%")
  summary.output3<- summary.output3[,c("Basis", "total.catch.tonnes","dead.removals.tonnes","landings.tonnes","unwanted.above.MCS.tonnes","dead.discards.below.MCS.tonnes","surviving.discards.tonnes","harvest.rate", "percentage.advice.change")]

 #Collect all outputs and inputs into a single object
  out.sum <-vector("list")
  out.sum$table1 <-summary.output1
  out.sum$table2 <-summary.output2
  out.sum$table3 <-summary.output3

#  out.sum$table[,2:4]<-lapply(out.sum$table[,2:4],round,0)
#  out.sum$input.txt <-rep("",11)

  out.sum$input.txt[1] <-paste("Abundance in TV (",last.survey.year,") = " ,surv.abundance,
               " million",sep="")
  out.sum$input.txt[2] <-paste("Mean weight in landings (",land.wt.yrs[1],"-",land.wt.yrs[length(land.wt.yrs)],") = ",
                         round(land.mean.wt,2)," g",sep="")
  out.sum$input.txt[3] <-paste("Mean weight in discards (",disc.wt.yrs[1],"-",disc.wt.yrs[length(disc.wt.yrs)],") = ",
                         round(disc.mean.wt,2)," g",sep="")
  out.sum$input.txt[4] <-paste("Mean weight in unwanted catch > MCS (",disc.rt.yrs[1],"-",disc.rt.yrs[length(disc.rt.yrs)],
                               ") = ",disc.above.MCS.mean.wt," g",sep="" )
  out.sum$input.txt[5] <-paste("Mean weight in unwanted catch < MCS (",disc.rt.yrs[1],"-",disc.rt.yrs[length(disc.rt.yrs)],
                               ") = ",disc.below.MCS.mean.wt," g",sep="" )
  out.sum$input.txt[6] <-paste("Discard rate total (",disc.rt.yrs[1],"-",disc.rt.yrs[length(disc.rt.yrs)],
                               ") = ",icesRound(disc.mean.rate*100)," percentage by number",sep="" )
  out.sum$input.txt[7] <-paste("Discard rate > MCS (",disc.rt.yrs[1],"-",disc.rt.yrs[length(disc.rt.yrs)],
                               ") = ",icesRound(disc.mean.rate.above.MCS*100)," percentage by number",sep="" )
  out.sum$input.txt[8] <-paste("Discard rate < MCS (",disc.rt.yrs[1],"-",disc.rt.yrs[length(disc.rt.yrs)],
                               ") = ",icesRound(disc.mean.rate.below.MCS*100)," percentage by number",sep="" )
  out.sum$input.txt[9] <-paste("Discard survival rate = ",d.surv*100," percentage by number",sep="")
  out.sum$input.txt[10] <-paste("Dead discard rate total (",disc.rt.yrs[1],"-",disc.rt.yrs[length(disc.rt.yrs)],
                               ") = ",icesRound(dead.disc.mean.rate*100)," percentage by number",sep="" )
  out.sum$input.txt[11] <-paste("Dead discard rate < MCS (",disc.rt.yrs[1],"-",disc.rt.yrs[length(disc.rt.yrs)],
                                ") = ",icesRound(dead.disc.mean.rate.below.MCS*100)," percentage by number",sep="" )
  out.sum$input.txt[12] <-paste("Latest Advice (Fmsy):",latest.advice[1]," tonnes")

  #Save output to file
  filename<- paste(wk.dir,fu,"_forecast_table_WGNSSK.csv",sep="")
  cat("Catch options assuming zero discards","\n",file=filename, append=FALSE)
  suppressWarnings(write.table(out.sum$table1,filename,row.names=FALSE, sep=",", append=TRUE))
  cat("\n",file=filename, append=TRUE); cat("Catch options assuming discarding is allowed","\n",file=filename, append=TRUE)
  suppressWarnings(write.table(out.sum$table2,filename,row.names=FALSE, sep=",", append=TRUE))
  cat("\n",file=filename, append=TRUE); cat("Discarding assumed below MCS only","\n",file=filename, append=TRUE)
  suppressWarnings(write.table(out.sum$table3,filename,row.names=FALSE, sep=",", append=TRUE))
  cat("\n",file=filename, append=TRUE); cat("Inputs for the catch options","\n",file=filename, append=TRUE)
  for (l in 1:length(out.sum$input.txt)){
    cat(out.sum$input.txt[l],file=filename, append=TRUE)
    cat("\n",file=filename, append=TRUE)
  }
}


library(edgeR)
library(gamlss)
library(parallel)

################################################################################
setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("COVID19_Ensemble_noise.RDat")

# Adjust Ensemble gene noise p values
COVID_ENS_noise_sig$padj <- p.adjust(COVID_ENS_noise_sig$p, "bonferroni")

################################################################################
# Select pathways to plot
pathways_to_plot <- c(
  grep("mitochondrial respiratory chain complex I assembly", rownames(COVID_ENS_noise_sig), fixed = T),
  # grep("Respiratory chain complex I (subcomplex I alpha)", rownames(COVID_ENS_noise_sig), fixed = T),
  grep("Respiratory chain complex I (nuclear encoded subunits)", rownames(COVID_ENS_noise_sig), fixed = T),
  grep("Osteoclast differentiation", rownames(COVID_ENS_noise_sig)),
  grep("Tight junction", rownames(COVID_ENS_noise_sig)),
  grep("Axon guidance", rownames(COVID_ENS_noise_sig)),
  grep("HIF-1 signaling pathway", rownames(COVID_ENS_noise_sig)),
  grep("Peroxisome", rownames(COVID_ENS_noise_sig)),
  grep("Necroptosis", rownames(COVID_ENS_noise_sig)),
  grep("NOD-like receptor signaling pathway", rownames(COVID_ENS_noise_sig)),
  grep("Fc epsilon RI signaling pathway", rownames(COVID_ENS_noise_sig)),
  grep("Autophagy - other", rownames(COVID_ENS_noise_sig)),
  grep("Biosynthesis of amino acids", rownames(COVID_ENS_noise_sig)),
  grep("TRAPP complex", rownames(COVID_ENS_noise_sig)),
  grep("Glucagon signaling pathway", rownames(COVID_ENS_noise_sig)),
  grep("Propanoate metabolism", rownames(COVID_ENS_noise_sig)),
  grep("Circadian rhythm", rownames(COVID_ENS_noise_sig)),
  grep("Dopaminergic synapse", rownames(COVID_ENS_noise_sig)),
  grep("Amyotrophic lateral sclerosis", rownames(COVID_ENS_noise_sig))
)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures")

pdf("Figure6B_S10.pdf", paper="a4r", width=8, height=5)

stripcol = c("#4591CCCC", "#673AB7CC"); COL = c("#4591CC", "#673AB7")

par(mfrow=c(1,4))

for(i in seq(pathways_to_plot)) {

  pthw <- rownames(COVID_ENS_noise)[pathways_to_plot[i]]
  st <- COVID_ENS_noise_sig[pathways_to_plot[i],]
  df <- data.frame(y = c(COVID_ENS_noise[pathways_to_plot[i],]), x = DGE_RNAcounts$samples$stage)

  mu <- aggregate(y ~ x, data=df, function(x) mean(x))$y
  upp_sd <- aggregate(y ~ x, data=df, function(x) mean(x) + sd(x))$y
  lwr_sd <- aggregate(y ~ x, data=df, function(x) mean(x) - sd(x))$y

  stripchart(df$y ~ df$x, vertical=T, method="jitter", pch=c(16, 17),
    col=stripcol, add=F, cex=2, ylab = pthw, las = 1)

  segments(1, mu[1], 2, mu[2], col = 1, lty = 2, lwd=2  )
  segments(c(1:2), upp_sd, c(1:2), lwr_sd, col = COL, lwd=3  )
  points(c(1:2), mu, pch=21, col = COL, bg = "white", cex=3, lwd=3  )
  legend("topleft", legend = paste0("t = ", round(st$t, 3), ", p = ", round(st$padj, 5)), cex=0.9)
}

dev.off()


MGRAST_preprocessing <<- function(file_in,     # name of the input file (tab delimited text with the raw counts) or R matrix
                                  data_type             = "file",  # c(file, r_matrix)
                                  output_object         = "default", # output R object (matrix)
                                  file_out              = "default", # output flat file
                                  remove_sg             = TRUE, # boolean to remove singleton counts
                                  remove_sg_valueMin    = 1, # lowest retained value (lower converted to 0)
                                  sg_threshold          = 1, # lowest retained row sum (lower, row is removed)
                                  log_transform         = FALSE,
                                  norm_method           = "DESeq_blind", #c("standardize", "quantile", "DESeq_blind", "DESeq_per_condition", "DESeq_pooled", "DESeq_pooled_CR", "none"), # USE blind if not replicates -- use pooled to get DESeq default
                                  pseudo_count          = 1, # has to be integer for DESeq
                                  DESeq_metadata_table  = NA, # only used if method is other than "blind"
                                  DESeq_metadata_column = 1, # only used if method is other than "blind"
                                  DESeq_metadata_type   = "file",           # c( "file", "r_matrix" )
                                  #DESeq_method          = "blind",  # c( "pooled", "pooled-CR", "per-condition", "blind" ) # blind, treat everything as one group
                                  DESeq_sharingMode     = "maximum",  # c( "maximum", "fit-only", "gene-est-only" ) # maximum is the most conservative choice
                                  DESeq_fitType         = "local",          # c( "parametric", "local" )
                                  DESeq_image           = FALSE, # create dispersion vs mean plot indicate DESeq regression
                                  scale_0_to_1          = TRUE,
                                  produce_fig           = FALSE,
                                  image_out             = "default",
                                  boxplot_height_in     = "default", # 11,
                                  boxplot_width_in      = "default", #"8.5,
                                  boxplot_res_dpi       = 300,
                                  create_log            = TRUE,
                                  debug                 = FALSE
                                  )

  {

    # check for necessary packages, install if they are not there
    #require(matR) || install.packages("matR", repo="http://mcs.anl.gov/~braithwaite/R", type="source")
    #chooseCRANmirror()
    #setRepositories(ind=1:8)
    #source("http://bioconductor.org/biocLite.R")
    #require(preprocessCore) || install.packages("preprocessCore")
    #require(DESeq) || biocLite("DESeq") # update to DESeq2 when I have a chance
    #if ( is.element("RColorBrewer", installed.packages()[,1]) == FALSE ){ install.packages("RColorBrewer") }
    #if ( is.element("preprocessCore", installed.packages()[,1]) == FALSE ){ biocLite("preprocessCore") }
    #if ( is.element("DESeq", installed.packages()[,1]) == FALSE ){ biocLite("DESeq") }
    # (DESeq): www.ncbi.nlm.nih.gov/pubmed/20979621
    suppressPackageStartupMessages(library(preprocessCore))
    suppressPackageStartupMessages(library(DESeq))
    suppressPackageStartupMessages(library(RColorBrewer))
    ###### MAIN

    # get the name of the data object if an object is used -- use the filename if input is filename string
    if ( identical( data_type, "file") ){
      input_name <- file_in
    }else if( identical( data_type, "r_matrix") ){
      input_name <- deparse(substitute(file_in))
    }else{
      stop( paste( data_type, " is not a valid option for data_type", sep="", collapse=""))
    }

    # Generate names for the output file and object
    if ( identical( output_object, "default") ){
      output_object <- paste( input_name, ".", norm_method, ".PREPROCESSED" , sep="", collapse="")
    }
    if ( identical( file_out, "default") ){
      file_out <- paste( input_name, ".", norm_method, ".PREPROCESSED.txt" , sep="", collapse="")
    }

    # Input the data
    if ( identical( data_type, "file") ){
      input_data <- data.matrix(read.table(file_in, row.names=1, header=TRUE, sep="\t", comment.char="", quote="", check.names=FALSE))
    }else if( identical( data_type, "r_matrix") ){
      input_data <- data.matrix(file_in)
    }else{
      stop( paste( data_type, " is not a valid option for data_type", sep="", collapse=""))
    }

    # sort the data (COLUMNWISE) by id
    sample_names <- order(colnames(input_data))
    input_data <- input_data[,sample_names]

    # make a copy of the input data that is not processed
    input_data.og <- input_data

    # non optional, convert "na's" to 0
    input_data[is.na(input_data)] <- 0

    # remove singletons
    if(remove_sg==TRUE){
      input_data <- remove.singletons(x=input_data, lim.entry=remove_sg_valueMin, lim.row=sg_threshold, debug=debug)
    }

    # log transform log(x+1)2
    if ( log_transform==TRUE ){
      input_data <- log_data(input_data)
    }

    regression_message <- "DESeq regression:      NA"
    # Normalize -- stadardize or quantile norm (depends on user selection)
    switch(
           norm_method,

           standardize={
             input_data <- standardize_data(input_data)
           },

           quantile={
             input_data <- quantile_norm_data(input_data)
           },

           DESeq_blind={
             regression_filename = paste(  input_name, ".DESeq_regression.png", sep="", collapse="" )
             regression_message <- paste("DESeq regression:      ", regression_filename, sep="", collapse="" )
             input_data <- DESeq_norm_data(input_data, regression_filename, pseudo_count,
                                           DESeq_metadata_table, DESeq_metadata_column, sample_names,
                                           DESeq_method="blind", DESeq_sharingMode, DESeq_fitType, DESeq_image, debug)
           },

           DESeq_per_condition={
             stop( cat("The DESeq_per_condition option does not work as it should. DESeq authors advise using the pooled method (DESeq_pooled here) instead.\n
You can accomplish a normalization equivalent to per-condition if you break your data into one matrix per-condition and use the pooled option.
Given that the method athors advise using the pooled methods anyways, I don't plan to fix this unless it is requested. For future reference, it
works up through estimateDispersions(), but fails on varianceStabilizingTransformation().  I can't find examples - and would not be able to debug
quickly"
                       ))
             #if( is.na(DESeq_metadata_table) ){ stop("To DESeq_norm_by_group you must specify a DESeq_metadata_table") }
             #regression_filename = paste(  input_name, ".DESeq_regression.png", sep="", collapse="" )
             #regression_message <- paste("DESeq regression:      ", regression_filename, sep="", collapse="" )
             #input_data <- DESeq_norm_data(input_data, regression_filename, pseudo_count,
             #                              DESeq_metadata_table, DESeq_metadata_column, sample_names,
             #                              DESeq_method="per-condition", DESeq_sharingMode, DESeq_fitType, DESeq_image, debug)
           },

           DESeq_pooled={
             if( is.na(DESeq_metadata_table) ){ stop("To DESeq_pooled you must specify a DESeq_metadata_table") }
             regression_filename = paste(  input_name, ".DESeq_regression.png", sep="", collapse="" )
             regression_message <- paste("DESeq regression:      ", regression_filename, sep="", collapse="" )
             input_data <- DESeq_norm_data(input_data, regression_filename, pseudo_count,
                                           DESeq_metadata_table, DESeq_metadata_column, sample_names,
                                           DESeq_method="pooled", DESeq_sharingMode, DESeq_fitType, DESeq_image, debug)
           },

           DESeq_pooled_CR={
             if( is.na(DESeq_metadata_table) ){ stop("To DESeq_pooled_CR you must specify a DESeq_metadata_table") }
             regression_filename = paste(  input_name, ".DESeq_regression.png", sep="", collapse="" )
             regression_message <- paste("DESeq regression:      ", regression_filename, sep="", collapse="" )
             input_data <- DESeq_norm_data(input_data, regression_filename, pseudo_count,
                                           DESeq_metadata_table, DESeq_metadata_column, sample_names,
                                           DESeq_method="pooled-CR", DESeq_sharingMode, DESeq_fitType, DESeq_image, debug)
           },

           none={
             input_data <- input_data
           },
           {
             stop( paste( norm_method, " is not a valid option for method", sep="", collapse=""))
           }
           )

    # scale normalized data [max..min] to [0..1] over the entire dataset
    if ( scale_0_to_1==TRUE ){
      input_data <- scale_data(input_data)
    }

    # create object, with specified name, that contains the preprocessed data
    do.call("<<-",list(output_object, input_data))

    # write flat file, with specified name, that contains the preprocessed data
    write.table(input_data, file=file_out, sep="\t", col.names = NA, row.names = TRUE, quote = FALSE, eol="\n")

    # produce boxplots
    boxplot_message <- "output boxplot:        NA"
    if ( produce_fig==TRUE ) {

      if( identical(image_out, "default") ){
        boxplots_file <- paste(input_name, ".boxplots.png", "\n", sep="", collapse="")
      }else{
        boxplots_file <- image_out
      }

      if( identical(boxplot_height_in, "default") ){ boxplot_height_in <- 8.5 }
      #if( identical(boxplot_width_in, "default") ){ boxplot_width_in <- round(ncol(input_data)/14) }
      if( identical(boxplot_width_in, "default") ){ boxplot_width_in <- 11 }

      png(
          filename = boxplots_file,
          height = boxplot_height_in,
          width = boxplot_width_in,
          res = boxplot_res_dpi,
          units = 'in'
          )
      plot.new()
      split.screen(c(2,1))
      screen(1)
      graphics::boxplot(input_data.og, main=(paste("RAW", sep="", collapse="")), las=2, cex.axis=0.5)
      screen(2)
      graphics::boxplot(input_data, main=(paste("PREPROCESSED (", norm_method, " norm)", sep="", collapse="")),las=2, cex.axis=0.5)
      dev.off()
      boxplot_message <- paste("output boxplot:       ", boxplots_file, "\n", sep="", collapse="")
    }

    # message to send to the user after completion, given names for object and flat file outputs
    #writeLines( paste("Data have been preprocessed. Proprocessed, see ", log_file, " for details", sep="", collapse=""))
    if ( create_log==TRUE ){
      # name log file
      log_file <- paste( file_out, ".log", sep="", collapse="")
      # write log
      writeLines(
                 paste(
                       "##############################################################\n",
                       "###################### INPUT PARAMETERS ######################\n",
                       "file_in:               ", file_in, "\n",
                       "data_type:             ", data_type, "\n",
                       "output_object:         ", output_object, "\n",
                       "file_out:              ", file_out, "\n",
                       "remove_sg:             ", as.character(remove_sg),
                       "remove_sg_valueMin:    ", remove_sg_valueMin, "\n",
                       "sg_threshold:          ", sg_threshold, "\n",
                       "log_transform          ", as.character(log_transform), "\n",
                       "norm_method:           ", norm_method, "\n",
                       "DESeq_metadata_table:  ", as.character(DESeq_metadata_table), "\n",
                       "DESeq_metadata_column: ", DESeq_metadata_column, "\n",
                       "DESeq_metadata_type:   ", DESeq_metadata_type, "\n",
                       #"DESeq_method:          ", DESeq_method, "\n",
                       "DESeq_sharingMode:     ", DESeq_sharingMode, "\n",
                       "DESeq_fitType:         ", DESeq_fitType, "\n",
                       "scale_0_to_1:          ", as.character(scale_0_to_1), "\n",
                       "produce_fig:           ", as.character(produce_fig), "\n",
                       "boxplot_height_in:     ", boxplot_height_in, "\n",
                       "boxplot_width_in:      ", boxplot_width_in, "\n",
                       "debug as.character:    ", as.character(debug), "\n",
                       "####################### OUTPUT SUMMARY #######################\n",
                       "output object:         ", output_object, "\n",
                       "output file:           ", file_out, "\n",
                       boxplot_message, "\n",
                       regression_message, "\n",
                       "##############################################################",
                       sep="", collapse=""
                       ),
                 con=log_file
                 )
    }
  }

######################################################################
######################################################################
### SUBS
######################################################################
######################################################################

######################################################################
### Load metadata (for groupings)
######################################################################
load_metadata <- function(group_table, group_column, sample_names){
  metadata_matrix <- as.matrix( # Load the metadata table (same if you use one or all columns)
                               read.table(
                                          file=group_table,row.names=1,header=TRUE,sep="\t",
                                          colClasses = "character", check.names=FALSE,
                                          comment.char = "",quote="",fill=TRUE,blank.lines.skip=FALSE
                                          )
                               )

  #metadata_matrix <- metadata_matrix[ order(sample_names),,drop=FALSE ]
  group_names <- metadata_matrix[ order(sample_names), group_column,drop=FALSE ]
  return(group_names)
}
######################################################################

######################################################################
### Sub to remove singletons
######################################################################
remove.singletons <- function (x, lim.entry, lim.row, debug) {
  x <- as.matrix (x)
  x [is.na (x)] <- 0
  x [x < lim.entry] <- 0 # less than limit changed to 0
  #x [ apply(x, MARGIN = 1, sum) >= lim.row, ] # THIS DOES NOT WORK - KEEPS ORIGINAL MATRIX
  x <- x [ apply(x, MARGIN = 1, sum) >= lim.row, ] # row sum equal to or greater than limit is retained
  if (debug==TRUE){write.table(x, file="sg_removed.txt", sep="\t", col.names = NA, row.names = TRUE, quote = FALSE, eol="\n")}
  x
}
######################################################################

# theMatrixWithoutRow5 = theMatrix[-5,]
# t1 <- t1[-(4:6),-(7:9)]
# mm2 <- mm[mm[,1]!=2,] # delete row if first column is 2
# data[rowSums(is.na(data)) != ncol(data),] # remove rows with any NAs

######################################################################
### Sub to log transform (base two of x+1)
######################################################################
log_data <- function(x, pseudo_count){
  x <- log2(x + pseudo_count)
  x
}
######################################################################

######################################################################
### sub to perform quantile normalization
######################################################################
quantile_norm_data <- function (x, ...){
  data_names <- dimnames(x)
  x <- normalize.quantiles(x)
  dimnames(x) <- data_names
  x
}
######################################################################

######################################################################
### sub to perform standardization
######################################################################
standardize_data <- function (x, ...){
  mu <- matrix(apply(x, 2, mean), nr = nrow(x), nc = ncol(x), byrow = TRUE)
  sigm <- apply(x, 2, sd)
  sigm <- matrix(ifelse(sigm == 0, 1, sigm), nr = nrow(x), nc = ncol(x), byrow = TRUE)
  x <- (x - mu)/sigm
  x
}
######################################################################

######################################################################
### sub to perform DESeq normalization
######################################################################
DESeq_norm_data <- function (x, regression_filename, pseudo_count,
                             DESeq_metadata_table, DESeq_metadata_column, sample_names,
                             DESeq_method, DESeq_sharingMode, DESeq_fitType, DESeq_image, debug, ...){
  # much of the code in this function is adapted/borrowed from two sources
  # Orignal DESeq publication www.ncbi.nlm.nih.gov/pubmed/20979621
  #     also see vignette("DESeq")
  # and Paul J. McMurdie's example analysis in a later paper http://www.ncbi.nlm.nih.gov/pubmed/24699258
  #     with supporing material # http://joey711.github.io/waste-not-supplemental/simulation-cluster-accuracy/simulation-cluster-accuracy-server.html
  if(debug==TRUE)(print("made it here DESeq (1)"))

  # check that pseudo counts are integer - must for DESeq
  if ( all.equal(pseudo_count, as.integer(pseudo_count)) != TRUE ){
    stop(paste("DESeq requires an integer pseudo_count, (", pseudo_count, ") is not an integer" ))
  }

  # import metadata matrix (from object or file)
  #if(!is.na(DESeq_metadata_table)){
  #  my_metadata <- load_metadata(DESeq_metadata_table, DESeq_metadata_column, sample_names)
  #}

  # create metdata for the "blind" case -- all samples treated as if they are in the same group
  if( identical(DESeq_method,"blind") ){
    my_conditions <- as.factor(rep(1,ncol(x)))
    if(debug==TRUE){my_conditions.test<<-my_conditions}
  }else{
    my_metadata <- load_metadata(DESeq_metadata_table, DESeq_metadata_column, sample_names)
    metadata_factors <- as.factor(my_metadata)
    if(debug==TRUE){my_metadata.test<<-my_metadata}
    my_conditions <- metadata_factors
    if(debug==TRUE){my_conditions.test<<-my_conditions}
  }

  if(debug==TRUE)(print("made it here DESeq (2)"))

  # add pseudocount to prevent workflow from crashing on NaNs - DESeq will crash on non integer counts
  x = x + pseudo_count

  # create dataset object
  if(debug==TRUE){my_conditions.test<<-my_conditions}
  my_dataset <- newCountDataSet( x, my_conditions )
  if(debug==TRUE){my_dataset.test1 <<- my_dataset}
  if(debug==TRUE)(print("made it here DESeq (3)"))

  # estimate the size factors
  my_dataset <- estimateSizeFactors(my_dataset)

  if(debug==TRUE)(print("made it here DESeq (4)"))
  if(debug==TRUE){my_dataset.test2 <<- my_dataset}

  # estimate dispersions
  # reproduce this: deseq_varstab(physeq, method = "blind", sharingMode = "maximum", fitType = "local")
  #      see https://stat.ethz.ch/pipermail/bioconductor/2012-April/044901.html
  # with DESeq code directly
  # my_dataset <- estimateDispersions(my_dataset, method = "blind", sharingMode = "maximum", fitType="local")
  # but this is what they did in the supplemental material for the DESeq paper (I think) -- and in figure 1 of McMurdie et al.
  #my_dataset <- estimateDispersions(my_dataset, method = "pooled", sharingMode = "fit-only", fitType="local") ### THIS WORKS
  # This is what they suggest in the DESeq vignette for multiple replicats

  my_dataset <- estimateDispersions(my_dataset, method = DESeq_method, sharingMode = DESeq_sharingMode, fitType = DESeq_fitType)

  # in the case of per-condition, creates an envrionment called fitInfo
  # ls(my_dataset.test4@fitInfo)

  #  my_dataset <- estimateDispersions(my_dataset, method = DESeq_method, sharingMode = DESeq_sharingMode, fitType = DESeq_fitType)

  if(debug==TRUE){my_dataset.test3 <<- my_dataset}

  if(debug==TRUE)(print("made it here DESeq (5)"))

  # Determine which column(s) have the dispersion estimates
  dispcol = grep("disp\\_", colnames(fData(my_dataset)))

  # Enforce that there are no infinite values in the dispersion estimates
  #if (any(!is.finite(fData(my_dataset)[, dispcol]))) {
  #  fData(cds)[which(!is.finite(fData(my_dataset)[, dispcol])), dispcol] <- 0
  #}

  if(debug==TRUE)(print("made it here DESeq (6)"))

  # apply variance stabilization normalization
  #if ( identical(DESeq_method, "per-condition") ){

  # produce a plot of the regression
  if(DESeq_image==TRUE){
    png(
        filename = regression_filename,
        height = 8.5,
        width = 11,
        res = 300,
        units = 'in'
        )
        #plot.new()
    plotDispEsts( my_dataset )
    dev.off()
  }

if(debug==TRUE)(print("made it here DESeq (7)"))

  my_dataset.normed <- varianceStabilizingTransformation(my_dataset)
  # ls(my_dataset.test4@fitInfo)
  # my_dataset.test4@fitInfo$Kirsten$fittedDispEsts

  if(debug==TRUE){my_dataset.test4 <<- my_dataset.normed}

  #}else{
   # my_dataset.normed <- varianceStabilizingTransformation(my_dataset)
  #}

  # return matrix of normed values
  x <- exprs(my_dataset.normed)
  x

}
######################################################################

######################################################################
### sub to scale dataset values from [min..max] to [0..1]
######################################################################
scale_data <- function(x){
  shift <- min(x, na.rm = TRUE)
  scale <- max(x, na.rm = TRUE) - shift
  if (scale != 0) x <- (x - shift)/scale
  x
}
######################################################################


source("scRNA_func.r")

library(SignacX)
library(Seurat)
library(ggplot2)

options(future.globals.maxSize= 10779361280)
random.seed=20200107

options_table<-read.table(parSampleFile1, sep="\t", header=F, stringsAsFactors = F)
myoptions<-split(options_table$V1, options_table$V2)
tcell_only = ifelse(myoptions$tcell_only == "1", TRUE, FALSE)
pca_dims=1:as.numeric(myoptions$pca_dims)
resolution=as.numeric(myoptions$resolution)
reduction=myoptions$reduction

finalList=readRDS(parFile1)
obj=finalList$obj

if(DefaultAssay(obj) == "integrated"){
  if(nrow(obj@assays$integrated@counts) == 0){
    if ("SCT" %in% names(obj@assays)){
      obj@assays$integrated@counts = obj@assays$SCT@counts
    }else{
      obj@assays$integrated@counts = obj@assays$RNA@counts
    }
  }
}

if(tcell_only){
  cells_tbl = read.csv(parFile2, row.names=1)
  cells=rownames(cells_tbl)[cells_tbl$cellactivity_clusters == "T cells"]
  obj=subset(obj, cells=cells)
  obj<-FindNeighbors(object = obj, reduction=reduction, dims=pca_dims, verbose=FALSE)
}

labels <- Signac(obj)

celltypes = GenerateLabels(labels, E = obj)
saveRDS(celltypes, file=paste0(outFile, ".SignacX.rds"))

obj <- AddMetaData(obj, metadata = celltypes$CellStates, col.name = "CellStates")
png(paste0(outFile, ".SignacX.no_recluster.png"), width=3300, height=3000, res=300)
g1=DimPlot(obj, group.by = "CellStates", reduction="umap", label=T)
print(g1)
dev.off()

dm=cbind(data.frame(obj@reductions$umap@cell.embeddings), data.frame(Cluster=obj$seurat_clusters, SignacX=obj$CellStates))
png(paste0(outFile, ".SignacX.no_recluster.c1.png"), width=5000, height=4000, res=300)
g1=ggplot(dm, aes(x=UMAP_1, y=UMAP_2, color=SignacX)) + geom_point() + facet_wrap(~Cluster)+theme_bw()
print(g1)
dev.off()

png(paste0(outFile, ".SignacX.no_recluster.c2.png"), width=5000, height=4000, res=300)
g1=ggplot(dm, aes(x=UMAP_1, y=UMAP_2, color=Cluster)) + geom_point() + facet_wrap(~SignacX)+theme_bw()
print(g1)
dev.off()

ct<-data.frame("Signac"=celltypes$CellStates, "Clusters"=obj$seurat_clusters)

ct_tbl<-table(ct$Signac,ct$Clusters)
write.csv(ct_tbl, paste0(outFile, ".SignacX.cluster.csv"))

if(tcell_only){
  obj<-RunUMAP(object = obj, reduction=reduction, dims=pca_dims, verbose = FALSE)
  obj<-FindClusters(object=obj, verbose=FALSE, random.seed=random.seed, resolution=resolution)

  png(paste0(outFile, ".SignacX.recluster.png"), width=3300, height=3000, res=300)
  g1=DimPlot(obj, group.by = "CellStates", reduction="umap", label=T)
  print(g1)
  dev.off()

  dm=cbind(data.frame(obj@reductions$umap@cell.embeddings), data.frame(Cluster=obj$seurat_clusters, SignacX=obj$CellStates))
  png(paste0(outFile, ".SignacX.recluster.c1.png"), width=5000, height=4000, res=300)
  g1=ggplot(dm, aes(x=UMAP_1, y=UMAP_2, color=SignacX)) + geom_point() + facet_wrap(~Cluster)+theme_bw()
  print(g1)
  dev.off()

  png(paste0(outFile, ".SignacX.recluster.c2.png"), width=5000, height=4000, res=300)
  g1=ggplot(dm, aes(x=UMAP_1, y=UMAP_2, color=Cluster)) + geom_point() + facet_wrap(~SignacX)+theme_bw()
  print(g1)
  dev.off()
}


#' Meta cell cover
#'
#' Representing a meta cell cover of a given cell graph (or more generally of a scRNA data matrix)
#'
#' @slot mc assignment of cells to metacell id
#' @slot cell_names names of cells (all other objects use running integres relating to these names)
#' @slot mc_fp a matrix showing for each gene (row) the relative enrichment of umis
#' @slot e_gc a matrix showin
#'
#'
#'
#'
#'
#'                                                                                g for each gene (row) the mean umi count (without normalizing for cell size)
#' @slot cov_gc a matrix showing for each gene (row) the fraction of cells in the meta cell that are non zero for the umi
#' @slot n_bc a matrix detemrining for each batch (row) the meta cell breakdown
#' @slot annots names of metacells (oridnal numbers by default)
#' @slot colors colors of metacells
#' @slot color_key data.frame defining color per markers genes
#'
#' @export tgMCCov
#' @exportClass tgMCCov
tgMCCov <- setClass(
   "tgMCCov",
	slots = c(
	  mc = "vector",
	  outliers = "vector",
	  cell_names = "vector",
	  mc_fp = "matrix",
	  e_gc = "matrix",
	  cov_gc = "matrix",
	  n_bc = "matrix",
	  annots = "vector",
	  colors = "vector",
	  color_key = "data.frame")
)

#' Construct a meta cell object
#'
#' This constructs a meta cell cover object. It gets an MC assignment (cell->MC_ID), and a matrix, and call standard api of this class to compute the footprints.
#'
#' @param mc assignment of metacell id to cell
#' @param scmat a single cell RNA matrix object
#' @export

setMethod(
  "initialize",
  signature = "tgMCCov",
  definition =
    function(.Object, mc, outliers = c(), scmat) {
		all_cells = colnames(scmat@mat)
		.Object@mc = mc
		.Object@outliers = outliers
		.Object@cell_names = all_cells
		mc_cells = names(mc)
		if(length(intersect(outliers, mc_cells)) > 0) {
			stop("MC-ERR non zero intersect of outliers and mc assigned cells")
		}
		if(length(all_cells) != (length(mc_cells)+length(outliers))
		| length(setdiff(all_cells, c(mc_cells, outliers))) > 0) {
			stop("matrix cell names and mc assignments+outliers differ in tgMCCov initialization", paste(head(setdiff(all_cells, c(mc_cells, outliers))),collapse=" "))
		}
		max_clust = max(mc)
		.Object@colors = rep("white", n=max_clust)
		.Object@annots= 1:max_clust
		.Object = mc_update_stats(.Object, scmat)
		.Object@color_key = data.frame(group=c(), gene=c(), color=c(), priority=c(), T_fold=c())
      return(.Object)
    }
)

#' Generate a new metacell in scdb
#'
#' This constructs a meta cell cover object and puts it into scdb. It gets an MC assignment (cell->MC_ID), and a matrix, and call standard api of this class to compute the footprints.
#'
#' @param mc_id id of scdb meta cell object ot be added
#' @param mc assignment of metacell id to cell
#' @param outliers the list of outliers
#' @param scmat a single cell RNA matrix object
#' @export
mcell_new_mc = function(mc_id, mc, outliers, scmat)
{
	scdb_add_mc(mc_id, tgMCCov(mc, outliers, scmat))
}

#' Compute stats over metacell and update the object
#'
#' This compute statistics per metacell given an sc matirx.
#'
#' @param mc a metacell object
#' @param scmat a matrix object to draw statisics from
#' @export
mc_update_stats = function(mc, scmat)
{
	us = scmat@mat[, names(mc@mc)]
	message("add batch counts")
	mc@n_bc = mc_compute_n_bc(mc, scmat)
	message("compute footprints")
	mc@mc_fp = mc_compute_fp(mc, us)
	message("compute absolute ps")
	mc@e_gc= mc_compute_e_gc(mc, us)
	message("compute coverage ps")
	mc@cov_gc = mc_compute_cov_gc(mc, us)
	return(mc)
}

#' Move all cels from specific metacells to the outliers
#'
#' This can be used to treat doublets metacells or other artifacts.
#'
#' @param mc mc object
#' @param mc_ids list of metacells to eliminate
#'
#' @export
mc_set_outlier_mc = function(mc, mc_ids)
{
	miss_mc = setdiff(mc_ids, colnames(mc@mc_fp))
	if(length(miss_mc) != 0) {
		stop("trying to remove non existing mcs, ids ", paste(miss_mc, collapse=" "))
	}
	N = ncol(mc@mc_fp)
	newN = N - length(mc_ids)
	id_map = rep(-1,N)
	id_map[(1:N)[-mc_ids]] = 1:newN
	ocells = names(mc@mc)[which(mc@mc %in% mc_ids)]
	mc@outliers = c(mc@outliers, ocells)
	gcells = setdiff(mc@cell_names, mc@outliers)
	mc@mc = mc@mc[gcells]
	mc@mc = id_map[mc@mc]
	names(mc@mc) = gcells
	drop_f = !(colnames(mc@mc_fp) %in% mc_ids)
	mc@mc_fp = mc@mc_fp[,drop_f]
	colnames(mc@mc_fp) = 1:newN
	mc@e_gc = mc@e_gc[,drop_f]
	colnames(mc@e_gc) = 1:newN
	mc@cov_gc = mc@cov_gc[,drop_f]
	colnames(mc@cov_gc) = 1:newN

#handle cases of single batch (vector.matrix issues)
	tb = mc@n_bc[,drop_f]
	n_bc = matrix(tb, ncol=sum(drop_f))
	rownames(n_bc) = rownames(mc@n_bc)
	mc@n_bc = n_bc
	colnames(mc@n_bc) = 1:newN

	mc@annots = mc@annots[drop_f]
	names(mc@annots) = 1:newN
	mc@colors= mc@colors[drop_f]
	names(mc@colors) = 1:newN
	return(mc)
}

#' Compute metacell gene footprint
#'
#' The footprint is defined as the size-normalized geometric mena of the number of umis per metacells, dvided by the median over all metacells.
#'
#' @param mc a metacell object
#' @param us umi matrix
#' @param norm_by_mc_size normalize by mean total umis and then multiply by median mean mc size (or at least 1000). This means umis per 1000 molecules.
#' @param min_total_umi consider genes with at least min_total_umi total umis
#'
#' @export
mc_compute_fp = function(mc, us, norm_by_mc_size=T, min_total_umi=10)
{
	f_g_cov = rowSums(us) > min_total_umi

	if(0) {
		mc_cores = get_param("mc_cores")
		doMC::registerDoMC(mc_cores)
		all_gs = rownames(us[f_g_cov,])
		n_g = length(all_gs)
		g_splts = split(all_gs, 1+floor(mc_cores*(1:n_g)/(n_g+1)))
		fnc = function(gs) {
						.row_stats_by_factor(us[gs,],
										mc@mc,
										function(y) {exp(rowMeans(log(1+y)))-1}) }

		clust_geomean = do.call(rbind, mclapply(g_splts, fnc, mc.cores = mc_cores))
	}
	clust_geomean = t(tgs_matrix_tapply(us[f_g_cov,], mc@mc,
									  function(y) {exp(mean(log(1+y)))-1}))
	rownames(clust_geomean) = rownames(us)[f_g_cov]

#	clust_geomean = .row_stats_by_factor(us[f_g_cov,],
#									mc@mc,
#									function(y) {exp(rowMeans(log(1+y)))-1})

	if (norm_by_mc_size) {
		mc_meansize = tapply(colSums(us), mc@mc, mean)
		ideal_cell_size = pmin(1000, median(mc_meansize))
		g_fp = t(ideal_cell_size*t(clust_geomean)/as.vector(mc_meansize))
	}
	else {
		g_fp = clust_geomean
	}
	#normalize each gene
	fp_reg = 0.1
	#0.1 is defined here because 0.1*mean_num_of_cells_in_cluster
	#is epxected to be 3-7, which means that we regulairze
	#umicount in the cluster by 3-7.
	g_fp_n = (fp_reg+g_fp)/apply(fp_reg+g_fp, 1, median)

	return(g_fp_n)
}

#' Compute metacell absolute mean umi per cell
#'
#' This compute the genometric mean of the number of umis per cells for each metacell
#'
#' @param mc a metacell object
#' @param us umi matrix
#' @param norm_by_mc_meansize normalize metacells by mean total cell umis
#' @export
mc_compute_e_gc= function(mc, us, norm_by_mc_meansize=T)
{
	f_g_cov = rowSums(us) > 10

	e_gc = t(tgs_matrix_tapply(us[f_g_cov,], mc@mc, function(y) {exp(mean(log(1+y)))-1}))
	rownames(e_gc) = rownames(us)[f_g_cov]

	if (norm_by_mc_meansize) {
		mc_meansize = tapply(colSums(us), mc@mc, mean)
		e_gc = t(t(e_gc)/as.vector(mc_meansize))
	}
	return(e_gc)
}

#' Compute fraction of non zero expressing cells per gene and mc
#'
#'
#' @param mc a metacell object
#' @param us umi matrix
#' @export
mc_compute_cov_gc= function(mc, us)
{
	f_g_cov = rowSums(us) > 10
	cov_gc = t(tgs_matrix_tapply(us[f_g_cov,], mc@mc, function(x) mean(x>0)))
	rownames(cov_gc) = rownames(us)[f_g_cov]
	return(cov_gc)
}

#' Compute distribution of cells over batches and metacell
#'
#' @param mc a metacell object
#' @param scmat scamt object (for the metadata)
#' @export
mc_compute_n_bc= function(mc, scmat)
{
	tb = table(scmat@cell_metadata[names(mc@mc), "amp_batch_id"], mc@mc)
	n_bc = matrix(tb, ncol=dim(tb)[2])
	rownames(n_bc) = dimnames(tb)[[1]]
	return(n_bc)
}

#' Update metacell annotation
#'
#' @param mc a metacell object
#' @param annot annotation vectors
#' @export
mcell_mc_add_annot = function(mc_id, annots)
{
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("MC-ERR: missing mc_id when updating annotation id = ", mc_id)
	}
	mc@annots = annots
	scdb_add_mc(mc_id, mc)
}

#' Update metacells  colors
#'
#' @param mc a metacell object
#' @param colors a vector of colors per metacell
#' @export
mcell_mc_add_color= function(mc_id, colors)
{
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("MC-ERR: missing mc_id when updating annotation id = ", mc_id)
	}
	mc@colors = colors
	scdb_add_mc(mc_id, mc)
}

#' Reorder metacell data given defined order
#'
#' @param mc metacell object
#' @param ord new order metacells
#'
#' @export

mc_reorder = function(mc, ord)
{
	if(length(ord) != ncol(mc@mc_fp)) {
		stop("MC-ERR: reordering metacells with an order vector shorter than the number of MC in the object")
	}
	ord_map = rep(NA, ncol(mc@mc_fp))
	ord_map[ord] = 1:ncol(mc@mc_fp)
	if(sum(is.na(ord_map)) > 0) {
		stop("MC-ERR: reordering metacells with an order vector lacking some of the ids - generate a new subset metacell object if this is what you wanted to do")
	}
	nms = names(mc@mc)
	mc@mc = ord_map[mc@mc]
	names(mc@mc) = nms
	mc@mc_fp = mc@mc_fp[,ord]
	colnames(mc@mc_fp) = 1:length(ord)
	mc@e_gc = mc@e_gc[,ord]
	colnames(mc@e_gc) = 1:length(ord)
	mc@cov_gc = mc@cov_gc[,ord]
	colnames(mc@cov_gc) = 1:length(ord)
	bnms = rownames(mc@n_bc)
	mc@n_bc = matrix(mc@n_bc[,ord], ncol=length(ord))	#as.matrix to avoid casting on 1 batch data
	rownames(mc@n_bc) = bnms
	colnames(mc@n_bc) = 1:length(ord)
	if(!is.null(mc@annots)) {
		mc@annots = mc@annots[ord]
		names(mc@annots) = 1:length(mc@annots)
	}
	if(!is.null(mc@colors)) {
		mc@colors = mc@colors[ord]
		names(mc@colors) = 1:length(mc@colors)
	}
	return(mc)
}

#' Reorder metacells using hierarchical clustering
#'
#' MEtacells are reorder according to their footprint similarity based on hclust and the reordering using two select antagonistic markers (that can be selected automatically)
#'
#' @param mc_id id of metacell object
#' @param gene_left gene for reordering toward the left side (null by default)
#' @param gene_right gene for reordering toward the right side (null by default)
#' @param gset_blist_id id of gene set to blacklist while ordering (e.g. cell cycle genes)
#'
#' @export

mcell_mc_reorder_hc = function(mc_id,
							gene_left = NULL, gene_right = NULL,
							gset_blist_id = NULL)
{
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("MC-ERR: missing mc_id when updating annotation id = ", mc_id)
	}
	gene_folds = mc@mc_fp

	marks = rownames(gene_folds)

	if(!is.null(gset_blist_id)) {
		blist = scdb_gset(gset_blist_id)
		if(is.null(blist)) {
			stop("MC-ERR unknown geneset id ", gset_blist_id, " when blacklisting markers for ordering metacells")
			marks = setdiff(marks, names(blist@gene_set))
		}
	}
	max_gcov = apply(mc@cov_gc[marks,],1,max)
	cov_marks = rownames(mc@cov_gc)[max_gcov > 0.25]
	if(length(intersect(marks, cov_marks)) > ncol(gene_folds)) {
		marks = intersect(marks, cov_marks)
	}

	gene_folds = gene_folds[marks,]

	good_marks = unique(as.vector(unlist(
			apply(gene_folds,
				2,
				function(x)  {
				   names(head(sort(-x[x>0.5]),n=10)) })
		     )))

	if(is.null(good_marks) | length(good_marks) < 4) {
		good_marks= rownames(gene_folds)
	}
	feat = log2(gene_folds[good_marks,])

	hc = hclust(dist(cor(feat)), "ward.D2")

	if(!is.null(gene_right) & !is.null(gene_left)) {
		if(!gene_right %in% marks | !gene_left %in% marks) {
			stop("genes for order polarization ", gene_right, " ", gene_left, " are not in markers")
		}
	}
	if(is.null(gene_right) | is.null(gene_left)) {
		g_ncover = apply(feat > 1, 1, sum)
		main_mark = names(g_ncover)[which.max(g_ncover)]
		f = feat[main_mark,] < 0.25
		if(sum(f) > 0.2*ncol(feat)) {
			g_score = apply(feat[,f]>1, 1, sum)
		} else {
			g_score = -apply(feat, 1, cor, feat[main_mark,])
		}
		second_mark = names(g_score)[which.max(g_score)]
		message("reorder on ", main_mark, " vs ", second_mark)
	}

	d = reorder(as.dendrogram(hc),
				feat[gene_right,]-feat[gene_left,],
				agglo.FUN=mean)
	hc2 = as.hclust(d)

	scdb_add_mc(mc_id, mc_reorder(mc, hc2$order))
}

#' TEst if a graph object cover all cells in the mc
#'
#' mc_id mc object
#' graph_id graph object
#'
#' @export
#'
mcell_mc_match_graph = function(mc_id, graph_id)
{
	mc = scdb_mc(mc_id)
	graph = scdb_cgraph(graph_id)
	cov = intersect(graph@cell_names, mc@cell_names)
	return(length(cov) == length(mc@cell_names))
}

#' Create a metacell object on a subset of the MCs, with all other cells becoming outliers. There is no re-normalization of mc_fp.
#'
#' @param mc metacell object
#' @param foc_mcs list of metacell to keep in the object
#'
#' @export

mc_restrict = function(mc, foc_mcs)
{
	foc_mcs = intersect(as.character(foc_mcs), as.character(1:ncol(mc@mc_fp)))
	all_nms = names(mc@mc)
	foc_nms = names(mc@mc)[mc@mc %in% foc_mcs]
	message("restrict mc from ", length(mc@mc), " to ", length(foc_nms), "cells")
	mc@outliers = union(mc@outliers, setdiff(all_nms, foc_nms))
	mc@mc = mc@mc[foc_nms]
	mc@mc_fp = mc@mc_fp[,foc_mcs]
	mc@e_gc = mc@e_gc[,foc_mcs]
	mc@cov_gc = mc@cov_gc[,foc_mcs]
	colnames(mc@n_bc) = 1:ncol(mc@n_bc)
	mc@n_bc = mc@n_bc[,foc_mcs]
	if(!is.null(mc@annots)) {
		mc@annots = mc@annots[foc_mcs]
	}
	if(!is.null(mc@colors)) {
		names(mc@colors) = 1:length(mc@colors)
		mc@colors = mc@colors[foc_mcs]
	}
	return(mc)
}

#' Splits input metacell object into sub-objects by color group, naming the new metacells <mc_id>_submc_<group>
#'
#' @param mc_id input mc object
#' @param mat_id mat object corresponsing to mc_id
#' @param min_cells_per_sub_mc minimum number of cells per group required to create a new metacell
#' @param col2grp mapping of mc colors to groups, by default, use the color_key slot
#'
#' @export
#'
mcell_mc_split_by_color_group = function(mc_id, mat_id, min_cells_per_sub_mc=500, col2grp=NULL)
{
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("MC-ERR: missing mat_id when splitting by color group = ", mat_id)
	}

	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("MC-ERR: missing mc_id when splitting by color group = ", mc_id)
	}

	if (is.null(col2grp)) {
		ucolkey =  unique(mc@color_key[, c('group', 'color')])
		col2grp = ucolkey$group
		names(col2grp) = ucolkey$color
	}

	cg = split(names(mc@mc), col2grp[mc@colors[mc@mc]])
	for (gr in names(cg)) {
		nms = cg[[gr]]
		if (length(nms) >= min_cells_per_sub_mc) {
			message(sprintf("splitting %s, creating %s_submc_%s with %d cells", mc_id, mc_id, gr, length(nms)))
			mc_map = 1:length(unique(mc@mc[nms]))
			names(mc_map) = names(table(mc@mc[nms]))

			dst_mc = mc_map[as.character(mc@mc[nms])]
			names(dst_mc) = nms

			new_id = paste(mc_id, "submc", gr, sep="_")

			mcell_mat_ignore_cells(new_id, mat_id, nms, reverse=T)
			mcell_add_gene_stat(new_id, new_id)

			mcell_new_mc(mc_id = new_id,
									 mc = dst_mc,
									 outliers = character(0), #setdiff(c(mc@outliers, names(mc@mc)), nms),
									 scmat = scdb_mat(new_id))
		}
	}
}


## Core Functions
# sourcetracker
# predict.sourcetracker
# plot.sourcetracker.fit
## Internal Functions
# run.gibbs
# tune.st    ----->    MODIFIED
# eval.fit    ----->    MODIFIED
# rarefy
# plot.sourcetracker.pie, plot.sourcetracker.bar, plot.sourcetracker.dist, sourcetracker.error.bars, plot.eval
# save.mapping.file
# sortmatrix, jsdmatrix, jsd, kld

######## MODIFIED

# modified to allow different rarefaction depth and ntrials
eval.fit.mod <- function(otus, envs, ntrials, rarefaction_depth,
             individual.samples=TRUE, verbosity=1, ...){
    train.envs <- sort(unique(envs))
    V <- length(train.envs)
    env.sizes <- table(envs)

    # make sure each pair of envs gets picked
    # build up all pairs of samples, each column is a pair
    # each source env gets to be first and second sample once
    # pairs <- expand.grid(1:V,1:V)
    # pairs <- pairs[pairs[,1]!=pairs[,2],]
    # make nreps pairs randomly
    pairs <- NULL
    for(i in 1:ntrials){
        pairs <- rbind(pairs, sample(V,size=2))
    }

    mixtures <- runif(ntrials)
    y <- matrix(0,nrow=ntrials, ncol=V+1)
    yhat <- matrix(0,nrow=ntrials, ncol=V+1)
    yhat.sd <- matrix(0,nrow=ntrials, ncol=V+1)
    colnames(y) <- c(as.character(train.envs),'Unknown')
    colnames(yhat) <- c(as.character(train.envs),'Unknown')
    newsamples <- NULL
    allenvs <- NULL
    for(i in 1:ntrials){
        env1 <- pairs[i,1]
        env2 <- pairs[i,2]
        allenvs <- rbind(allenvs, c(env1, env2))
        if(verbosity > 1){
           cat(sprintf('%d of %d: %.2f*%s + %.2f*%s: \n',i,ntrials,mixtures[i], train.envs[env1],1-mixtures[i], train.envs[env2]))
        } else if(verbosity > 0){
            cat('.')
        }

        # all indices of each environment
        env1.ix.all <- which(envs == train.envs[env1])
        env2.ix.all <- which(envs == train.envs[env2])

        if(individual.samples){
            # get one sample from each env
            # cast as list so that sample doesn't misinterpret a length-1 vector
            env1.ix <- sample(as.list(env1.ix.all),size=1)[[1]]
            env2.ix <- sample(as.list(env2.ix.all),size=1)[[1]]

            # train sourcetracker, hold out entire second env. and first env. sample
            # note: don't hold out first sample if that env has only one sample
            if(length(env1.ix.all) == 1){
                st <- sourcetracker(otus[-env2.ix.all,], envs[-env2.ix.all], rarefaction_depth=rarefaction_depth)
            } else {
                st <- sourcetracker(otus[-c(env1.ix,env2.ix.all),], envs[-c(env1.ix,env2.ix.all)], rarefaction_depth=rarefaction_depth)
            }

            # make fake sample, weighted mixture of two source samples
            s1 <- otus[env1.ix,]
            s2 <- otus[env2.ix,]

        } else {
            # train sourcetracker, hold out entire second env.
            st <- sourcetracker(otus[-env2.ix.all,], envs[-env2.ix.all], rarefaction_depth=rarefaction_depth)

            # make fake sample as mixture of _environment_ means
            s1 <- colSums(rarefy(otus[env1.ix.all,], maxdepth=rarefaction_depth))
            s2 <- colSums(rarefy(otus[env2.ix.all,], maxdepth= gv  ))
        }

        newsample <- mixtures[i] * s1/sum(s1) + (1-mixtures[i]) * s2/sum(s2)
        newsample <- round(100000 * newsample)
        newsample <- matrix(newsample, nrow=1)
        newsample <- rarefy(newsample,maxdepth=ceiling(sum(s1+s2)/2))
        newsamples <- rbind(newsamples, newsample)
        y[i,env1] <- mixtures[i]
        y[i,V+1] <- 1-mixtures[i]

        # test on fake sample
        results <- predict(st, newsample, rarefaction_depth=rarefaction_depth, verbosity=verbosity-1, ...)
        for(j in 1:ncol(results$proportions)){
            whichenv <- which(colnames(yhat) == colnames(results$proportions)[j])
            yhat[i,whichenv] <- results$proportions[,j]
            yhat.sd[i,whichenv] <- results$proportions_sd[,j]
        }
    }

    # calculate RMSE
    se <- as.numeric((y[,-V] - yhat[,-V])**2)
    mse <- mean(se)
    se.sem <- sd(se)/sqrt(length(se))
    rmse <- mse**.5
    rmse.sem <- se.sem**.5

    return(list(y=y,yhat=yhat,yhat.sd=yhat.sd,newsamples=newsamples,
            env.pairs=allenvs, train.envs=train.envs, rmse=rmse, rmse.sem=rmse.sem))
}

#modified to test multiple values of alpha1, but not alpha2 or beta priors
## also inherits eval.fit.mod to allow for precise rarefaction depth
tune.st.mod <- function(otus, envs, ntrials, rarefaction_depth,
            individual.samples=TRUE, alpha1=10**(-3:0), alpha2=1e-1,
            beta=10, verbosity=0, ...){
    results <- list()
    alphas <- expand.grid(rev(alpha1), alpha2)
    colnames(alphas) <- c('alpha1','alpha2')
    rmse <- numeric(nrow(alphas))
    rmse.sem <- numeric(nrow(alphas))
    for(i in 1:nrow(alphas)){
        cat(sprintf('Loop %d of %d, alpha1=%f, alpha2=%f ',i,nrow(alphas),alphas[i,1], alphas[i,2]))
        if(verbosity > 2) cat('\n')
        results[[i]] <- eval.fit.mod(otus, envs, ntrials, rarefaction_depth,
                                individual.samples=individual.samples,
                                alpha1=alphas[i,1], alpha2=alphas[i,2], beta=beta, verbosity=verbosity-1, ...)
        rmse[i] <- results[[i]]$rmse
        rmse.sem[i] <- results[[i]]$rmse.sem
        if(verbosity > 0) cat(sprintf('RMSE = %.3f +/- %.3f\n',rmse[i], rmse.sem[i]))
    }
    ## choose alpha as most conservative value of alpha2 (smallest)
    ## then most conservative value of alpha1 (largest)
    ## that gives pseudo-r2 within 1 sem of the max.
    # best.ix <- min(which(rmse <= min(rmse + rmse.sem)))
    ## Alternative: simply choose the lowest rmse
    best.ix <- which.min(rmse)
    best.rmse <- rmse[best.ix]
    best.alpha1 <- alphas[best.ix,1]
    best.alpha2 <- alphas[best.ix,2]
    return(list(alphas=alphas, rmse=rmse, rmse.sem=rmse.sem, best.rmse=best.rmse,
                best.alpha1=best.alpha1, best.alpha2=best.alpha2,
                results=results))
}


convert.marport.sds_csv2netmind = function( fnroot = NULL, yr, redo.marport_conversion = F ) {
  fn_marport_proc = file.path(project.datadirectory(),"bio.snowcrab", "data", "marport", paste("marport_proc_", yr, ".RDATA", sep = ""))
  if(redo.marport_conversion){

    con = file(fnroot, "r")
    line = readLines(con, n = -1)
    ind = grep("GPRMC", line)
    inda = grep("192.168", line)
    indb = grep("RAW", line)
    indc = intersect(inda, indb)
    indall = sort(c(indc, ind))
    lines = line[indall]
    close(con)
    depth = ""
    wing = ""
    height = ""
    pitch = ""
    roll = ""
    temp = ""

    marport = data.table::data.table()
    for(i in 1:length(lines)) {
      print(i)
      lin = lines[i]
      lin = gsub(";", ",", lin)

      if(grepl("GPRMC", lin)){
        gps = unlist(strsplit(lin, ","))[c(1, 3, 5, 7, 9, 11)]
        marport = rbind(marport, cbind(gps[1], gps[6], gps[2], gps[3], gps[4], gps[5], height, NA, wing, depth, temp))
        depth = NA
        wing = NA
        height = NA
        pitch = NA
        roll = NA
        temp = NA
      }
      if(grepl("DEPTH", lin)){
        depth = unlist(strsplit(lin, ","))[5]
      }
      if(grepl("DISTANCE", lin)){
        wing = unlist(strsplit(lin, ","))[5]
      }
      if(grepl("ROLL", lin)){
        roll = unlist(strsplit(lin, ","))[5]
      }
      if(grepl("PITCH", lin)){
        pitch = unlist(strsplit(lin, ","))[5]
      }
      if(grepl("TEMPERATURE", lin)){
        temp = unlist(strsplit(lin, ","))[5]
      }
      if(grepl("SENSORDTB", lin)){
        height = unlist(strsplit(lin, ","))[5]
      }

    }

    names(marport) = c("localtime", "Date",	"Time",	"Latitude",	"Longitude",	"Speed",	"Primary",	"Secondary",	"DoorSpread",	"Depth",	"Temperature")

    marport$localtime = lubridate::as_datetime(as.numeric(marport$localtime)/86400000 + lubridate::as_date("1970/01/01"), tz = "UTC")
    marport$localtime = lubridate::with_tz(marport$localtime, "America/Halifax")
    marport = tidyr::separate(data = marport, col = "Latitude", into = c('latdeg', 'latmin'), sep = 2, remove = F)
    marport = tidyr::separate(data = marport, col = "Longitude", into = c('londeg', 'lonmin'), sep = 3, remove = F)
    marport$lat = as.numeric(marport$latdeg) + as.numeric(marport$latmin)/60
    marport$lon = (as.numeric(marport$londeg) + as.numeric(marport$lonmin)/60)*-1

    save(marport, file =  fn_marport_proc)
  }
  load(fn_marport_proc)

  fn_netmind_arc = file.path(project.datadirectory(),"bio.snowcrab", "data", "netmind", "archive", yr)
  if(!dir.exists(fn_netmind_arc)){
    dir.create(fn_netmind_arc)
  }
  fl = list.files(fn_netmind_arc)
  set = snowcrab.db( DS="setInitial" )
  set = set[which(set$yr == yr),]

  set$station[which(nchar(set$station) == 1)] = paste("00", set$station[which(nchar(set$station) == 1)], sep = "")
  set$station[which(nchar(set$station) == 2)] = paste("0", set$station[which(nchar(set$station) == 2)], sep = "")
  missing.set = set[which(!paste("ep", set$station, ".txt", sep = "") %in% fl),]
  missing.set = missing.set[order(missing.set$timestamp),]

  for(i in 1:nrow(missing.set)){
    curset = missing.set[i,]
     if(curset$trip == "S06102021" && curset$station == "130") curset$station = "305"
    sind = which(geosphere::distm(c(curset$lon, curset$lat),cbind(marport$lon, marport$lat), fun = distHaversine) < 2000)
    if(length(sind) == 0){
      warning(paste("Could Not find Marport data for station: ", curset$station, sep = ""))
      next()
    }
    start = min(sind)
    end = max(which(geosphere::distm(c(curset$lon1, curset$lat1),cbind(marport$lon, marport$lat), fun = distHaversine) < 2000))
    marsub = marport[start:end,]

    range = which((abs(dmy_hms(paste(marsub$Date, marsub$Time, sep = " ")) - curset$timestamp)) < minutes(15))
    marsub = marsub[range,]

    if(nrow(marsub) < 10){
      warning(paste("Could Not find Marport data for station: ", curset$station, sep = ""))
      next()
    }

    header =  paste("FileName: ",yr, "SnowCrabSurvey ep", curset$station, ".txt \nLocal Time: ", format(marsub$localtime[1], format = "%a %b %d  %H:%M:%S %Y"),"\nShip:  Trip: ", curset$trip, "  Tow:  ", curset$set, "\nComments: ", sep = "")

    marsub$Latitude = paste(marsub$latdeg, marsub$latmin, "N", sep = " ")
    marsub$Longitude = paste(marsub$londeg, marsub$lonmin, "W", sep = " ")
    marsub$Date = format(dmy(marsub$Date), format = "%y%m%d")

    marsub$localtime = NULL
    marsub$latdeg = NULL
    marsub$latmin = NULL
    marsub$londeg = NULL
    marsub$lonmin = NULL
    marsub$lat = NULL
    marsub$lon = NULL

    file = file.path(project.datadirectory(),"bio.snowcrab", "data", "netmind", "archive", yr, paste("ep", curset$station, ".txt", sep = ""))

    cat(header, '\n',  file = file)
    suppressWarnings(write.table(marsub, file, append = T, quote = F, row.names = F, col.names = T, sep = "  "))

  }

}

load.marport.rawdata = function( fnroot, fncfg ) {

  require(lubridate)
  if (FALSE) {
    fncfg=sensorconfig
    fnroot=fl
  }

# fn="/home/jae/Downloads/net/Alfred\ Needler-Ned_2013_002-045"
  # cfgfn = "/home/jae/Downloads/net/Config_Old.txt"

  sensorcodes = as.data.frame( matrix(
    c( "01PIT", "PitchDoorPort",
       "02PIT", "PitchDoorStar",
       "03PIT", "PitchWingPort",
       "01ROL", "RollDoorPort",
       "02ROL", "RollDoorStar",
       "03ROL", "RollWingPort",
       "02TMP", "TempDoorStar",
       "03TMP", "TempWingPort",
       "04TMP", "TempWingStar",
       "01DPT", "DepthDoorPort",
       "02DPT", "DepthDoorStar",
       "03DPT", "DepthWingPort",
       "04DPT", "DepthWingStar",
       "05DPT", "DepthScanmar",
       "01DST", "doorspread",
       "03DST", "wingspread",
       "03HGT", "opening",
       "06HGT", "opening.scanmar"
    ), ncol=2,  byrow=TRUE),  stringsAsFactors =FALSE )
  colnames(sensorcodes) = c("sensorcode", "variablename")

  cfg = parse.marport.config( fncfg )

  header = cfg[ which( is.na( cfg$units)) , ]
  bottom = cfg[ which( !is.na( cfg$units)), ]

  lookuptable = merge( sensorcodes, bottom, by.x="sensorcode", by.y="variable", all.x=TRUE, all.y=TRUE)
  names( header) = c( "sensorid", "sensorcode", "units")
  header$variablename=NA

  cfg = rbind( header, lookuptable[,names(header)] )

  fn.gps = paste(fnroot, "gps", sep=".")
  fn.sgp = paste(fnroot, "sgp", sep=".")
  fn.dlog =  paste(fnroot, "log", sep=".")

  if (!( file.exists(fn.gps) & file.exists(fn.sgp) & file.exists(fn.dlog) ) ) return(NULL)

  gps = read.table( fn.gps, sep=",", as.is=TRUE, header=FALSE )
  names(gps) = c("Vessel", "Cruise", "set", "timestamp", "latitude", "longitude" )

  sgp = read.table( fn.sgp, sep=",", as.is=TRUE, header=FALSE )
  names(sgp) = c("Vessel", "Cruise", "set",  "timestamp", "sensor", "value" )

  dlog = read.table( fn.dlog, sep=",", as.is=TRUE, header=FALSE )
  names(dlog) =  c("Vessel", "Cruise", "set", "timestamp", "event" )

  sgp = sgp[ , c( "timestamp", "sensor", "value" ) ]
  sgp$sensor = as.character( sgp$sensor)

  marport = gps
  vnames1 = names(gps)
  newvnames = cfg$variablename[ which(!is.na(cfg$variablename))]
  outputvnames = c(vnames1, newvnames )

  for (i in 1:nrow(cfg)) {
    if ( is.na( cfg$variablename[i])) next()
    if ( is.na( cfg$sensorid[i])) {
      marport[[cfg$variablename[i]]] = NA
      marport[[cfg$variablename[i]]] = as.numeric( marport[[cfg$variablename[i]]])
      next()
    }
    matchingsensordata = which( sgp$sensor == cfg$sensorid[i] )
    if (length(matchingsensordata)==0) {
      marport[[cfg$variablename[i]]] = NA
      marport[[cfg$variablename[i]]] = as.numeric( marport[[cfg$variablename[i]]])
      next()
    }
    sdata = NULL
    sdata = sgp[ matchingsensordata ,]
    newvariablename = cfg$variablename[i]
    names(sdata) = c( "timestamp", "sensor", newvariablename )
    marport = merge( marport, sdata[,c("timestamp",newvariablename)], by="timestamp", all.x=TRUE, all.y=FALSE )
  }

  marport = marport[, outputvnames]
  marportId = paste( marport$Vessel, marport$Cruise, marport$set )

  tzone="America/Halifax"
  marport$timestamp = mdy_hms( marport$timestamp, tz=tzone ) ## need to check if mdy or dmy ...
  dlog$timestamp = mdy_hms(dlog$timestamp, tz=tzone )

  # convert to internal TZ
  marport$timestamp = with_tz(marport$timestamp, "UTC")
  dlog$timestamp = with_tz(dlog$timestamp, "UTC" )

    threshold.seconds = 1*60*60 # 1hr in seconds
    nmids = unique( marportId )
    for (ii in nmids) {
      jj = which( marportId == ii)
      tstamp = marport$timestamp[jj]
      r = range(tstamp, na.rm=TRUE)
      y = as.numeric( difftime(r[2], r[1]), units="secs")  # in seconds

      if ( y > threshold.seconds ) { # as duration is in seconds
        # if there is a timestamp problem, the problematic records are those with hour values that are soon after midnight
        # .. assume any values from midnight to 2 AM need to be recoded to the next day's value
        hrs = hour( tstamp )
        z = which( hrs < 2 )  # 2AM is the cutoff
        if ( length(z) > 0 ) {
          day( tstamp[z]) = day( tstamp[z])+1
        }
        marport$timestamp[jj] = tstamp
      }
    }

  return(marport)
}


library(dplyr)
library(readr)
library(tidyr)
library(caret)
library(caretEnsemble)

best_model_path <- './models/C5.0_full.rds'

data_pred <- read.csv('./data/processed/processed_pred.csv')
data_clean <- read.csv('./data/clean/clean_train_predict.csv')

# combining the train data
data <- bind_rows(data_train, data_test)

# splitting the cleaned data
data_clean_missing <- filter(data_clean, predict == 1)
data_clean_nomissing <- filter(data_clean, predict == 0)

# Loading the model
best_model <- readRDS(best_model_path)

best_predictions <-
    predict(best_model, newdata = data_pred)

data_clean_missing$brand = best_predictions
data_fixed <- bind_rows(data_clean_missing, data_clean_nomissing)
write.csv(data_fixed, file='./data/fixed/data_nomissing.csv', row.names = FALSE)

# Saving also the pure predictions in a csv
best_bredictions_df <- as.data.frame(best_predictions)
colnames(best_bredictions_df) <- 'prediction'
write.csv(best_predictions, file='./data/fixed/just_predictions.csv', row.names = FALSE)


# Define the palette
bins <- c(0, 10, 20, 50, 100, 200, 500, 1000, Inf)
bins2 <- c(2000, 10000, 100000, 300000, 500000, 700000, 1000000, 1500000, Inf)
pal_ecoR <- colorBin("YlOrRd", domain = shape_eco$Shape_Area, bins = bins)
pal_ICES_areas <- colorBin("YlOrRd", domain = ices_areas$Area_km2, bins = bins2)

# Define the interactive labels
labels_ecoR <- sprintf(
    "%s Ecoregion
%g Shape Area ",
    shape_eco$Ecoregion, shape_eco$Shape_Area
) %>% lapply(htmltools::HTML)

# Define interactive labels for iceas areas
labels_ices_areas <- sprintf(
    "%s ICES area
%g Shape Area ",
    ices_areas$Area_Full, ices_areas$Area_km2
) %>% lapply(htmltools::HTML)

## Map plot (this function has iceas ecor R and iceas areas as separate layers)
map_plot <- function(shape_eco, eu_shape, ices_areas, labels_ecoR, labels_ices_areas) {
    leaflet(options = leafletOptions(crs = crs_laea, minZoom = minZoom, maxZoom = maxZoom)) %>%
        # addProviderTiles("Stamen.Toner") %>%
        addPolygons(
            data = shape_eco,
            color = "#444444",
            weight = 1,
            smoothFactor = 0.5,
            opacity = 0.5,
            fillOpacity = 0.5,
            fillColor = ~ pal_ecoR(shape_eco$Shape_Area),
            group = "ICES Ecoregions",
            layerId = ~uid, # unique id for polygons
            highlightOptions = highlightOptions(
                color = "white", weight = 3,
                bringToFront = TRUE
            ),
            label = labels_ecoR,
            labelOptions = labelOptions(
                style = list("font-weight" = "normal", padding = "3px 8px"),
                textsize = "15px",
                direction = "auto"
            )
        ) %>%
        addPolygons(
            data = eu_shape,
            color = "black",
            weight = 1,
            smoothFactor = 0.5,
            opacity = 0.7,
            fillOpacity = 0.5,
            fillColor = "grey",
            group = "Europe"
        ) %>%
        addPolygons(
            data = ices_areas,
            color = "black",
            weight = 1,
            smoothFactor = 0.5,
            opacity = 0.5,
            fillOpacity = 0.5,
            fillColor = ~ pal_ICES_areas(ices_areas$Area_km2),
            group = "ICES Areas",
            layerId = ~OBJECTID, # unique id for polygons
            highlightOptions = highlightOptions(
                color = "#ffffff", weight = 3,
                bringToFront = TRUE
            ),
            label = labels_ices_areas,
            labelOptions = labelOptions(
                style = list("font-weight" = "normal", padding = "3px 8px"),
                textsize = "15px",
                direction = "auto"
            )
        ) %>%
        setView(lng = -1.235660, lat = 60.346958, zoom = 0.5) %>%
        addLayersControl(
            baseGroups = c("ICES Ecoregions", "ICES Areas"),
            # overlayGroups =c(),
            options = layersControlOptions(collapsed = FALSE)
        )
}
# map_plot(shape_eco, eu_shape, ices_areas, labels_ecoR, labels_ices_areas)

## this second map function has only ecoregion, the map will be the updated using proxy,
## the colors are simpler also
map_plot_simple <- function(shape_eco, eu_shape){
    leaflet(options = leafletOptions(crs = crs_laea, minZoom = minZoom, maxZoom = maxZoom)) %>%
    addTiles() %>%
        addPolygons(
            data = shape_eco,
            fillColor = "white",
            fillOpacity = 0.5,
            color = "black",
            stroke = TRUE,
            weight = 1,
            group = "Eco_regions",
            layerId = ~Ecoregion, # unique id for polygons
            highlightOptions = highlightOptions(
                color = "black", weight = 3,
                bringToFront = TRUE
            ),
            label = ~Ecoregion,
            labelOptions = labelOptions(
                style = list("font-weight" = "normal", padding = "3px 8px"),
                textsize = "15px",
                direction = "auto"
            )  %>%
            addPolygons(
            data = shape_eco,
            fillColor = "red",
            fillOpacity = 0.5,
            color = "black",
            stroke = TRUE,
            weight = 1,
            layerId = ~OBJECTID,
            group = ~Ecoregion),
            highlightOptions = highlightOptions(
                color = "black", weight = 3,
                bringToFront = TRUE
            ),
            label = ~Ecoregion,
            labelOptions = labelOptions(
                style = list("font-weight" = "normal", padding = "3px 8px"),
                textsize = "15px",
                direction = "auto"
            )  %>%
            hideGroup(group = shape_eco$Ecoregion)

        ) %>%
        addPolygons(
            data = eu_shape,
            color = "black",
            weight = 1,
            fillOpacity = 0.5,
            fillColor = "grey",
            group = "Europe"
        ) %>%
        setView(lng = -1.235660, lat = 60.346958, zoom = 0.5)
}

map_ecoregion <- function(shape_eco, eu_shape) {
    leaflet(options = leafletOptions(crs = crs_laea, minZoom = minZoom, maxZoom = maxZoom)) %>%
                # addTiles() %>%
                addPolygons(
                    data = eu_shape,
                    color = "black",
                    weight = 1,
                    fillOpacity = 0.2,
                    fillColor = "#fddfc2",
                    group = "Europe"
                ) %>%
                addPolygons(
                    data = shape_eco,
                    fillColor = "white",
                    fillOpacity = 0.5,
                    color = "black",
                    stroke = TRUE,
                    weight = 1,
                    layerId = ~Ecoregion,
                    group = "Eco_regions",
                    label = ~Ecoregion
                ) %>%
                addPolygons(
                    data = shape_eco,
                    fillColor = "red",
                    fillOpacity = 0.5,
                    weight = 1,
                    color = "black",
                    stroke = TRUE,
                    layerId = ~OBJECTID,
                    group = ~Ecoregion
                ) %>%
                setView(lng = -1.235660, lat = 60.346958, zoom = 0.5) %>%
                hideGroup(group = shape_eco$Ecoregion)
}

map_ices_areas <- function(ices_areas, eu_shape) {
    leaflet(options = leafletOptions(crs = crs_laea, minZoom = minZoom, maxZoom = maxZoom)) %>%
                addPolygons(
                    data = eu_shape,
                    color = "black",
                    weight = 1,
                    fillOpacity = 0.2,
                    fillColor = "#fddfc2",
                    group = "Europe"
                ) %>%
                addPolygons(
                    data = ices_areas,
                    fillColor = "white",
                    fillOpacity = 0.5,
                    color = "black",
                    stroke = TRUE,
                    weight = 1,
                    layerId = ~Area_Full,
                    group = "ices_areas",
                    label = ~Area_Full
                ) %>%
                addPolygons(
                    data = ices_areas,
                    fillColor = "red",
                    fillOpacity = 0.5,
                    weight = 1,
                    color = "black",
                    stroke = TRUE,
                    layerId = ~OBJECTID,
                    group = ~Area_Full
                ) %>%
                setView(lng = -1.235660, lat = 60.346958, zoom = 0.5) %>%
                hideGroup(group = ices_areas$Area_Full)
}


library("R.utils")
library("AnnotationHub")
library("Rsamtools")
library("GenomicFeatures")
library("GenomicRanges")
library("Rsubread")
library("limma")
library("edgeR")
library("DESeq2")
library("GenomicAlignments")
library("BiocParallel")
library("AnnotationDbi")
library("ggplot2")
library("Gviz")
library("biomaRt")
library("pheatmap")
library("RColorBrewer")
library("reshape2")
library("dplyr")
library("genefilter")

wd = "~/work/abe516-project2"
fig.dir = file.path(wd, "figures")
if (!dir.exists(fig.dir)) {
  dir.create(fig.dir)
}

filenames = dir(path = file.path(wd, "stage4_bamfiles"), pattern = "bam", full.names = T)
printf("Found %s BAM files\n", length(filenames))
stage4.samples = read.csv(file.path(wd, "stage4_samples.csv"), header = F)
colnames(stage4.samples) = c("SampleName", "trt")

gtf.file = file.path(wd, "sorghum.gtf")
txdb = makeTxDbFromGFF(gtf.file, format = "gtf", circ_seqs = character())
ebg = exonsBy(txdb, by = "gene")

# this function helps to prepare data if we have more filenames and sample tables
dataprepare = function(filenames, sample.table) {
  bam.files = BamFileList(filenames)
  se = summarizeOverlaps(features = ebg, reads = bam.files, mode = "Union", singleEnd = TRUE)
  colData(se) <- DataFrame(sample.table)
  return(se)
}

se = dataprepare(filenames = filenames, sample.table = stage4.samples)
se
dim(se)
assayNames(se)
head(assay(se))
colSums(assay(se))

se$trt
countdata = assay(se)
head(countdata)
coldata = colData(se)

dds = DESeqDataSet(se, design = ~trt)
nrow(dds)
dds = dds[rowSums(counts(dds)) > 1, ]  ### pre-filtering
nrow(dds)

# PCA
rld = rlog(dds, blind = FALSE)  ## transform data to log2 scale
pcdata = plotPCA(rld, intgroup = "trt", returnData = TRUE)
percentVar = round(100 * attr(pcdata, "percentVar"))

pca.plot = ggplot(pcdata, aes(PC1, PC2, color = trt, shape = trt)) +
  ggtitle("Stage4") +
  geom_point(size = 3) +
  xlab(paste0("PC1: ", percentVar[1], "% variance")) +
  ylab(paste0("PC2: ", percentVar[2], "% variance"))

ggsave(file = file.path(fig.dir, "pca.png"), width = 5, height = 5, plot = pca.plot)

# Heatmap
sampleDists <- dist(t(assay(rld)))
sampleDistMatrix <- as.matrix(sampleDists)
rownames(sampleDistMatrix) <- rld$trt
colnames(sampleDistMatrix) <- NULL
colors <- colorRampPalette( rev(brewer.pal(9, "Blues")) )(255)
pheatmap(sampleDistMatrix,
         main = "Sample Distances",
         filename = file.path(fig.dir, "heatmap.png"),
         clustering_distance_rows = sampleDists,
         clustering_distance_cols = sampleDists,
         col = colors)

# MDS plot
mds = as.data.frame(colData(rld)) %>% cbind(cmdscale(sampleDistMatrix))
mds.plot = ggplot(mds, aes(x = `1`, y = `2`, color = trt, shape = trt)) +
  ggtitle("MDS Plot") + geom_point(size = 3) + coord_fixed() + theme_light()
ggsave(file = file.path(fig.dir, "mds.png"), plot = mds.plot)

# Dendrogram
dist.matrix = as.dist(1 - sampleDistMatrix)
fit = hclust(dist.matrix, method = "ward.D2")
dg = ggdendro::ggdendrogram(fit, rotate=T) + ggtitle("Dendrogram")
ggsave(file = file.path(fig.dir, "dendrogram.png"), width = 5, height = 5, plot = dg)

# Gene clustering
topVarGenes = head(order(rowVars(assay(rld)), decreasing = TRUE), 25)
mat  = assay(rld)[ topVarGenes, ]
mat  = mat - rowMeans(mat)
colnames(mat) = rld$trt
pheatmap(mat, main="Gene Clusters", filename = file.path(fig.dir, "gene_clusters.png"))

# Plot GO functions
go = read.csv(file = file.path(wd, "go.csv"), header = T)
go.terms = unlist(strsplit(as.character(go$GO.term.name), ', ', fixed = T))
go.summary = as.data.frame(table(go.terms))
colnames(go.summary) = c("func", "freq")
go.summary$func = factor(go.summary$func,
                         levels = go.summary$func[order(go.summary$freq)])
go.plot = ggplot(data = go.summary, aes(x=func, y=freq)) + xlab(element_blank()) +
  geom_bar(stat="identity", fill="#56B4E9", colour="black") + theme_light() + coord_flip()
ggsave(file = file.path(fig.dir, "go.png"), width = 5, height = 6, plot = go.plot)

dds = DESeq(dds)
res = results(dds)
mcols(res, use.names = TRUE)
summary(res)

resLFC1 = results(dds, lfcThreshold = 1)
table(resLFC1$padj < 0.1)

sum(res$padj < 0.05, na.rm = TRUE)

resSig = subset(res, padj < 0.05)
head(resSig[order(resSig$log2FoldChange), ])

resSig = resSig[order(resSig$log2FoldChange, decreasing = TRUE), ]
write.csv(resSig, file = file.path(wd, "gene_list.csv"))

# Create plots for the top 10 genes
for (i in 1:10) {
  gene.name = rownames(resSig)[i]
  printf("%s: Creating plot for '%s'\n", i, gene.name)
  d = plotCounts(dds,
                 gene = gene.name,
                 intgroup = c("trt"),
                 returnData=TRUE)
  p = ggplot(d, aes(x = trt, y = count, color = trt, shape = trt)) +
    ggtitle(gene.name) + theme_light() +
    geom_point(position = position_jitter(w = 0.1, h = 0))
  filename = file.path(fig.dir,
                       paste0(paste("top", sprintf("%02d", i), gene.name, sep="_"), ".png"))
  ggsave(file = filename, width = 5, height = 5, plot = p)
}

# MAplot
png(filename = file.path(fig.dir, "ma_plot.png"))
plotMA(res, ylim = c(-3, 3), main = "MA Plot")
invisible(dev.off())

# plotmalabel
plotMA(resLFC1, ylim = c(-3, 3))
topGene = rownames(resLFC1)[which.min(resLFC1$padj)]
with(resLFC1[topGene, ], {
  printf("%s\n", baseMean)
  printf("%s\n", log2FoldChange)
  points(baseMean, log2FoldChange, col = "dodgerblue", cex = 2, lwd = 2)
  text(baseMean, log2FoldChange, topGene, pos = 2, col = "dodgerblue")
})


require(hash)

# Name of Mongo File
aaIndexMongoFile <- "AAIndicesForMongo.json"

############################################################
##########       Read in Raw Index Data      ###############
############################################################

nameOfIndexFile <- "index_data_544.txt"
fileLocation <- "/Users/mercer/p4/data/"

con <- file(paste(fileLocation,nameOfIndexFile,sep=""), 'r')
indexData <- readLines(con)
close(con)

############################################################
#####     Now Read in Previous Assigned Classes  ###########
############################################################

#alpha
nameOfFile <-  paste(fileLocation,"alpha_and_turn_propensities_from402.csv",sep="")
savedAlpha <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE)

# beta
nameOfFile <-  paste(fileLocation,"beta_propensities_from402.csv",sep="")
savedBeta <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE)

# composition
nameOfFile <-  paste(fileLocation,"composition_from402.csv",sep="")
savedComposition <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE)

# hydro
nameOfFile <-  paste(fileLocation,"hydrophobicity_from402.csv",sep="")
savedHydro <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE)

#other

nameOfFile <-  paste(fileLocation,"other_properties_from402.csv",sep="")
savedOther <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE)

#physico
nameOfFile <-  paste(fileLocation,"physicochemical_from402.csv",sep="")
savedPhysico <- read.delim(nameOfFile,stringsAsFactors=FALSE, header = TRUE)

#new 142
nameOfFile <-  paste(fileLocation,"new_indices_142_in_csv_format.csv",sep="")
savedNew <- read.delim(nameOfFile,stringsAsFactors=FALSE, sep=",",header = TRUE)

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

renameClass <- function(class){

  if(class == "alpha and turn"){
    return ("Alpha & Turn Propensity")
  }
  if(class == "composition"){
    return ("Composition")
  }
  if(class == "other"){
    return ("Other")
  }
  if(class == "beta"){
    return ("Beta Sheet Propensity")
  }
  if(class=="Hydrophobicity"){
    return (class)
  }

}

getClass <- function(accession){

  if(accession %in% unlist(savedAlpha)){
    return ("Alpha & Turn Propensity")
  }

  if(accession %in% unlist(savedPhysico)){
    return ("Physico-Chemical Properties")
  }

  if(accession %in% unlist(savedBeta)){
    return ("Beta Sheet Propensity")
  }

  if(accession %in% unlist(savedComposition)){
    return ("Composition")
  }

  if(accession %in% unlist(savedHydro)){
    return ("Hydrophobicity")
  }

  if(accession %in% unlist(savedOther)){
    return ("Other")
  }

  if(accession %in% unlist(savedNew$ID)){
    getRow <- savedNew[which(savedNew$ID==accession),]
    return (renameClass(getRow$index_category))
  }

  return ("Other")
}

#H ANDN920101
#D alpha-CH chemical shifts (Andersen et al., 1992)
#R LIT:1810048b PMID:1575719
#A Andersen, N.H., Cao, B. and Chen, C.
#T Peptide/protein structure analysis using the chemical shift index method:
#  upfield alpha-CH values reveal dynamic helices and aL sites
#J Biochem. and Biophys. Res. Comm. 184, 1008-1014 (1992)
#C BUNA790102    0.949
#I    A/L     R/K     N/M     D/F     C/P     Q/S     E/T     G/W     H/Y     I/V
#4.35    4.38    4.75    4.76    4.65    4.37    4.29    3.97    4.63    3.95
#4.17    4.36    4.52    4.66    4.44    4.50    4.35    4.70    4.60    3.95
#//
#"AVBF000102" is an example of NAs

AAIndex <<- setClass("AAIndex",representation(accession = "character",
                                              description = "character",
                                              category = "character",
                                              indices = "numeric"))

indexHash <- hash()
for(index in 1:(length(indexData)-12)){

  #print(paste("index: ",index,sep=""))
  element <- indexData[index]
  if (substr(element,1,1) == 'H'){

    accession <- gsub("(^ +)|( +$)", "",substr(element,2,nchar(element)))

    lookAheadIndex <- 1
    while(indexData[index+lookAheadIndex] != "//"){

      #print(paste("lookAheadIndex: ",lookAheadIndex,sep=""))
      if(substr(indexData[index+lookAheadIndex],1,1) == "D"){
        description <- trim(substr(indexData[index+lookAheadIndex],2,nchar(indexData[index+lookAheadIndex])))
        description <- gsub("\"","",description) #correct the escaped quotations
      }

      if(substr(indexData[index+lookAheadIndex],1,1) == "I"){

          firstRow <- indexData[index+lookAheadIndex+1]
          secondRow <- indexData[index+lookAheadIndex+2]

          #trim trailing and leading spaces first
          firstRow <- trim(firstRow)
          secondRow <- trim(secondRow)

          #compress white space
          firstRow <- gsub("\\s+"," ",firstRow)
          secondRow <- gsub("\\s+"," ",secondRow)

          #remove NAs
          firstRow <- gsub("NA","0.0",firstRow)
          secondRow <- gsub("NA","0.0",secondRow)

          splitFirstRow <- unlist(strsplit(firstRow," "))
          splitSecondRow <- unlist(strsplit(secondRow," "))

          indices <- append(as.numeric(splitFirstRow), as.numeric(splitSecondRow))
          category <- getClass(accession)

          aai <- AAIndex(accession = accession,
                        description = description,
                        indices = indices,
                        category = category)

          .set(indexHash,accession, aai)
          break
      }

      lookAheadIndex <- lookAheadIndex + 1
    }
  }
}

setwd(fileLocation)
sink(aaIndexMongoFile)

accessions <- keys(indexHash)

#indexHash[["AURR980118"]]
aaIndexIndex <- 1
for (accession in accessions){

    thisObj <- indexHash[[accession]]

    indexElements <- "["
    for(ie in 1:length(thisObj@indices)){
      if(ie==20){
        indexElements <- paste(indexElements, thisObj@indices[ie],"]",sep="")
      }else{
        indexElements <- paste(indexElements, thisObj@indices[ie],",",sep="")
      }

    }

    thisIndex <- paste(    '{ "accession": ', paste('"',thisObj@accession,'"',sep=""),
                            ',"description": ', paste('"',thisObj@description,'"',sep=""),
                            ',"category": ',paste('"',thisObj@category,'"',sep=""),
                            ',"indices": ',indexElements,
                            ',"aaIndexIndex": ',aaIndexIndex,
                            '}', sep="" )

    cat(thisIndex)
    cat('\n')

    aaIndexIndex <- aaIndexIndex + 1
}

sink()

#./mongoimport -d mu8 -c AAInidices --file /Users/mercer/p4/data/AAIndicesForMongo.json


import_package('dplyr', attach=TRUE)
bin_reads = import('./bin_reads')$bin_reads
blacklist_from_ref = import('./blacklist_from_ref')$blacklist_from_ref
seq = import('../../seq')

#' Run aneufinder with clean output structure
#'
#' Does not support strandseq so far
#'
#' @param files          Character vector of BAM or BED files, or directory
#' @param assembly       Character string identifying the assembly; e.g.
#'                       GRCh38, mm10, etc.; sequence lengths derived from that
#' @param chromosomes    Restrict analysis to the following chromosomes
#' @param blacklist      BED file name with blacklisted regions, BAM file with
#'   reads to derive blacklist from, or NULL if no blacklist
#' @param binsize        Average bin size for reads
#' @param correction     "GC", "mappability" or both in a vector
#' @param states         Max number of chromosome copies to model
#' @param min_segment_size  Minimum number of bins for a copy segment to span
#' @param bin_width_ref  Reference BAM file for creating variable width bins
#'   value can either be NULL (fixed bins) or a path to a file to use for reference
#' @param method         Aneufinder method: "edivisive", "HMM" or "dnacopy"
#' @param ...            Additional parameters passed to 'findCNVs'
#' @param cores          Number of cores to use for parallel processing
#' @return               A list of models, one for each input file
run = function(files, assembly, chromosomes=NULL, blacklist=NULL,
               binsize=1e6, correction="GC", states=10, min_segment_size=10,
               mappability_reference=NULL, paired_reads=FALSE,
               duplicate_reads=FALSE, min_mapq=10, max_time=-1, n_trials=15,
               bin_width_ref=NULL, method="edivisive", ..., cores=1L) {

    stopifnot(length(files) >= 1)
    stopifnot(length(binsize) == 1) # change [[1]] below if removing

    if (length(files) == 1 && file.info(files)[1,"isdir"])
        files = list.files(files, pattern="\\.(bam|bed)(\\.gz)?$",
                           full.names=TRUE)

    # get assembly information
    genome = seq$genome(assembly)
    chr_lengths = seq$chr_lengths(genome)
    if (is.null(chromosomes))
        chromosomes = names(chr_lengths)

    # partition the reads into bins
    if (!is.null(bin_width_ref)) {
        ref_reads = seq$read_granges(bin_width_ref, assembly=genome)

        if (!is.null(blacklist) && grepl("\\.bam$", blacklist))
            blacklist = blacklist_from_ref(ref_reads, chr_lengths,
                                           chromosomes=chromosomes)

        bins = AneuFinder::variableWidthBins(ref_reads, binsizes=binsize,
            chromosomes = chromosomes)[[1]]
    } else
        bins = AneuFinder::fixedWidthBins(chromosomes = chromosomes,
            chrom.lengths = chr_lengths, binsizes = binsize)[[1]]

    # load BAM or BED files to granges objects
    reads = seq$read_granges(as.list(files), chromosomes=chromosomes,
                             pairedEndReads=paired_reads, assembly=genome,
                             remove.duplicate.reads=!duplicate_reads,
                             min.mapq=min_mapq, blacklist=blacklist)

    binned_reads = mapply(bin_reads, reads=reads, id=basename(files),
                          MoreArgs = list(bins=bins, min_mapq=min_mapq))

    # gc or mappability correction #TODO: preserve order
    if ("GC" %in% correction) {
        binned_reads = AneuFinder::correctGC(binned_reads, GC.BSgenome=genome,
                                             same.binsize=TRUE)
    }
    if ("mappability" %in% correction)
        binned_reads = AneuFinder::correctMappability(binned_reads,
            is.null(bin_width_ref), mappability_reference, chr_lengths)

    # run HMM/dnacopy
    do_fit = function(br) {
        m = try(AneuFinder::findCNVs(br,
            eps = 0.1,
#            min.segment.size = min_segment_size, # not a parameter for aneuf pkg
            max.time = max_time,
            max.iter = 5000,
            num.trials = n_trials,
            states = c("zero-inflation", sprintf("%i-somy", 0:states)),
            most.frequent.state = "2-somy",
            method = method,
            ...))
        if (class(m$segments) == "GRanges") {
            idx = unique(as.character(GenomeInfoDb::seqnames(m$segments)))
            GenomeInfoDb::seqinfo(m$segments) = GenomeInfoDb::seqinfo(genome)[idx]
        }
        m
    }
    if (cores == 1L) {
        lapply(binned_reads, do_fit)
    } else {
        parallel::mclapply(binned_reads, do_fit, mc.cores=min(length(binned_reads), cores))
    }
}


#' plotCellCurve
#'
#' Plot counts vs. barcodes to identify reasonable count cut off to define
#' which barcodes represent a "cell" vs.noise
#'
#' @param data A matrix of counts, with barcodes as rows and genes as columns
#' @param threshold Your selected threshold, so curve can be colored nicely
#'   Default: TRUE
#' @param verbose Do you want the cell count to be printed. Default: TRUE
#' @param main Title for plot.  Default is "Cells"
#' @return None.  Called for side-effect of plotting the curve and, optionally,
#'   printing the number of barcodes that are cells based on threshold.
#'
#' At this point, you must pick the threshold subjectively, ideally high up
#' in the "knee" region. In the future it would be ideal to add a heuristic
#' for picking the threshold automatically.
#' @name plotCellCurve
#' @rdname plotCellCurve
#' @examples
#' data <- readRDS("counts.rds")
#' plotCellCurve(data, 300)
#'
plotCellCurve <- function(data, threshold = 300, verbose=TRUE, main="Cells")
{
  counts <- apply(data, 1, sum)
  runcounts <- sapply(sort(counts), function(x) { sum(counts > x)})
  Cell <- sort(counts) > threshold
  Cell <- factor(Cell, levels = c(TRUE, FALSE))
  if (verbose)
    print(table(Cell))

  pd <- data.frame("bc" = runcounts + 1, "umi" = sort(counts + 1), Cell = Cell)
  ggplot(pd, aes(x = bc, y = umi, color = Cell)) +
    geom_point(pch = 19) +
    scale_x_log10(name = "Log (Barcode Count)",
                  breaks = c(0, 5, 10, 50, 100, 500, 1000, 5000)) +
    scale_y_log10(name = "Log (UMI Count)",
                  breaks = c(0, 5, 10, 50, 100, 500, 1000, 5000)) +
    theme_bw() +
    theme( axis.title.x = element_text(face = "bold"),
           axis.title.y = element_text(face = "bold")) +
    labs(title = main) +
    theme(axis.text.x = element_text(angle = 270, vjust = 0.5, hjust = 0))
}