library(tidyverse)
library(phyloseq)
library(Maaslin2)

setwd('/home/jovyan/work/microbial/GO_term_analysis/16_DEC_2020_dmm_troubleshooting_Lee/')

load(file = "././images/1_dmm_03222021.RDA")

term_pseq_no_neg_comp<-microbiome::transform(x = term_pseq_no_neg,transform = "compositional")
<<<<<<< Updated upstream
term_pseq_no_neg_comp<-microbiome::transform(x = pseq_decontam_no_neg_core,transform = "compositional")
=======
>>>>>>> Stashed changes

library(microbiome)

df_input_data<-data.frame(t(otu_table(term_pseq_no_neg_comp)))
df_input_metadata<-data.frame(sample_data(term_pseq_no_neg_comp))

<<<<<<< Updated upstream
#write.table(x = df_input_metadata,file = "maaslin2_case_analysis_metadata.tsv",quote = F,sep = "\t",row.names = T,)
=======
write.table(x = df_input_metadata,file = "maaslin2_case_analysis_metadata.tsv",quote = F,sep = "\t",row.names = T,)
>>>>>>> Stashed changes

case_norm<-Maaslin2(
  input_data = df_input_data,
  input_metadata = df_input_metadata,
<<<<<<< Updated upstream
  output="./trash",
=======
  output="./results/terms_vs_case_comp_norm",
>>>>>>> Stashed changes
  min_abundance = 0.01,
  min_prevalence = 0.1,
  normalization = "CLR",
  transform = "NONE",
  analysis_method = "LM",
  max_significance = 0.05,
  random_effects = c("sample_name","publication"),
  fixed_effects = c("case"),
  correction="BH",
  standardize = TRUE,
<<<<<<< Updated upstream
  cores = 24,
=======
  cores = 20,
>>>>>>> Stashed changes
  plot_heatmap = TRUE,
  plot_scatter = TRUE,
  heatmap_first_n =num,
 reference="case,COVID19")

<<<<<<< Updated upstream

res<-unique(case_norm$results$feature)
res<-gsub("X","",res)
pseq_res<-prune_taxa(taxa = res,x = pseq_decontam_no_neg_core)
resmelt<-psmelt(pseq_res)
resmelt
library(ggpubr)
library(ggsci)
ggviolin(data = resmelt,x = "case",y = "Abundance",)
library(ggsci)
library(ggpubr)
ggviolin(data = s,x = "case",y = "Abundance",add = "jitter")+
  yscale(.scale = "log10",.format = T)+
  stat_compare_means(aes(label = ..p.signif..),method = "t.test", ref.group = "COVID19")
my_comparisons <- list( c("COVID19", "CAP"), c("CAP","Uninfected"),c("COVID19", "Uninfected"))

ggviolin(data = s,x = "case",y = "Abundance",add = "jitter",trim = T)+#,facet.by = "species")+
  yscale(.scale = "log10",.format = T)+
  stat_compare_means(comparisons = my_comparisons,label.y = c(6,6.25,6.5))+
  stat_compare_means(label.y = c(5))+rotate_x_text()#,aes

=======
>>>>>>> Stashed changes
term_pseq_outcome<-subset_samples(physeq = term_pseq_no_neg,outcome!="NA")
x<-sample_sums(term_pseq_outcome)
y<-as_tibble(x,,rownames="sample")%>%arrange(value)
meta<-as_tibble(meta(term_pseq_outcome),rownames="sample")

y<-full_join(y,meta)
library(ggpubr)
gghistogram(data = y,x = "value",y = "..count..",color = "publication",fill = "outcome",bins = 50)+xscale("log10")
# library(mosaic)
 favstats(data = y,x = y$value)

meta<-meta(term_pseq_outcome)
meta$outcome<-gsub("Stabilized","Survived",meta$outcome)
meta$outcome<-gsub("Recovered","Survived",meta$outcome)
sample_data(term_pseq_outcome)<-sample_data(meta)

sample_data(term_pseq_outcome)

remove_zhou<-c("SRR11092058","SRR11092057","SRR11092056","SRR11092064")

keep<-c("SRR11092061","CRR125941","CRR125940","CRR125939","CRR125938","CRR125937","CRR125936",
"CRR125935","SRR10903402","SRR10903401","SRR11092063","SRR11092062","SRR11092060","SRR11092059")

a<-as.data.frame(taxa_sums(term_pseq_outcome))

library(mosaic)

favstats(a$`taxa_sums(term_pseq_outcome`)

term_pseq_outcome_core<-prune_taxa(taxa_sums(term_pseq_outcome)>10,term_pseq_outcome)
term_pseq_outcome_core<-subset_samples(physeq = term_pseq_outcome_core,reads=="paired")
term_pseq_outcome_core<-prune_samples(x = term_pseq_outcome_core,samples = keep)
term_pseq_outcome
term_pseq_outcome_core

term_pseq_outcome_comp<-microbiome::transform(x = term_pseq_outcome_core,transform = "compositional")

COVID19_df_input_data<-data.frame(t(otu_table(term_pseq_outcome_comp)))
COVID19_df_input_metadata<-data.frame(sample_data(term_pseq_outcome_comp))

tally(~sample_name+publication,data=COVID19_df_input_metadata,"count")

tally(~sample_name+outcome,data=COVID19_df_input_metadata,"count")

tally(~outcome+publication,data=COVID19_df_input_metadata,"count")
<<<<<<< Updated upstream

subset_outcome<-Maaslin2(
  input_data = COVID19_df_input_data,
  input_metadata = COVID19_df_input_metadata,
  output="./results/subset_outcome",
=======
getwd()
subset_outcome<-Maaslin2(
  input_data = COVID19_df_input_data,
  input_metadata = COVID19_df_input_metadata,
  output="./results/subset_outcome_05042021",
>>>>>>> Stashed changes
  min_abundance = 0.00001,
  min_prevalence = 0.01,  #test only features with at least 10% non-zero values. min 2.5samples to be run
  normalization = "CLR",
  transform = "NONE",
  analysis_method = "LM",
  max_significance = 0.05,
#  random_effects = c("publication"),
  fixed_effects = c("outcome"),
  correction="BH",
  standardize = TRUE,
<<<<<<< Updated upstream
  cores = 48,
=======
  cores = 20,
>>>>>>> Stashed changes
  plot_heatmap = TRUE,
  plot_scatter = TRUE,
  heatmap_first_n =num)

subset_outcome<-Maaslin2(
  input_data = COVID19_df_input_data,
  input_metadata = COVID19_df_input_metadata,
  output="./results/subset_outcome",
  min_abundance = 0.00001,
  min_prevalence = 0.01,  #test only features with at least 10% non-zero values. min 2.5samples to be run
  normalization = "CLR",
  transform = "NONE",
  analysis_method = "LM",
  max_significance = 0.05,
  random_effects = c("publication"),
  fixed_effects = c("outcome"),
  correction="BH",
  standardize = TRUE,
<<<<<<< Updated upstream
  cores = 48,
=======
  cores =20,
>>>>>>> Stashed changes
  plot_heatmap = TRUE,
  plot_scatter = TRUE,
  heatmap_first_n =num)

subset_outcome<-Maaslin2(
  input_data = COVID19_df_input_data,
  input_metadata = COVID19_df_input_metadata_test,
  output="./results/subset_outcome",
  min_abundance = 0.00001,
  min_prevalence = 0.01,  #test only features with at least 10% non-zero values. min 2.5samples to be run
  normalization = "CLR",
  transform = "NONE",
  analysis_method = "LM",
  max_significance = 0.05,
  random_effects = c('sample_name'),
  fixed_effects = c("outcome"),
  correction="BH",
  standardize = TRUE,
<<<<<<< Updated upstream
  cores = 48,
=======
  cores =20,
>>>>>>> Stashed changes
  plot_heatmap = TRUE,
  plot_scatter = TRUE,
  heatmap_first_n =num)

subset_outcome<-Maaslin2(
  input_data = COVID19_df_input_data,
  input_metadata = COVID19_df_input_metadata_test,
  output="./results/subset_outcome",
  min_abundance = 0.00001,
  min_prevalence = 0.01,  #test only features with at least 10% non-zero values. min 2.5samples to be run
  normalization = "CLR",
  transform = "NONE",
  analysis_method = "LM",
  max_significance = 0.05,
  random_effects = c('publication'),
  fixed_effects = c("outcome"),
  correction="BH",
  standardize = TRUE,
<<<<<<< Updated upstream
  cores = 48,
=======
  cores =20,
>>>>>>> Stashed changes
  plot_heatmap = TRUE,
  plot_scatter = TRUE,
  heatmap_first_n =num)

subset_outcome<-Maaslin2(
  input_data = COVID19_df_input_data,
  input_metadata = COVID19_df_input_metadata_test,
  output="./results/subset_outcome",
  min_abundance = 0.00001,
  min_prevalence = 0.01,  #test only features with at least 10% non-zero values. min 2.5samples to be run
  normalization = "CLR",
  transform = "NONE",
  analysis_method = "LM",
  max_significance = 0.05,
  random_effects = c('reads'),
  fixed_effects = c("outcome"),
  correction="BH",
  standardize = TRUE,
<<<<<<< Updated upstream
  cores = 48,
=======
  cores =20,
>>>>>>> Stashed changes
  plot_heatmap = TRUE,
  plot_scatter = TRUE,
  heatmap_first_n =num)

COVID19_df_input_metadata_test<-data.frame(sample_data(term_pseq_outcome_comp))
COVID19_df_input_metadata_test$control<-as_factor(paste0(COVID19_df_input_metadata_test$publication,
    "_",
    COVID19_df_input_metadata_test$sample_name,
    "_",
    COVID19_df_input_metadata_test$reads))
COVID19_df_input_metadata_test$control

subset_outcome<-Maaslin2(
  input_data = COVID19_df_input_data,
  input_metadata = COVID19_df_input_metadata_test,
  output="./results/subset_outcome",
  min_abundance = 0.00001,
  min_prevalence = 0.01,  #test only features with at least 10% non-zero values. min 2.5samples to be run
  normalization = "CLR",
  transform = "NONE",
  analysis_method = "LM",
  max_significance = 0.05,
  random_effects = c("control"),
  fixed_effects = c("outcome"),
  correction="BH",
  standardize = TRUE,
<<<<<<< Updated upstream
  cores = 48,
=======
  cores =20,
>>>>>>> Stashed changes
  plot_heatmap = TRUE,
  plot_scatter = TRUE,
  heatmap_first_n =num)

subset_outcome_res<-subset_outcome$results%>%filter(pval<=0.01)
subset_outcome_res

subset_outcome<-Maaslin2(
  input_data = COVID19_df_input_data,
  input_metadata = COVID19_df_input_metadata_test,
  output="./results/subset_outcome",
  min_abundance = 0.00001,
  min_prevalence = 0.01,  #test only features with at least 10% non-zero values. min 2.5samples to be run
  normalization = "CLR",
  transform = "NONE",
  analysis_method = "LM",
  max_significance = 0.05,
  random_effects = c("publication","sample_name"),
  fixed_effects = c("outcome"),
  correction="BH",
  standardize = TRUE,
<<<<<<< Updated upstream
  cores = 48,
=======
  cores =20,
>>>>>>> Stashed changes
  plot_heatmap = TRUE,
  plot_scatter = TRUE,
  heatmap_first_n =num)

subset_outcome_res<-subset_outcome$results%>%filter(pval<=0.01)
dim(subset_outcome_res)

subset_outcome<-Maaslin2(
  input_data = COVID19_df_input_data,
  input_metadata = COVID19_df_input_metadata_test,
  output="./results/subset_outcome",
  min_abundance = 0.00001,
  min_prevalence = 0.01,  #test only features with at least 10% non-zero values. min 2.5samples to be run
  normalization = "CLR",
  transform = "NONE",
  analysis_method = "LM",
  max_significance = 0.05,
  random_effects = c("publication","reads"),
  fixed_effects = c("outcome"),
  correction="BH",
  standardize = TRUE,
<<<<<<< Updated upstream
  cores = 48,
=======
  cores =20,
>>>>>>> Stashed changes
  plot_heatmap = TRUE,
  plot_scatter = TRUE,
  heatmap_first_n =num)

subset_outcome_res<-subset_outcome$results%>%filter(pval<=0.01)
dim(subset_outcome_res)

subset_outcome_res

tally(~sample_name+publication,data=COVID19_df_input_metadata_test,"count")

tally(~sample_name+outcome,data=COVID19_df_input_metadata_test)

tally(~sample_name+reads+publication,data=COVID19_df_input_metadata_test)

tally(~sample_name+reads+publication,data=COVID19_df_input_metadata_test)

tally(~control+outcome,data=COVID19_df_input_metadata_test)

tally(~sample_name+reads,meta,"count")

res<-case_norm$results%>%filter(pval<=0.05)

write.table(subset_outcome_res,"subset_outcome_res.tsv", sep="\t", row.names=F)

dim(subset_outcome_res)

Terms<-gsub("GO.","GO:",res$feature)
Terms<-gsub("[.]"," ",Terms)
Terms<-sub(" ","-",Terms)
Terms<-as_tibble(Terms)
Terms<-separate(data = Terms,col = value,sep = "-",into =  c("Term", "name"))

outcome_Terms<-gsub("GO.","GO:",subset_outcome_res$feature)
outcome_Terms<-gsub("[.]"," ",outcome_Terms)
outcome_Terms<-sub(" ","-",outcome_Terms)
outcome_Terms<-as_tibble(outcome_Terms)
outcome_Terms<-separate(data = outcome_Terms,col = value,sep = "-",into =  c("Term", "name"))

outcome_term_pseq_prune <- prune_taxa(taxa = outcome_Terms$Term,x =term_pseq_no_neg_gonames)
outcome_term_pseq_prune #[85 taxa and 141 samples ]
tax<-data.frame(tax_table(outcome_term_pseq_prune))
names<-paste(rownames(tax),tax$name,sep="-")
taxa_names(outcome_term_pseq_prune)<-names

term_pseq_prune <- prune_taxa(taxa = Terms$Term,x =term_pseq_no_neg_gonames)
term_pseq_prune #[85 taxa and 141 samples ]
tax<-data.frame(tax_table(term_pseq_prune))
names<-paste(rownames(tax),tax$name,sep="-")
taxa_names(term_pseq_prune)<-names

save.image("./images/2_maaslin2.rda")

write.table(tax,"subset_outcome_tax.tsv",sep = "\t",row.names = T,quote = F)

boxplot_abundance()

subset_outcome_res$feature


#
# Script to implement MeTHODICAL for CCNX
#
#
#ssh  user@10.0.1.131
# 10.0.1.123
# 10.10.10.30

# rngBen <- 2:2
# rngCost <- 2:4
# myRNGBEN <- 1:2
# myRNGCOST <- 3:5
# myWrngBEN <- 1:1
# myWrngCost <- 2:4

aux_step03_Weight_of_Norm_matrix <-function(inMatrix, inWeight){

  outMat <- inMatrix
  ncols<-dim(inMatrix)[2]
  nrows<-dim(inMatrix)[1]

  #iMcalc2 <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=TRUE)
  iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=FALSE)

  nC <- dim(iMcalc)[2] # Convert weigths into a matrix in order to perform Mult
  aMmul <- matrix(rep(inWeight, times=nrows), ncol=nC, byrow=TRUE)

  auxCalc <- iMcalc * aMmul

  outMat[,2:ncols]<-auxCalc

  return(outMat)
}

FMC_WD <- function(mBen, mCost, wBen, wCost, namesList, name){

  mBen <- data.frame(matrix(unlist(mBen), ncol=2, byrow=F))
  colnames(mBen) <- c("id", "pop")

  mCost <- data.frame(matrix(unlist(mCost), ncol=4, byrow=F))
  colnames(mCost) <- c("id", "ratio", "size", "pop")

  namesList <- data.frame(matrix(unlist(namesList), ncol=2, byrow=F))
  colnames(namesList) <- c("id", "prefix")

  save(mBen, mCost, wBen, wCost, namesList, file=name)
}

FMC_LD <- function(dataFile, algorithm){
  load(dataFile)
  out <- FMC_MADM(mBen, mCost, wBen, wCost, algorithm)

  dfNames <- data.frame(matrix(unlist(namesList), ncol=2, byrow=F))
  colnames(dfNames) <- c("id", "prefix")

  dfOut <- data.frame(matrix(unlist(out), ncol=2, byrow=F))
  colnames(dfOut) <- c("id", "score")

  output <- merge(dfNames, dfOut, by="id")
  output <- output[2:3]
  output <- output[order(output$score),]
  return(output)
}

FMC_MADM <- function(mBen, mCost, wBen, wCost, algorithm=1){

  source("METH_related.r")

  #save(file="./input_data_.data", list=ls())

  auxBen_col <- dim(mBen)[2]
  auxCost_col <- dim(mCost)[2]

  if (dim(mBen)[1] < 1 || dim(mCost)[1] < 1){
    return(-2)
  }
  else if (dim(mBen)[1] < 2 || dim(mCost)[1] < 2){
    return(-1)
  }

  myRNGBEN <- seq(1, by=1, to=auxBen_col)
  rngBen <- seq(1, by=1, to=auxBen_col)

  #DANGER
  myRNGCOST <- seq(auxBen_col+1, by=1, to=auxBen_col + auxCost_col -1)
  rngCosts <- seq(2, by=1, to=auxCost_col)

  myWrngBEN <- seq(1, by=1, to=length(wBen))
  myWrngCost <- seq(length(wBen) +1, by=1, to=length(wBen) + length(wCost))

  if (is.list(mBen)){
    mBen <- matrix(unlist(mBen), ncol=auxBen_col, byrow=FALSE)
  }

  if (is.list(mCost)){
    mCost <- matrix(unlist(mCost), ncol=auxCost_col, byrow=FALSE)
  }

  if (algorithm == 1){

    iM <- mBen
    iM <- cbind(iM, mCost[,rngCosts])

    iVecWei <- wBen
    iVecWei <- append(iVecWei, wCost)

    aux_out <- METH_METHODICALv10(iM, iVecWei, rngBEN=myRNGBEN, rngCost=myRNGCOST, rngWBen=myWrngBEN, rngWCost=myWrngCost)
  }
  else if (algorithm == 2){
    aux_out <- METH_runTOPSIS(mBen, mCost, wBen, wCost)
  }
  else if (algorithm == 3){
    aux_out <- METH_runDiA(mBen, mCost, wBen, wCost)
  }
  else if (algorithm == 4){
    aux_out <- METH_runNMMD(mBen, mCost, wBen, wCost)
  }

  return(aux_out)
}

METH_METHODICALv9 <-function(mBen, mCost, weiBen_prefMultihoming, weiCost_prefMultihoming){

  auxBen_col <- dim(mBen)[2] - 1
  auxCost_col <- dim(mCost)[2] - 1

  myRNGBEN <- seq(1, by=1, to=auxBen_col)
  rngBen   <- seq(1, by=1, to=auxBen_col)
  # DANGER
  myRNGCOST <- seq(auxBen_col+1, by=1, to=auxBen_col + auxCost_col - 1 )
  rngCosts   <- seq(2, by=1, to=auxCost_col)

#   print("BEN")
#   print(auxBen_col)
#   print(myRNGBEN)
#   #print(rngBen)
#
#   print("COST")
#   print(auxCost_col)
#   print(myRNGCOST)
#   print(rngCosts)

  myWrngBEN  <- seq(1, by=1, to=length(weiBen_prefMultihoming) )
  myWrngCost <- seq(length(weiBen_prefMultihoming) +1, by=1, to= length(weiBen_prefMultihoming) + length(weiCost_prefMultihoming) )

#   print("W BEN")
#   print(myWrngBEN)
#   print("W COST")
#   print(myWrngCost)

  iM <-mBen
  iM <- cbind(iM , mCost[,rngCosts])

  #str(iM)
  #print("#R")
  #print(iM)

  iVecWei <- weiBen_prefMultihoming
  iVecWei <- append(iVecWei, weiCost_prefMultihoming)

  aux_res<-METH_METHODICALv10(iM, iVecWei,  rngBEN=myRNGBEN, rngCost=myRNGCOST, rngWBen=myWrngBEN, rngWCost=myWrngCost )

  #str(aux_res)
  #print("#R")
  #print(aux_res)

  return (aux_res)
}

#
#
# Code for Version 10 uses Variance instead of standard deviation
#
METH_METHODICALv10 <- function(iM, iVecWei, rngBEN=1:5, rngCost=6, rngWBen=1:4, rngWCost=5, MeTHBeta=0.5, MeTHOmega=0.5, itry=1 ){

  MINSUM_TOPSIS <- 1e-99 # To avoid divisions by zero in normalization

  mBen_Criteria <- iM[,rngBEN]
  mCost_Criteria <- iM[,c(1,rngCost)] # Put also the id in the matrix of costs.

  vBen_weight <- iVecWei[rngWBen]
  vCost_weight <- iVecWei[rngWCost]

  applyWeight <- TRUE
  applyNorm <- TRUE

  #norm_method <- "minmax"
  norm_method <- "vector"
  #norm_method <- "max"
  #norm_method <- "sum"

  fAuxPos <- function(iN){

    if (iN < 0) {
      iN <- iN * (-1)
    }
    return(iN)
  }

  fAux_Positive_Dif <- function(i1, i2){
    adif <- (i1 - i2)
    #if (adif < 0) {
    #  adif <- adif * (-1)
    #}
    adif<-fAuxPos(adif)
    return(adif)
  }

  #
  # Determine RScore
  #
  calcRscorev10 <- function(inM, alpha=0.5, omega=0.5){
    nrow <- dim(inM)[1]
    outMat <- inM
    outMat <- outMat[,-3]

    for (nR in 1:nrow){
      #outMat[nR,2] <-  sqrt(alpha*(inM[nR,2]) + omega*(inM[nR,3])   ) # no square
      outMat[nR,2] <-  sqrt((inM[nR,2]) + (inM[nR,3])   ) # no square
      outMat[nR,2] <- outMat[nR,2] #+ auxSD
    }

    return(outMat)
  }

  #
  # It can't be leads to zeros.
  #
  calcRscorev10b_asTOPSIS <- function(inM, alpha=0.5, omega=0.5){
    nrow <- dim(inM)[1]
    outMat <- inM
    outMat <- outMat[,-3]

    for (nR in 1:nrow){
      #outMat[nR,2] <-  sqrt(alpha*(inM[nR,2]) + omega*(inM[nR,3])   ) # no square
      outMat[nR,2] <- inM[nR,3] / inM[nR,3] + inM[nR,2]
      outMat[nR,2] <- outMat[nR,2] #+ auxSD
    }

    return(outMat)
  }

  # I think this method produces a lot of zeros.
  aux_step02_MinMax_Normalization<- function(inMatrix, iTypeBen=TRUE, iRangeNorm=1){

    #internal function to help in normalization
    fAuxLinearBEN <- function(i, iMax, iMin){
      aa <- iMax - iMin
      if (aa != 0){
        aSu <- ( (i - iMin) / (iMax - iMin) )
      }else{
        aSu <- 0
      }
      return(aSu)
    }

    fAuxLinearCOST <- function(i, iMax, iMin){
      aa <- iMax - iMin
      if (aa != 0){
        aSu <- ( (iMax - i) / (iMax - iMin) )
      }else{
        aSu <- 0
      }
      return(aSu)
    }

    outMat <- inMatrix
    ncols<-dim(inMatrix)[2]
    nrows<-dim(inMatrix)[1]

    iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=FALSE)

    #Apply Sum by col
    MaxPer_Row <- apply(iMcalc, 2, max)
    MinPer_Row <- apply(iMcalc, 2, min)

    nC <- dim(iMcalc)[2]
    nR <- dim(iMcalc)[1]
    aMMax <- matrix(rep(MaxPer_Row, times=nR), ncol=nC, byrow=TRUE)
    aMMin <- matrix(rep(MinPer_Row, times=nR), ncol=nC, byrow=TRUE)

    if (iTypeBen==TRUE){
      auxCalc <- mapply(FUN=fAuxLinearBEN, iMcalc, aMMax, aMMin)
    }else{
      auxCalc <- mapply(FUN=fAuxLinearCOST, iMcalc, aMMax, aMMin)
    }

    auxCalc <- auxCalc * iRangeNorm

    auxCalc <- matrix(auxCalc, nrow=nR, ncol=nC, byrow=FALSE)
    #nC <- dim(iMcalc)[2]
    #aMSum <- matrix(rep(auxSum, times=nrows), ncol=nC, byrow=TRUE)
    #auxCalc <- iMcalc / sqrt(aMSum)

    outMat[,2:ncols]<-auxCalc
    return(outMat)

  }

  aux_step02_VEC_Normalization <- function(inMatrix){

    #internal function to help in normalization
    fSum <- function(i){
      sumrow <- MINSUM_TOPSIS
      aSu <- sum(i^2) + sumrow
      return(aSu)
    }

    outMat <- inMatrix
    ncols<-dim(inMatrix)[2]
    nrows<-dim(inMatrix)[1]

    iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=FALSE)
    #print(iMcalc)

    #Apply Sum by col
    auxSum <- apply(iMcalc, 2, FUN=fSum)
    #print(auxSum)

    nC <- dim(iMcalc)[2]
    aMSum <- matrix(rep(auxSum, times=nrows), ncol=nC, byrow=TRUE)
    auxCalc <- iMcalc / sqrt(aMSum)
    #print(auxCalc)

    outMat[,2:ncols]<-auxCalc
    return(outMat)

  }

  #
  # The opposite of minMax leads to a lot of one's if criterion is maximized.
  #
  aux_step02_Max_Normalization<- function(inMatrix, iTypeBen=TRUE, iRangeNorm=1){

    #internal function to help in normalization
    fAuxLinearBEN <- function(i, iMax){
      aa <- iMax
      if (aa != 0){
        aSu <- ( i  / iMax )
      }else{
        aSu <- 0
      }
      return(aSu)
    }

    fAuxLinearCOST <- function(i, iMax){
      aa <- iMax
      if (aa != 0){
        aSu <- 1 - ( i / iMax  )
      }else{
        aSu <- 0
      }
      return(aSu)
    }

    outMat <- inMatrix
    ncols<-dim(inMatrix)[2]
    nrows<-dim(inMatrix)[1]

    iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=FALSE)

    #Apply Sum by col
    MaxPer_Row <- apply(iMcalc, 2, max)
    #MinPer_Row <- apply(iMcalc, 2, min)

    nC <- dim(iMcalc)[2]
    nR <- dim(iMcalc)[1]
    aMMax <- matrix(rep(MaxPer_Row, times=nR), ncol=nC, byrow=TRUE)
    #aMMin <- matrix(rep(MinPer_Row, times=nR), ncol=nC, byrow=TRUE)
    if (iTypeBen==TRUE){
      auxCalc <- mapply(FUN=fAuxLinearBEN, iMcalc, aMMax)
    }else{
      auxCalc <- mapply(FUN=fAuxLinearCOST, iMcalc, aMMax)
    }

    auxCalc <- auxCalc * iRangeNorm

    auxCalc <- matrix(auxCalc, nrow=nR, ncol=nC, byrow=FALSE)
    #nC <- dim(iMcalc)[2]
    #aMSum <- matrix(rep(auxSum, times=nrows), ncol=nC, byrow=TRUE)
    #auxCalc <- iMcalc / sqrt(aMSum)

    outMat[,2:ncols]<-auxCalc
    return(outMat)

  }

  aux_step02_SUM_Normalization <- function(inMatrix){

    #internal function to help in normalization
    fSum <- function(i){
      sumrow <- MINSUM_TOPSIS
      aSu <- sum(i) + sumrow
      return(aSu)
    }

    outMat <- inMatrix
    ncols<-dim(inMatrix)[2]
    nrows<-dim(inMatrix)[1]

    iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=FALSE)
    #print(iMcalc)

    #Apply Sum by col
    auxSum <- apply(iMcalc, 2, FUN=fSum)
    #print(auxSum)

    nC <- dim(iMcalc)[2]
    aMSum <- matrix(rep(auxSum, times=nrows), ncol=nC, byrow=TRUE)
    auxCalc <- iMcalc / aMSum
    #print(auxCalc)

    outMat[,2:ncols]<-auxCalc
    return(outMat)

  }

  calcDist_METHODICALv10b<- function(inMatrix, inIdeal, inMin, inMax, BenCriteria=TRUE, ignFirstCol=TRUE){

    ncols<-dim(inMatrix)[2]
    nrows<-dim(inMatrix)[1]

    if (ignFirstCol){
      iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=FALSE)

    }else{
      iMcalc <- inMatrix

    }

    fCalcAux <- function(iMcalc){
      auxMean <- mean(iMcalc)
      auxSD   <- var(iMcalc) # MAIN difference in MeTH_v10
      #auxSD   <- sd(iMcalc) # MAIN difference in MeTH_v10

      if (BENC){
        SDMean <- auxMean + auxSD
      }else{
        SDMean <- auxMean - auxSD
      }
      return(SDMean)
    }

    outMat <- matrix(ncol=2,nrow=nrows)
    outMat[,1] <- inMatrix[,1]

    nColMat <- dim(iMcalc)[2]
    ncolIdeal <- dim(inIdeal)[2]

    #}
    # Just to be sure
    stopifnot(nColMat == ncolIdeal)

    BENC <<- BenCriteria

    SDMean <- apply(iMcalc, 2, FUN=fCalcAux)

    mSDMean <- matrix(SDMean, byrow=TRUE, nrow=dim(iMcalc)[1], ncol=dim(iMcalc)[2])
    mIdeal  <- matrix(inIdeal, byrow=TRUE, nrow=dim(iMcalc)[1], ncol=dim(iMcalc)[2])
    mMax  <- matrix(inMax, byrow=TRUE, nrow=dim(iMcalc)[1], ncol=dim(iMcalc)[2])
    mMin  <- matrix(inMin, byrow=TRUE, nrow=dim(iMcalc)[1], ncol=dim(iMcalc)[2])

    #Perform Operation
    #auxTETA <- -1 *  (mSDMean - iMcalc)
    #Yaux <- (iMcalc - mIdeal)^2
    #auxDiffDeno <- (mMax - mMin)^2 #originally without sqrt
    #auxDeno <-  (auxTETA + auxDiffDeno)

    #auxTETA <- -1 *  (mSDMean - iMcalc)
    #Yaux <- (iMcalc - mIdeal)^2 + (mIdeal - mSDMean)^2
    #auxDiffDeno <- (mMax - mMin)^2 #originally without sqrt
    #auxDeno <-  (auxDiffDeno - auxTETA)

    Yaux <- (iMcalc - mIdeal)^2
    auxDeno <-  abs(mIdeal - mSDMean) + 0.001

    auxCalcM <- (Yaux /  auxDeno )
    auxCalcM[is.na(auxCalcM)]<-0

    auxCalc <- apply(auxCalcM, 1, sum)

    outMat[,2] <- auxCalc

    return(outMat)
  }

  ncolMB <- dim(mBen_Criteria)[2]
  MeTHTOPsisBenefits <- as.matrix(mBen_Criteria )

  ncolMC <- dim(mCost_Criteria)[2]
  MeTHTOPsisCosts <- as.matrix(mCost_Criteria )

  MeTHWeiBenTOP <- vBen_weight
  MeTHWeiCostTOP <- vCost_weight

  #
  # Step 01
  #

  # Needs libNormalization
  # apply Normalization
  if (applyNorm==TRUE){

    #ISSUE
    if (norm_method =="minmax"){
      MeTHTOPsisBenefits <- aux_step02_MinMax_Normalization(MeTHTOPsisBenefits, iTypeBen=TRUE)
      MeTHTOPsisCosts    <- aux_step02_MinMax_Normalization(MeTHTOPsisCosts, iTypeBen=FALSE)
    }

    if (norm_method =="vector"){
      MeTHTOPsisBenefits <- aux_step02_VEC_Normalization(MeTHTOPsisBenefits)
      MeTHTOPsisCosts    <- aux_step02_VEC_Normalization(MeTHTOPsisCosts)
    }

    if (norm_method =="sum"){
      MeTHTOPsisBenefits <- aux_step02_SUM_Normalization(MeTHTOPsisBenefits)
      MeTHTOPsisCosts    <- aux_step02_SUM_Normalization(MeTHTOPsisCosts)
    }

    if (norm_method =="max"){
      MeTHTOPsisBenefits <- aux_step02_Max_Normalization(MeTHTOPsisBenefits, iTypeBen=TRUE)
      MeTHTOPsisCosts    <- aux_step02_Max_Normalization(MeTHTOPsisCosts, iTypeBen=FALSE)
    }

  }

  #Apply Weighting
  if (applyWeight==TRUE){
    MeTHTOPsisBenefits <-aux_step03_Weight_of_Norm_matrix(MeTHTOPsisBenefits, MeTHWeiBenTOP)
    MeTHTOPsisCosts    <-aux_step03_Weight_of_Norm_matrix(MeTHTOPsisCosts, MeTHWeiCostTOP)
  }

  #
  # Step 02
  #
  #Retrieve Maximum and Minimum
  rngBBen <- seq(from=2, by=1, to=dim(MeTHTOPsisBenefits)[2])
  rngCCost <- seq(from=2, by=1, to=dim(MeTHTOPsisCosts)[2])

  MeTHMaxIdeal<- as.numeric(apply(as.matrix(MeTHTOPsisBenefits[,rngBBen]), 2, max))
  MeTHBenMin  <- as.numeric(apply(as.matrix(MeTHTOPsisBenefits[,rngBBen]), 2, min))
  MeTHBenMax  <- MeTHMaxIdeal
  #
  MeTHMinIdeal<- as.numeric(apply(as.matrix(MeTHTOPsisCosts[,rngCCost]), 2, min))
  MeTHCostMax <- as.numeric(apply(as.matrix(MeTHTOPsisCosts[,rngCCost]), 2, max))
  MeTHCostMin <- MeTHMinIdeal

  MeTHBenDist<-calcDist_METHODICALv10b(MeTHTOPsisBenefits,MeTHMaxIdeal, MeTHBenMin, MeTHBenMax, BenCriteria=TRUE)
  MeTHCostDist<-calcDist_METHODICALv10b(MeTHTOPsisCosts,MeTHMinIdeal, MeTHCostMin, MeTHCostMax, BenCriteria=FALSE)

  #
  # Step 04
  #
  inMatForR <- MeTHBenDist
  inMatForR <- cbind(inMatForR, MeTHCostDist[,2])
  #inMatForR

  MeTHRScore<-calcRscorev10(inMatForR, MeTHBeta, MeTHOmega)
  #RScoreANT <<- MeTHRScore

  orderRet  <-  MeTHRScore[order(MeTHRScore[,2]),]

  return(orderRet)
  #return(MeTHRScore)
}


#!/usr/bin/env Rscript

suppressMessages(require(optparse))
suppressMessages(require(stringr))
suppressMessages(require(xtable))
suppressMessages(require(igraph))
options(stringsAsFactors = F)

option_list <- list(
  make_option(c("-d", "--database"), type="character", default=NULL,
              help="path to the database of motifs used as Tomtom reference",
              metavar="DATABASE.MEME"),
  make_option(c("-a", "--tom_alignments"), type="character", default=NULL,
              help="path to the Tomtom tsv output of motifs aligned to the database",
              metavar="TOMTOM.TSV"),
  make_option(c("-t", "--threshold"), type="double", default=0.05,
              help="cutoff value of motif matches: significance (q-val)",
              metavar="CUTOFF"),
  make_option(c("-o", "--outdir"), type="character", default=".",
              help="output directory",
              metavar="OUTDIR"))

# Parse command line arguments
opt_parser <- optparse::OptionParser(option_list=option_list);
opt <- optparse::parse_args(opt_parser);

# Check if required arguments are supplied
if (is.null(opt$database) |
    is.null(opt$tom_alignments)){
  optparse::print_help(opt_parser)
  stop("At least two arguments must be supplied:
 1) database (-c)\n 2) tom_alignments (-a)\n",
    call.=FALSE)
}

# Get full motif names (rather than IDs) from database file
dbfile <- opt$database
db <- readLines(dbfile)
db <- db[str_detect(db, "^MOTIF")]
codes <- sapply(db, FUN=function(x){ str_split(x, " ")[[1]][2] })
names <- sapply(db, FUN=function(x){ str_split(x, " ")[[1]][3] })
names(names) <- codes

# Get threshold and output directory
threshold <- opt$threshold
outdir <- opt$outdir

# Part one: find motif-alignment clusters and output reproducibility table ========================

# Read alignment table and update alignment names to full motif names
tom_alignments <- opt$tom_alignments
all_tom_table <- read.delim(tom_alignments, sep="\t",quote = "", header = T,
                            comment.char = "#")
all_tom_table$Target_ID <- names[all_tom_table$Target_ID]

# Only use alignments below alignment threshold
all_tom_table <- all_tom_table[all_tom_table$q.value < threshold, ]

# Get edge connections from table
edge_vect <- c()
for(i in 1:nrow(all_tom_table)){
  edge_vect <- c(edge_vect, all_tom_table[i,1], all_tom_table[i,2])
}
edge_weights <- all_tom_table$q.value

# Build graph from motif alignments
g <- graph(edge_vect, directed = F)
bipartite.mapping(g) # Assess bipartite mapping
V(g)$type <- bipartite_mapping(g)$type # Make it a bipartite graph

# Add log-transformed q-values as edge weights
E(g)$weight <- -log2(edge_weights)

# Set plotting parameters
V(g)$color <- ifelse(V(g)$type, "lightblue", "salmon")
V(g)$shape <- ifelse(V(g)$type, "circle", "square")
E(g)$color <- "lightgray"
V(g)$label.color <- "black"
V(g)$label.cex <- .8
V(g)$frame.color <-  "gray"
V(g)$size <- 4
E(g)$arrow.size = 0.5
V(g)$size2 = 3

# Plot graph
plot_output_name <- paste0(outdir, "/Motif_alignment_plot.png")
png(plot_output_name, width = 2000, height = 2000)
plot(g, layout = layout_with_graphopt, edge.width=E(g)$weight)
dev.off()

# Cluster graph
g <- simplify(g)
fgc <- igraph::cluster_walktrap(g)
fgc_groups <- igraph::groups(fgc)

# Plot with clusters
plot_output_name <- paste0(outdir, "/Motif_alignment_plot_with_clusters.png")
png(plot_output_name, width = 2000, height = 2000)
plot(fgc, g, layout = layout_with_graphopt, edge.width=E(g)$weight)
dev.off()

# Save clusters to html and tsv
html_file <- paste0(outdir, "/Motif_clusters.html")

n_candidates <- length(unique(sapply(all_tom_table$Query_ID, function(x){return(strsplit(x,split="_")[[1]][1])})))

# Calculate cluster metrics
group_reproducibilities <- sapply(fgc_groups,FUN=function(x, ncan=n_candidates){
  prefixes <- stringr::str_extract(x, "^best|(^[0-9]+)")
  prefixes <- prefixes[!is.na(prefixes)]
  num_exp_found <- length(unique(prefixes))
  return( (num_exp_found/ncan) )
})
cluster_motif_detectors <- sapply(fgc_groups, FUN=function(x, query_options=all_tom_table$Query_ID){
  return(x[x %in% query_options])
})
cluster_not_motif_detectors <- sapply(fgc_groups, FUN=function(x, query_options=all_tom_table$Query_ID){
  return(x[!(x %in% query_options)])
})
cluster_motif_detectors <- sapply(X = cluster_motif_detectors, FUN=function(X){
  return(paste0(X, collapse=" "))
})
cluster_alignments <- sapply(X = cluster_not_motif_detectors, FUN=function(X){
  return(paste0(X, collapse=" "))
})
cluster_df <- data.frame(cluster_motif_detectors, cluster_alignments, cluster_reproducibility=group_reproducibilities)

# Save clusters with metrics to tsv
print(xtable(cluster_df), "html", file = html_file)
tsv_file <- paste0(outdir, "/Motif_clusters.tsv")
write.table(cluster_df, file = tsv_file, sep = "\t", quote = F)

# Save graph object
graph_object_name <- paste0(outdir, "/Motif_alignment_graph_object.RDS")
saveRDS(g, graph_object_name)

cat("\nDone\n")


library(tm)
setwd("whatever")
#Adjust this as necessary, obviously.

filenames <- list.files(getwd(),pattern="*.txt")
files <- lapply(filenames, readLines)
docs <- Corpus(VectorSource(files))
docs <-tm_map(docs, content_transformer(tolower))

toSpace <- content_transformer(function(x, pattern) { return (gsub(pattern, " ", x))})
docs <- tm_map(docs, toSpace, "-")
docs <- tm_map(docs, toSpace, "’")
docs <- tm_map(docs, toSpace, "‘")
docs <- tm_map(docs, toSpace, "•")
docs <- tm_map(docs, toSpace, """)
docs <- tm_map(docs, toSpace, """)

docs <- tm_map(docs, removePunctuation)
docs <- tm_map(docs, removeNumbers)
docs <- tm_map(docs, removeWords, stopwords("english"))
docs <- tm_map(docs, stripWhitespace)
#docs <- tm_map(docs, stemDocument)

#addedstopwords <- c("can", "say", "one")
#docs <- tm_map(docs, removeWords, addedstopwords)

dtm <- DocumentTermMatrix(docs)

#need to convert DTM to a matrix
m <- as.matrix(dtm)

#Using "Ward" method for agglomerative clustering.
hiercluster <- hclust(d, method="ward.D")
plot(hiercluster, hang=-1)

write.csv("hiercluster.csv")


library(yaml)
library(ncdf4)
library(SPEI)
library(RColorBrewer) # nolint

leap_year <- function(year) {
  return(ifelse( (year %% 4 == 0 & year %% 100 != 0) |
                  year %% 400 == 0, TRUE, FALSE))
}

getnc <- function(yml, m, lat = FALSE) {
  id <- nc_open(yml[m][[1]]$filename, readunlim = FALSE)
  if (lat){
     v <- ncvar_get(id, "lat")
  }else{
   v <- ncvar_get(id, yml[m][[1]]$short_name)
   if (yml[m][[1]]$short_name == "tas") v <- v - 273.15
   if (yml[m][[1]]$short_name == "pr"){
     time <- ncvar_get(id, "time")
     tcal <- ncatt_get(id, "time", attname = "calendar")
     tunits <- ncatt_get(id, "time", attname = "units")
     tustr <- strsplit(tunits$value, " ")
     stdate <- as.Date(time[1], origin = unlist(tustr)[3])
     nddate <- as.Date(time[length(time)], origin = unlist(tustr)[3])
     if (tcal$value == "365_day"){
       # Correct for missing leap years in nddate
       diff <- as.numeric(nddate - stdate, units = "days")
       dcorr <- floor( (diff / 365 - diff / 365.25) * 365.25)
       nddate <- nddate + dcorr
     }
     if (tcal$value == "360_day"){
       v <- v * 30 * 24 * 3600.
     }else{
       cnt <- 1
       monarr <- c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
       date <- stdate
       while (date <= nddate){
         year <- as.numeric(substr(date, 1, 4))
         lpyear <- leap_year(year)
         month <- as.numeric(substr(date, 6, 7))
         mdays <- monarr[month]
         pdays <- mdays
         if (month == 2 & lpyear == TRUE){
           pdays <- 29
           if (tcal$value != "365_day"){
             mdays <- 29
           }else{
             mdays <- 28
           }
         }
         v[,,cnt] <- v[,,cnt] * mdays * 24 * 3600.
         date <- date + pdays
         cnt <- cnt + 1
       }
     }
   }
  }
  nc_close(id)
  return(v)
}

ncwritenew <- function(yml, m, hist, wdir, bins){
  fnam <- strsplit(yml[m][[1]]$filename, "/")[[1]]
  pcs <- strsplit(fnam[length(fnam)], "_")[[1]]
  pcs[which(pcs == yml[m][[1]]$short_name)] <- "spei"
  onam <- paste(pcs, collapse = "_")
  onam <- paste0(wdir, "/", strsplit(onam, ".nc"), "_hist.nc")
  ncid_in <- nc_open(yml[m][[1]]$filename)
  var <- ncid_in$var[[yml[m][[1]]$short_name]]
  xdim <- ncid_in$dim[["lon"]]
  ydim <- ncid_in$dim[["lat"]]
  hdim <- ncdim_def("bins", "level", bins[1:(length(bins) - 1)])
  hdim2 <- ncdim_def("binsup", "level", bins[2:length(bins)])
  var_hist <- ncvar_def("hist", "counts", list(xdim, ydim, hdim), NA)
  idw <- nc_create(onam, var_hist)
  ncvar_put(idw, "hist", hist)
  nc_close(idw)
  return(onam)
}

whfcn <- function(x, ilow, ihigh){
  return(length(which(x >= ilow & x < ihigh)))
}

dothornthwaite <- function(v, lat){
 print("Estimating PET with Thornthwaite method.")
 dpet <- v * NA
 d <- dim(dpet)
 for (i in 1:d[2]){
  tmp <- v[,i,]
  tmp2 <- thornthwaite(t(tmp), rep(lat[i], d[1]), na.rm = TRUE)
  d2 <- dim(tmp2)
  tmp2 <- as.numeric(tmp2)
  dim(tmp2) <- d2
  dpet[,i,] <- t(tmp2)
 }
 return(dpet)
}

args <- commandArgs(trailingOnly = TRUE)
params <- read_yaml(args[1])
metadata1 <- read_yaml(params$input_files[1])
metadata2 <- read_yaml(params$input_files[2])
modfile1 <- names(metadata1)
modfile2 <- names(metadata2)
wdir <- params$work_dir
rundir <- params$run_dir
dir.create(wdir, recursive = TRUE)
pdir <- params$plot_dir
dir.create(pdir, recursive = TRUE)
var1_input <- read_yaml(params$input_files[1])
var2_input <- read_yaml(params$input_files[2])
nmods <- length(names(var1_input))

# setup provenance file and list
provenance_file <- paste0(rundir, "/", "diagnostic_provenance.yml")
provenance <- list()

histbrks <- c(-99999, -2, -1.5, -1, 1, 1.5, 2, 99999)
histnams <- c("Extremely dry", "Moderately dry", "Dry",
              "Neutral",
              "Wet", "Moderately wet", "Extremely wet")
refnam <- var1_input[1][[1]]$reference_dataset
n <- 1
while (n <= nmods){
  if (var1_input[n][[1]]$dataset == refnam) break
  n <- n + 1
}
nref <- n
lat <- getnc(var1_input, nref, lat = TRUE)
if (max(lat) > 90){
  print(paste0("Latitude must be [-90,90]: min=",
  min(lat), " max=", max(lat)))
  stop("Aborting!")
}
ref <- getnc(var1_input, nref, lat = FALSE)
refmsk <- apply(ref, c(1, 2), FUN = mean, na.rm = TRUE)
refmsk[refmsk > 10000] <- NA
refmsk[!is.na(refmsk)] <- 1

xprov <- list(ancestors = list(""),
              authors = list("berg_peter"),
              references = list("vicente10jclim"),
              projects = list("c3s-magic"),
              caption = "",
              statistics = list("other"),
              realms = list("atmos"),
              themes = list("phys"),
              domains = list("global"))

histarr <- array(NA, c(nmods, length(histnams)))
for (mod in 1:nmods){
   lat <- getnc(var1_input, mod, TRUE)
   v1 <- getnc(var1_input, mod, FALSE)
   v2 <- getnc(var2_input, mod, FALSE)
   if (var1_input[1][[1]]$short_name == "pr") prtas <- TRUE else prtas <- FALSE
   if (prtas){
     pet <- dothornthwaite(v2, lat)
     pme <- v1 - pet
   }else{
     pet <- dothornthwaite(v1, lat)
     pme <- v2 - pet
   }
   print(var1_input[mod][[1]]$cmor_table)
   d <- dim(pme)
   pme_spei <- pme * NA
   for (i in 1:d[1]){
     wh <- which(!is.na(refmsk[i,]))
     if (length(wh) > 0){
       tmp <- pme[i,wh,]
       pme_spei[i,wh,] <- t(spei(t(tmp), 1, na.rm = TRUE)$fitted)
     }
   }
   pme_spei[is.infinite(pme_spei)] <- NA
   pme_spei[pme_spei > 10000] <- NA
   hist_spei <- array(NA, c(d[1], d[2], length(histbrks) - 1))
   for (nnh in 1:(length(histbrks) - 1)){
     hist_spei[,,nnh] <- apply(pme_spei, c(1, 2), FUN = whfcn,
                              ilow = histbrks[nnh],
                              ihigh = histbrks[nnh + 1])
   }
   filename <- ncwritenew(var1_input, mod, hist_spei, wdir, histbrks)
   # Set provenance for output files
   xprov$caption <- "Histogram of SPEI index per grid point."
   xprov$ancestors <- list(modfile1[mod], modfile2[mod])
   provenance[[filename]] <- xprov
   for (t in 1:d[3]){
      tmp <- pme_spei[,,t]
      tmp[is.na(refmsk)] <- NA
      pme_spei[,,t] <- tmp
   }
   pme_spei[is.infinite(pme_spei)] <- NA
   pme_spei[pme_spei > 10000] <- NA
   # Weight against latitude
   h <- c(1:length(histnams)) * 0
   for (j in 1:d[2]){
     h <- h + hist(pme_spei[j,,], breaks = histbrks,
                   plot = FALSE)$counts * cos(lat[j] * pi / 180.)
   }
   histarr[mod,] <- h / sum(h, na.rm = TRUE)
}
filehist <- paste0(params$work_dir, "/", "histarr.rsav")
save(histarr, file = filehist)
plot_file <- paste0(params$plot_dir, "/", "histplot.png")
xprov$caption <- "Global latitude-weighted histogram of SPEI index."
xprov$ancestors <- list(modfile1, modfile2)
xprov[["plot_file"]] <- plot_file
provenance[[filehist]] <- xprov
write_yaml(provenance, provenance_file)

bhistarr <- array(NA, c(nmods - 1, 7))
marr <- c(1:nmods)[c(1:nmods) != nref]
cnt <- 1
for (m in marr){
  bhistarr[cnt,] <- histarr[m,] - histarr[nref,]
  cnt <- cnt + 1
}
parr <- c(nref, marr)

mnam <- c(1:nmods) * NA
for (m in 1:nmods) mnam[m] <- var1_input[m][[1]]$dataset

qual_col_pals <- brewer.pal.info[brewer.pal.info$category == "qual",] # nolint
col_vector <- unlist(mapply(brewer.pal, qual_col_pals$maxcolors, # nolint
                           rownames(qual_col_pals)))
cols <- c("black", sample(col_vector, nmods - 1))

png(plot_file, width = 1000, height = 500)
 par(mfrow = c(2, 1), oma = c(3, 3, 3, 13), mar = c(2, 1, 1, 1))
 barplot(histarr[parr,], beside = 1, names.arg = histnams,
         col = cols, xaxs = "i")
 box()
 mtext("Probability", side = 2, line = 2.1)
 barplot(bhistarr, beside = 1, names.arg = histnams,
         col = cols[2:nmods], xaxs = "i")
 box()
 mtext("Absolute difference", side = 2, line = 2.1)
 mtext("Standardized precipitation-evapotranspiration index",
        outer = TRUE, cex = 2, font = 2)
 par(fig = c(0.8, .95, 0.1, 0.9), new = T, oma = c(1, 1, 1, 1) * 0,
     mar = c(0, 0, 0, 0))
 legend("topright", mnam[parr], fill = cols)
dev.off()


pdf_file<-"pdf/maps_germany_scatterplot_black.pdf"
cairo_pdf(bg="grey98", pdf_file,width=9,height=11)

par(bg="black",mai=c(0,0,0,0),omi=c(0.5,1,1,0.5),family="Lato Light",las=1)
library(RColorBrewer)

# Import data

source("scripts/inc_datadesign_dbconnect.r")
sql<-"select * from v_women_men"
myDataset<-dbGetQuery(con,sql)
attach(myDataset)

# Create chart

plot(lng,lat,type="n",axes=F)
myColour<-rgb(255,255,0,100,maxColorValue=255)
points(lng,lat,pch=19,col=myColour,cex=4*sqrt(bevinsg),lwd=0)

# Titling

mtext("Germany at night......",side=3,adj=0,line=1,cex=3,family="Lato Black",col="white")
mtext("Source: www.bundeswahlleiter.de",side=1,adj=1,line=0,cex=1,font=3,col="white")
dev.off()


#' Read MT3DMS .ucn File
#'
#' This function reads in a binary ucn file and creates a data frame
#' composed of the following elements:
#' \describe{
#' \item{TRANS}{Transport Time Step}
#' \item{STP}{Flow Time Step}
#' \item{PER}{Stress Period}
#' \item{TIME}{Elapsed Time}
#' \item{LAY}{Model Layer}
#' \item{ROW}{Model Row}
#' \item{COL}{Model Column}
#' \item{CONC}{Concentration}
#' }
#' @param ucname This is the name of the ucn file
#' @param NLAY This is the number of layers assigned to the model
#' @param NTTS This is the number of transport time steps that are printed to the .ucn file. This can be obtained from the .btn file.
#' This will cause an error if the value assigned is greater than the correct value. Future versions will need to be developed so that NTTS is not
#' needed for this function to operate properly.
#' @export
#' @examples
#' readucn("MT3DMS001S", NLAY = 8, NTTS = 22)

readucn <- function(ucrootname, NLAY, NTTS){
    # NLAY IS THE NUMBER OF LAYERS IN THE MODEL
    # NTTS IS THE NUMBER OF TRANSPORT TIME STEPS IN THE MODEL
    ucname <- paste(ucrootname, ".ucn", sep = "")
    to.read <- file(ucname, "rb")
    TRANS <- c()
    STP <- c()
    PER <- c()
    TIME <- c()
    TEXT <- c()
    LAY <- c()
    CONC <- c()
    dat <- c()
    readblock <- function(){
            TRANS <- readBin(to.read, integer(), n = 1)
            STP <- readBin(to.read, integer(), n = 1)
            PER <- readBin(to.read, integer(), n = 1)
            TIME <- readBin(to.read, double(), size = 4, n = 1)
            TEXT <- readChar(to.read, 16)
            NC <- readBin(to.read, integer(), n = 1)
            NR <- readBin(to.read, integer(), n = 1)
            LAY <- readBin(to.read, integer(), n = 1)
            CONC <- readBin(to.read, double(), size = 4, n = NR * NC, endian = "little")
            out <- list(TRANS, STP, PER, TIME, TEXT, NC, NR, LAY, CONC)
            return(out)
        }
    for(Q in 1:NTTS){
        for(K in 1:NLAY){
            dat[[length(dat) + 1]] <- readblock()
        }
    }
    close(to.read)
    TRANS <- sapply(dat, "[[", 1)
    STP <- sapply(dat, "[[", 2)
    PER <- sapply(dat, "[[", 3)
    TIME <- sapply(dat, "[[", 4)
    LAY <- sapply(dat, "[[", 8)
    NC <- dat[[1]][6] %>% as.integer
    NR <- dat[[1]][7] %>% as.integer
    CONC <- sapply(dat, "[[", 9)
    UCN <- tibble::data_frame(
           TRANS = rep(TRANS, each = (NC * NR)) %>% as.integer(),
           STP = rep(STP, each = (NC * NR)) %>% as.integer(),
           PER = rep(PER, each = (NC * NR)) %>% as.integer(),
           TIME = rep(TIME, each = (NC * NR)) %>% as.double(),
           LAY = rep(LAY, each = (NC * NR)) %>% as.integer(),
           ROW = rep(rep(rep(1:NR, each = NC), NLAY), NTTS) %>% as.integer(),
           COL = rep(rep(rep(seq(1, NC, 1), NR), NLAY), NTTS) %>% as.integer(),
           CONC = CONC %>% as.double()
           )
    rm(TRANS)
    rm(STP)
    rm(CONC)
    rm(LAY)
    rm(NR)
    rm(NC)
    rm(TEXT)
    rm(TIME)
    rm(PER)
    rm(dat)
    gc()
    return(UCN)
    }


## differential gene expression
## Please use gene symbol
## Biological replicates for each sample; no techinical ones, if there are techinical replicates, please combine them.

args <- commandArgs(trailingOnly=TRUE)
expression.file <- args[1]
class.file <- args[2]
exp.format <- args[3]
out.path <- args[4]
err.file <- args[5]

is.installed <- function(mypkg) is.element(mypkg, installed.packages()[,1])
expression.data <- read.table(expression.file,header=T,row.names=1,sep="\t",check.names=FALSE)
myclass = read.table(class.file,row.names=1,check.names=FALSE)

if (dim(expression.data)[2] != dim(myclass)[1]){
	write("Error: Differential gene expression analysis - number of samples in expression does not qual to number of class labels...",file=err.file)
	stop("Number of samples in expression does not qual to number of class labels...")
}
if (length(unique(myclass[,1])) !=2 || length(grep("benign",myclass[,1],ignore.case=TRUE)) == 0){
	write("Error: Differential gene expression analysis - sample classes are not correct...",file=err.file)
	stop("Sample classes are not correct...")
}

myfactors = data.frame(Tissue=myclass[colnames(expression.data),1])
if(exp.format == "rpkm"){

	if(is.installed("NOISeq")){
	}else{
		source("http://bioconductor.org/biocLite.R")
		biocLite("NOISeq")
	}

	suppressMessages(library(NOISeq))
	mydata <- readData(data=expression.data,factors=myfactors)

	if (length(myfactors[,1]) == 2){
		myresults <- noiseq(mydata, factor = "Tissue", k = NULL, norm = "n", replicates = "no")
		mynoiseq.deup = rownames(degenes(myresults,q=0.9,M="up"))
		mynoiseq.dedown = rownames(degenes(myresults,q=0.9,M="down"))
		pdf(file=paste(out.path,"/DE.pdf",sep=""))
		DE.plot(myresults,q=0.9,graphic="expr",log.scale=TRUE)
		dev.off()
	}else{
		myresults = noiseqbio(mydata,factor="Tissue",norm="n",r=20, k=0, a0per = NULL)
		mynoiseq.deup = rownames(degenes(myresults,q=0.95,M="up"))
		mynoiseq.dedown = rownames(degenes(myresults,q=0.95,M="down"))
		pdf(file=paste(out.path,"/DE.pdf",sep=""))
		DE.plot(myresults,q=0.95,graphic="expr",log.scale=TRUE)
		dev.off()
	}

	condition.1=gsub("_mean","",colnames(as.matrix(myresults@results[[1]]))[1])
	condition.2=gsub("_mean","",colnames(as.matrix(myresults@results[[1]]))[2])

	output = rbind(cbind(mynoiseq.deup,rep(condition.1, length(mynoiseq.deup))), cbind(mynoiseq.dedown, rep(condition.2,length(mynoiseq.dedown))))
	write.table(output, file=paste(out.path,"/DE.gene.txt",sep=""),sep="\t",quote=F,row.names=F,col.names=F)

}else{
	if(is.installed("DESeq")){
	}else{
	    source("http://bioconductor.org/biocLite.R")
    	biocLite("DESeq")
	}
	suppressMessages(library(DESeq))
	condition = factor(myfactors[,"Tissue"])
	mydata <- newCountDataSet(expression.data,condition)
	mydata = estimateSizeFactors( mydata )

	if (length(myfactors[,1]) == 2){
		mydata = estimateDispersions( mydata, method="blind", sharingMode="fit-only" )
		myresults = nbinomTest(mydata,unique(condition)[1],unique(condition)[2])
		pdf(file=paste(out.path,"/DE.pdf",sep=""))
			plotMA(myresults, col = ifelse(myresults$padj>=0.1, "gray32", "red3"))
		dev.off()
		resSig = myresults[ (myresults$padj <= 0.1 & is.na(myresults$padj)==FALSE), ]
		my.deup = resSig[resSig$foldChange<1,]
		my.dedown = resSig[resSig$foldChange>1,]
	}else{
		mydata = estimateDispersions( mydata )
		myresults = nbinomTest(mydata,unique(condition)[1],unique(condition)[2])
		pdf(file=paste(out.path,"/DE.pdf",sep=""))
			plotMA(myresults, col = ifelse(myresults$padj>=0.05, "gray32", "red3"))
		dev.off()
		resSig = myresults[ (myresults$padj <= 0.05 & is.na(myresults$padj)==FALSE), ]
		my.deup = resSig[resSig$foldChange<1,]
		my.dedown = resSig[resSig$foldChange>1,]
	}

	output = rbind(cbind(my.deup$id,as.character(rep(unique(condition)[1], dim(my.deup)[1])),my.deup$foldChange,my.deup$padj), cbind(my.dedown$id, as.character(rep(unique(condition)[2],dim(my.dedown)[1])),my.dedown$foldChange,my.dedown$padj))
	write.table(output, file=paste(out.path,"/DE.gene.txt",sep=""),sep="\t",quote=F,row.names=F,col.names=F)
}