initializeLncPathEnvir<-function(){
##initialize the environment variable;
   utils::data("LncPathEnvir",package="LncPath");
}

##RandomWalk function
RandomWalk2igraph<-function(igraphM,VertexWeight,EdgeWeight=TRUE,gamma=0.7){
        ##igraphM: an object of class igraph for random walk to perform;
        ##VertexWeight: a vector of the vertex weights, for unweithted strategy, 1 indicates seed vertex, 0 else;
        ##EdgeWeight: logical, if the weight of edge should be take into consideration;
#        print("now, do the random walk:");
#        print(Sys.time());
      if(EdgeWeight==TRUE){
        adjM<-get.adjacency(igraphM,attr="weight") # convert igraph object to a weight matrix
      }
      if(EdgeWeight==FALSE){
        adjM<-get.adjacency(igraphM) # convert igraph object to a conventional matrix
      }
      res<-rw(adjM,VertexWeight,gamma)
#        print(Sys.time());
      return(drop(res))
}

rw<-function(W,p0,gamma) {
## perform a random walk;
      p0<-t(p0)
      p0 <- p0/sum(p0)
      PT <- p0
      k <- 0
      delta <- 1
      Ng <- dim(W)[2]
      for (i in 1:Ng) {
        sumr<-sum(W[i,])
        if(sumr==0){
        W[i,] <-numeric(length=length(W[i,]))
        }
        if(sumr>0){
        W[i,] <- W[i,]/sum(W[i,])
        }
     }
     W<-as.matrix(W)
     W <- t(W)

     while(delta>1e-10) {
      PT1 <- (1-gamma)*W
      PT2 <- PT1 %*% t(PT)
      PT3 <- (gamma*p0)
      PT4 <- t(PT2) + PT3
      delta <- sum(abs(PT4 - PT))
      PT <- PT4
      k <- k + 1
    }
    PT<-t(PT)
    rownames(PT)<-NULL
    return(PT)
}

lncPath.EnrichmentScore <- function(gene.list, gene.set, weighted.score.type = 1, correl.vector = NULL) {
#
# Computes the weighted GSEA score of gene.set in gene.list.
# The weighted score type is the exponent of the correlation
# weight: 0 (unweighted = Kolmogorov-Smirnov), 1 (weighted), and 2 (over-weighted). When the score type is 1 or 2 it is
# necessary to input the correlation vector with the values in the same order as in the gene list.
#
# Inputs:
#   gene.list: The ordered gene list (e.g. integers indicating the original position in the input dataset)
#   gene.set: A gene set (e.g. integers indicating the location of those genes in the input dataset)
#   weighted.score.type: Type of score: weight: 0 (unweighted = Kolmogorov-Smirnov), 1 (weighted), and 2 (over-weighted)
#  correl.vector: A vector with the coorelations (e.g. signal to noise scores) corresponding to the genes in the gene list
#
# Outputs:
#   ES: Enrichment score (real number between -1 and +1)
#   arg.ES: Location in gene.list where the peak running enrichment occurs (peak of the "mountain")
#   RES: Numerical vector containing the running enrichment score for all locations in the gene list
#   tag.indicator: Binary vector indicating the location of the gene sets (1's) in the gene list
#
# The Broad Institute
# SOFTWARE COPYRIGHT NOTICE AGREEMENT
# This software and its documentation are copyright 2003 by the
# Broad Institute/Massachusetts Institute of Technology.
# All rights are reserved.
#
# This software is supplied without any warranty or guaranteed support
# whatsoever. Neither the Broad Institute nor MIT can be responsible for
# its use, misuse, or functionality.
   tag.indicator <- sign(match(gene.list, gene.set, nomatch=0))    # notice that the sign is 0 (no tag) or 1 (tag)
   no.tag.indicator <- 1 - tag.indicator
   N <- length(gene.list)
   Nh <- length(gene.set)
   Nm <-  N - Nh
   if (weighted.score.type == 0) {
      correl.vector <- rep(1, N)
   }
   alpha <- weighted.score.type
   correl.vector <- abs(correl.vector**alpha)
   sum.correl.tag    <- sum(correl.vector[tag.indicator == 1])
   norm.tag    <- 1.0/sum.correl.tag
   norm.no.tag <- 1.0/Nm
   RES <- cumsum(tag.indicator * correl.vector * norm.tag - no.tag.indicator * norm.no.tag)
   max.ES <- max(RES)
   min.ES <- min(RES)
   if (max.ES > - min.ES) {
#      ES <- max.ES
      ES <- signif(max.ES, digits = 5)
      arg.ES <- which.max(RES)
   } else {
#      ES <- min.ES
      ES <- signif(min.ES, digits=5)
      arg.ES <- which.min(RES)
   }
   return(list(ES = ES, arg.ES = arg.ES, RES = RES, indicator = tag.indicator))
}

lncPath.EnrichmentScore2 <- function(gene.list, gene.set, weighted.score.type = 1, correl.vector = NULL) {
#
# Computes the weighted GSEA score of gene.set in gene.list. It is the same calculation as in
# lncPath.EnrichmentScore but faster (x8) without producing the RES, arg.RES and tag.indicator outputs.
# This call is intended to be used to asses the enrichment of random permutations rather than the
# observed one.
# The weighted score type is the exponent of the correlation
# weight: 0 (unweighted = Kolmogorov-Smirnov), 1 (weighted), and 2 (over-weighted). When the score type is 1 or 2 it is
# necessary to input the correlation vector with the values in the same order as in the gene list.
#
# Inputs:
#   gene.list: The ordered gene list (e.g. integers indicating the original position in the input dataset)
#   gene.set: A gene set (e.g. integers indicating the location of those genes in the input dataset)
#   weighted.score.type: Type of score: weight: 0 (unweighted = Kolmogorov-Smirnov), 1 (weighted), and 2 (over-weighted)
#  correl.vector: A vector with the coorelations (e.g. signal to noise scores) corresponding to the genes in the gene list
#
# Outputs:
#   ES: Enrichment score (real number between -1 and +1)
#
# The Broad Institute
# SOFTWARE COPYRIGHT NOTICE AGREEMENT
# This software and its documentation are copyright 2003 by the
# Broad Institute/Massachusetts Institute of Technology.
# All rights are reserved.
#
# This software is supplied without any warranty or guaranteed support
# whatsoever. Neither the Broad Institute nor MIT can be responsible for
# its use, misuse, or functionality.

   N <- length(gene.list)
   Nh <- length(gene.set)
   Nm <-  N - Nh

   loc.vector <- vector(length=N, mode="numeric")
   peak.res.vector <- vector(length=Nh, mode="numeric")
   valley.res.vector <- vector(length=Nh, mode="numeric")
   tag.correl.vector <- vector(length=Nh, mode="numeric")
   tag.diff.vector <- vector(length=Nh, mode="numeric")
   tag.loc.vector <- vector(length=Nh, mode="numeric")

   loc.vector[gene.list] <- seq(1, N)
   tag.loc.vector <- loc.vector[gene.set]

   tag.loc.vector <- sort(tag.loc.vector, decreasing = F)

   if (weighted.score.type == 0) {
      tag.correl.vector <- rep(1, Nh)
   } else if (weighted.score.type == 1) {
      tag.correl.vector <- correl.vector[tag.loc.vector]
      tag.correl.vector <- abs(tag.correl.vector)
   } else if (weighted.score.type == 2) {
      tag.correl.vector <- correl.vector[tag.loc.vector]*correl.vector[tag.loc.vector]
      tag.correl.vector <- abs(tag.correl.vector)
   } else {
      tag.correl.vector <- correl.vector[tag.loc.vector]**weighted.score.type
      tag.correl.vector <- abs(tag.correl.vector)
   }

   norm.tag <- 1.0/sum(tag.correl.vector)
   tag.correl.vector <- tag.correl.vector * norm.tag
   norm.no.tag <- 1.0/Nm
   tag.diff.vector[1] <- (tag.loc.vector[1] - 1)
   tag.diff.vector[2:Nh] <- tag.loc.vector[2:Nh] - tag.loc.vector[1:(Nh - 1)] - 1
   tag.diff.vector <- tag.diff.vector * norm.no.tag
   peak.res.vector <- cumsum(tag.correl.vector - tag.diff.vector)
   valley.res.vector <- peak.res.vector - tag.correl.vector
   max.ES <- max(peak.res.vector)
   min.ES <- min(valley.res.vector)
   ES <- signif(ifelse(max.ES > - min.ES, max.ES, min.ES), digits=5)

   return(list(ES = ES))

}

ESNorm <- function(ESs){
        ## Perform a standarization for the ES scores;
        pos.m <- mean(ESs[which(ESs >= 0)]);
        neg.m <- mean(abs(ESs[which(ESs < 0)]));
        ESs[which(ESs >= 0)] <- ESs[which(ESs >= 0)]/pos.m;
        ESs[which(ESs < 0)] <- ESs[which(ESs < 0)]/neg.m;
        return(ESs);
}

lncPath.HeatMapPlot <- function(V, row.names = F, col.labels, col.classes, col.names = F, main = " ", xlab=" ", ylab=" ") {

# Plots a heatmap "pinkogram" of a gene expression matrix including phenotype vector and gene, sample and phenotype labels

       n.rows <- length(V[,1])

       n.cols <- length(V[1,])

       row.mean <- apply(V, MARGIN=1, FUN=mean)

       row.sd <- apply(V, MARGIN=1, FUN=sd)

       row.n <- length(V[,1])

       for (i in 1:n.rows) {

           if (row.sd[i] == 0) {

               V[i,] <- 0

           } else {

               V[i,] <- (V[i,] - row.mean[i])/(0.5 * row.sd[i])

           }

           V[i,] <- ifelse(V[i,] < -6, -6, V[i,])

           V[i,] <- ifelse(V[i,] > 6, 6, V[i,])

        }

        mycol <- c("#0000FF", "#0000FF", "#4040FF", "#7070FF", "#8888FF", "#A9A9FF", "#D5D5FF", "#EEE5EE", "#FFAADA", "#FF9DB0", "#FF7080", "#FF5A5A", "#FF4040", "#FF0D1D", "#FF0000") # blue-pinkogram colors. The first and last are the colors to indicate the class vector (phenotype). This is the 1998-vintage, pre-gene cluster, original pinkogram color map

        mid.range.V <- mean(range(V)) - 0.1

        heatm <- matrix(0, nrow = n.rows + 1, ncol = n.cols)

        heatm[1:n.rows,] <- V[seq(n.rows, 1, -1),]

        heatm[n.rows + 1,] <- ifelse(col.labels == 0, 7, -7)

        image(1:n.cols, 1:(n.rows + 1), t(heatm), col=mycol, axes=FALSE, main=main, xlab= xlab, ylab=ylab)

        if (length(row.names) > 1) {

            numC <- nchar(row.names)

            size.row.char <- 35/(n.rows + 5)

            size.col.char <- 25/(n.cols + 5)

            maxl <- floor(n.rows/1.6)

            for (i in 1:n.rows) {

               row.names[i] <- substr(row.names[i], 1, maxl)

            }

            row.names <- c(row.names[seq(n.rows, 1, -1)], "Class")

            axis(2, at=1:(n.rows + 1), labels=row.names, adj= 0.5, tick=FALSE, las = 1, cex.axis=size.row.char, font.axis=2, line=-1)

        }

        if (length(col.names) > 1) {

           axis(1, at=1:n.cols, labels=col.names, tick=FALSE, las = 3, cex.axis=size.col.char, font.axis=2, line=-1)

        }

        C <- split(col.labels, col.labels)

        class1.size <- length(C[[1]])

        class2.size <- length(C[[2]])

        axis(3, at=c(floor(class1.size/2),class1.size + floor(class2.size/2)), labels=col.classes, tick=FALSE, las = 1, cex.axis=1.25, font.axis=2, line=-1)

        return()

}

#########################Differencial Analysis
##### T Test, for a given expression, it performs two-sample t-test for case and control group, in labels,
##### 0 represents case,1 represents control
calT <- function(inData, classLabel) {
                ## inData: a data frame, represents the expression profile to be tested;
                ## classLabel: a vector of 01s, represents the tags of case and control teams;
        m <- length(ind1 <- which(classLabel == 1))
        n <- length(ind2 <- which(classLabel == 0))
        inData1 <- inData[, ind1]
        inData2 <- inData[, ind2]
        rmean1 <- rowMeans(inData1)
        rmean2 <- rowMeans(inData2)
        ss1 <- rowSums((inData1 - rmean1)^2)
        ss2 <- rowSums((inData2 - rmean2)^2)
        tt <- (m + n - 2)^0.5 * (rmean2 - rmean1)/((1/m + 1/n) *
            (ss1 + ss2))^0.5
        return(list(T = tt, df = m + n - 2))
    }

calFD <- function(inData, classLabel) {
       ## inData: a data frame, represents the expression profile to be tested;
       ## classLabel: a vector of 01s, represents the tags of case and control teams;

        case <- inData[, which(classLabel == 0)];
        control <- inData[, which(classLabel == 1)];
       outData1 <- unname(as.matrix(case))
       outData2 <- unname(as.matrix(control))
       rmean1 <- rowMeans(apply(outData1, 2,as.numeric))
       rmean2 <- rowMeans(apply(outData2, 2,as.numeric))
       fd <- (rmean1/rmean2);
       logfd <- log(fd, 2);
       Result <- as.data.frame(cbind(rownames(inData), fd, logfd));
        names(Result) <- c("ID", "FoldChange", "Log2FoldChange");
       return(Result);
}


####ZIGDM_EM usage

####library(DMBC)
####library(Rlab)

#' @export
#'

####First step: generate pi
Bernoulli <- function(c.est, row) {

  #pi = exp(c.est %*% row)/(1+exp(c.est %*% row))
  pi = 0
  Delta = rbern(dim(c.est)[1], pi)
  return (Delta)
}

####Second step: generate Z
Zvalue_Generator <- function(Delta,Test_result, row2, row3) {

  Beta_mean = exp(Test_result$alpha.est %*% row2)/(1+exp(Test_result$alpha.est %*% row2))
  Beta_dispersion = exp(Test_result$beta.est %*% row3)/(1+exp(Test_result$beta.est %*% row3))
  Data_Matrix = cbind(as.matrix(Delta),Beta_mean,Beta_dispersion)

  test = apply(Data_Matrix, 1, RandomGenerate_beta)
  return(test)
}

RandomGenerate_beta <- function(input) {
    delta = input[1]
    beta_mean =input[2]
    beta_dispersion = input[3]

   if (delta ==1) {
      Z = 0
    }else{
      shape1= beta_mean*(1/beta_dispersion)-beta_mean
      shape2 = (1-beta_mean)*(1/beta_dispersion -1)
      Z = rbeta(1, shape1, shape2, ncp = 0)
    }
  return(Z)
  }

####Third step: generate p for multinormail distribution
multinormial_P <- function(Z) {
  P= list()
  P[1] = Z[1]
  if(length(Z)>1) {
    for (j in 2:length(Z)) {
      multiply =1
      for(k in 1:(j-1)) {
        multiply = multiply*(1-Z[k])
      }
      P[j] = Z[j]*multiply
    }
  }
  P= unlist(P)
  return(P)
}

################ Run below functions before calling
## The function ZIGDM.EM.PAR2 estimates three sets of regression coefficients "c", "alpha", and "beta" in the ZIGDM regression model.

## Input
# Y: taxa count matrix.
# Xc, Xa, Xb: design matrices for probability of absence model, mean model and dispersion model, respectively. The first column should contain "1" for the intercept. For intercept only model, the three matrices are simply contain vectors of 1.
# c0: initial values for regression coefficients "c" organized in a matrix (dim: K x d, K+1 is the #taxa (i.e. K+1 = ncol(Y)), d is the number of columns in the corresponding design matrix)
# alpha0: initial values for regression coefficients "alpha" organized in a matrix (dim: K x d)
# beta0: initial values for regression coefficients "beta" organized in a matrix (dim: K x d)
# tol: convergence tolerance
# max.iter: maximum number of iterations

## output
# c.est: regression coefficient for the probability of absence organized in a matrix. The probabilities of absence for all the taxa in sample i can then be calculated as exp(c.est %*% Xc[i,])/(1+exp(c.est %*% Xc[i,]))
# alpha.est: regression coefficient for the Beta mean parameter organized in a matrix. The Beta means for all the taxa in sample i  can then be calculated as exp(alpha.est %*% Xa[i,])/(1+exp(alpha.est %*% Xa[i,]))
# beta.est: regression coefficient for the Beta dispersion parameter organized in a matrix. The Beta dispersions for all the taxa in sample i can then be calculated as exp(beta.est %*% Xb[i,])/(1+exp(beta.est %*% Xb[i,]))

## Two important remarks:
## 1. Sort the taxa as Y = Y[,order( colSums(Y), decreasing = TRUE )] before run the analysis
## 2. If you don't want to have zero-inflation on a certain subset of taxa, just set the elements of the corresponding columns in c0 to -Inf.
##    So to fit the GDM model, all elements in c0 matrix should be set to -Inf

ZIGDM.EM.PAR2 <- function(Y, Xc, Xa, Xb, c0, alpha0, beta0, tol=0.0001, max.iter=1000){
  Y = Y[,order( colSums(Y), decreasing = TRUE )]
  CONV = 0
  CONV.iter = max.iter
  n = nrow(Y)
  K = ncol(Y)-1
  dc = ncol(Xc)
  da = ncol(Xa)
  db = ncol(Xb)

  c.last = c0; alpha.last = alpha0; beta.last = beta0;
  c.now = c0; alpha.now = alpha0; beta.now = beta0;

  Del.R = matrix(NA, n, K)
  A.R = matrix(NA, n, K)
  B.R = matrix(NA, n, K)

  for(l in 1:max.iter){

    # E-step

    # print(paste("====== ", l, "th ======", sep=""))
    for(i in 1:n){

      tmp = exp(c.last %*% Xc[i,])
      tmp[is.na(tmp)] = 0
      pv = as.numeric( tmp/(1+tmp) )
      pv[is.infinite(tmp) & tmp>0] =1  # positive inf

      tmp = exp(alpha.last %*% Xa[i,])
      mv = as.numeric( tmp/(1+tmp) )
      tmp = exp(beta.last %*% Xb[i,])
      sv = as.numeric( tmp/(1+tmp) )

      av = (1/sv - 1) * mv
      bv = (1/sv - 1) * (1-mv)

      par.post = rP.Y.par(pv, av, bv, Y[i,])

      Del.R[i, ] = par.post$pv.post
      tmp = par.post$av.post + par.post$bv.post
      #A.R[i, ] = digamma(par.post$av.post) - digamma(tmp)
      #B.R[i, ] = digamma(par.post$bv.post) - digamma(tmp)

      A.R[i, ] = as.matrix(digamma(par.post$av.post) - digamma(tmp))
      B.R[i, ] = as.matrix(digamma(par.post$bv.post) - digamma(tmp))

    }

    # M-step
    for(j in 1:K){

      if( !is.infinite(c.last[j,1]) ){
        c.now[j, ] = Logit.optim(Del.R[,j], Xc, c.last[j, ])
      }

      tmp = Beta.optim.PAR2(Del.R[,j], A.R[,j], B.R[,j], Xa, Xb, alpha.last[j, ], beta.last[j, ])
      alpha.now[j, ] = tmp[1:da]; beta.now[j, ] = tmp[-(1:da)]

    }

    diff = 0
    if( sum(!is.infinite(c.now))>0 ){

      diff = diff + sum(abs(c.now[!is.infinite(c.now)]-c.last[!is.infinite(c.now)]))

    }

    diff = diff + sum(abs(alpha.now-alpha.last))
    diff = diff + sum(abs(beta.now-beta.last))
    if( diff < tol ){

      CONV = 1; CONV.iter = l;
      break;

    }else{

      c.last = c.now; alpha.last = alpha.now; beta.last = beta.now;
    }

  }

  return(list(c.est = c.now, alpha.est = alpha.now, beta.est = beta.now, CONV=CONV, CONV.iter = CONV.iter))

}

rP.Y.par <- function(pv, av, bv, Y){

  K = length(Y)-1
  N = sum(Y)

  pv.post = rep(0, K)

  av.prim = av + Y[1:K]
  bv.prim = bv
  for(j in 1:K){
    bv.prim[j] = bv.prim[j] + (N - sum(Y[1:j]))

    if(Y[j]==0){

      if(beta(av[j], bv[j])==0){

        pv.post[j] = pv[j]/(pv[j] + (1-pv[j]))

      }else{
        tmp = pv[j] + (1-pv[j])*beta(as.numeric(av.prim[j]), bv.prim[j])/beta(av[j], bv[j])
        #tmp = pv[j] + (1-pv[j])*beta(av.prim[j], bv.prim[j])/beta(av[j], bv[j])
        if(tmp==0){
          pv.post[j] = 1
        }else{
          pv.post[j] = pv[j]/tmp
        }

      }

    }

  }

  return(list(pv.post = pv.post, av.post = av.prim, bv.post = bv.prim))
}

lbeta2 <- function(a,b){
  a[a<0] = 0
  b[b<0] = 0
  return(lbeta(a,b))
}

Logit.neg.loglik <- function(par, data){

  tmp = as.numeric( exp(  data$X %*% par ) )
  p = tmp/(1+tmp)
  tmp = data$Del * log(p) + (1-data$Del) * log(1-p)
  index = which(p==0 | p==1)
  if(length(index)>0){
    tmp[index] = 0
  }

  return( -sum( tmp) )

}

Logit.neg.score <- function(par, data){

  tmp = as.numeric( exp(  data$X %*% par ) )
  p = tmp/(1+tmp)
  return( -colSums( (data$Del - p) * data$X ) )

}

Logit.optim <- function(Del, X, c.ini){

  Logit.par.ini = c.ini
  Logit.data = list(Del=Del, X=X)

  return( optim(par=Logit.par.ini, fn=Logit.neg.loglik, gr=Logit.neg.score, data = Logit.data, method="BFGS")$par)

}

Beta.neg.loglik.PAR2 <- function(par, data){

  da = ncol(data$Xa)
  alpha = par[1:da]
  beta = par[-(1:da)]

  tmp = as.numeric( exp( data$Xa %*% alpha) )
  mu.tmp = as.numeric( tmp/(1+tmp) )

  tmp = as.numeric( exp( data$Xb %*% beta) )
  sigma.tmp = as.numeric( tmp/(1+tmp) )

  a = (1/sigma.tmp - 1) * mu.tmp
  b = (1/sigma.tmp - 1) * (1-mu.tmp)
  a[a<0] = 0
  b[b<0] = 0

  return( -sum( (1-data$Del) * ( -lbeta2(a,b) + data$A * (a-1) + data$B *(b-1) )  ) )

}

Beta.neg.score.PAR2 <- function(par, data){

  da = ncol(data$Xa)
  alpha = par[1:da]
  beta = par[-(1:da)]

  tmp.a = as.numeric( exp( data$Xa %*% alpha) )
  mu.tmp = as.numeric( tmp.a/(1+tmp.a) )

  tmp.b = as.numeric( exp( data$Xb %*% beta) )
  sigma.tmp = as.numeric( tmp.b/(1+tmp.b) )

  a = (1/sigma.tmp - 1) * mu.tmp
  b = (1/sigma.tmp - 1) * (1-mu.tmp)
  a[a<0] = 0
  b[b<0] = 0

  a.a = (1/tmp.b) * mu.tmp * (1/(1+tmp.a))
  a.b = -(1/tmp.b) * mu.tmp
  b.a = - a.a
  b.b = -(1/tmp.b) *  (1/(1+tmp.a))

  one = (1-data$Del)*(digamma(a+b)-digamma(a) + data$A)
  two = (1-data$Del)*(digamma(a+b)-digamma(b) + data$B)

  return( -c( colSums( (one*a.a + two*b.a) * data$Xa ), colSums( (one*a.b + two*b.b) * data$Xb ) ) )
}

Beta.optim.PAR2 <- function(Del, A, B, Xa, Xb, alpha.ini, beta.ini){

  Beta.par.ini = c(alpha.ini, beta.ini)
  Beta.data = list(Del=Del, A=A, B=B, Xa=Xa, Xb=Xb)

  return( optim(par=Beta.par.ini, fn=Beta.neg.loglik.PAR2, gr=Beta.neg.score.PAR2, data = Beta.data, method="BFGS")$par)

}


library(jsonlite)
library(rstan)
library(EnvStats)
stan_data <- jsonlite::fromJSON("Python/notebooks/test.json")
stan_data$SI <- dgammaAlt(c(1:130), mean=6.5, cv=0.62)
options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)
m = stan_model(paste0('stan-models/',"county_mobility",'.stan'))
fit = sampling(m,data=stan_data,iter=40,warmup=20,chains=2)


# MESMA (multiple-endmember spectral unmixing) module
# At the moment, there is no advertised MESMA function for points.
# However, the RStoolbox::mesma() function is a wrapper for one:
# RStoolbox::nnls_solver(x=predict_matrix, A=endmember_matrix, iterate=400, tolerance=0.000001)
library(RStoolbox)
library(hydroGOF)

source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")
source("pixel-based/utils/crossvalidation.r")
source("pixel-based/utils/subpixel-confusion-matrix.r")
source("utils/accuracy-statistics.r")

Data.df = LoadTrainingAndCovariates()
#Data.df[is.na(Data.df)] = -9999
Data.df = st_set_geometry(Data.df, NULL)
#Data.df = AddZeroValueColumns(Data.df)
Data.df = TidyData(Data.df, drop.cols=NULL)

# Validation data
Data.val = LoadValidationAndCovariates()
Data.val[is.na(Data.val)] = -9999
#Val.sp = Data.val
Data.val = st_set_geometry(Data.val, NULL)
Data.val = TidyData(Data.val, drop.cols=NULL) # Drops around 1050
#Val.sp = Val.sp[rownames(Data.val),]

Classes = GetCommonClassNames()
Truth = Data.val[,Classes]

# Get pure points in training
PureThreshold = 100
PureData = Data.df[,Classes]>=PureThreshold
PureRows = apply(PureData, 1, any)
PureData = Data.df[PureRows, GetAllPixelCovars()]
#rownames(PureData) = Data.df[PureRows, "dominant_lc"]
EM = stats::aggregate(PureData, list(Data.df[PureRows, "dominant_lc"]), mean, na.rm=TRUE)
rownames(EM) = EM[,1]

MESMA = RStoolbox:::nnls_solver(as.matrix(Data.val[,GetAllPixelCovars()]), as.matrix(EM[,-1]), iterate=400, tolerance=0.000001)
colnames(MESMA) = c(rownames(EM), "RMSE")
# The result is unscaled!
MESMA = ScalePredictions(MESMA[,Classes], FALSE)

corval = cor(MESMA[,Classes], Truth[,Classes], use="pairwise.complete.obs")

corrplot::corrplot(corval, method="ellipse")
AccuracyStatisticsPlots(MESMA/100, Truth[,Classes]/100) # RMSE 46.1%, MAE 25.7%, significantly worse than intercept?!
SCM(MESMA/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE, scale=TRUE) # OA 10±0.3%, kappa 0.03±0.004
NSE(unlist(MESMA/100), unlist(Truth[,Classes]/100)) # -1.37, worse than intercept by far

## What if we only use spectral info
MESMAS = RStoolbox:::nnls_solver(as.matrix(Data.val[,GetAllPixelCovars(TRUE)$spectral]), as.matrix(EM[,GetAllPixelCovars(TRUE)$spectral]), iterate=400, tolerance=0.000001)
colnames(MESMAS) = c(rownames(EM), "RMSE")
# The result is unscaled!
MESMAS = ScalePredictions(MESMAS[,Classes], FALSE)
AccuracyStatisticsPlots(MESMAS/100, Truth[,Classes]/100) # RMSE 34.4%, MAE 19.0%, similar to intercept but at least trees, crops and water are fine now
SCM(MESMAS/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE, scale=TRUE) # OA 34±3%, kappa 0.22±0.04
NSE(unlist(MESMAS/100), unlist(Truth[,Classes]/100)) # -0.32, still a bit worse than intercept

# What if only yearly means
Covars = c("NDMI.year.median", "NIRv.year.median")
MESMAS = RStoolbox:::nnls_solver(as.matrix(Data.val[,Covars]), as.matrix(EM[,Covars]), iterate=400, tolerance=0.000001)
colnames(MESMAS) = c(rownames(EM), "RMSE")
# The result is unscaled!
MESMAS = ScalePredictions(MESMAS[,Classes], FALSE)
AccuracyStatisticsPlots(MESMAS/100, Truth[,Classes]/100) # RMSE 44.8%, MAE 25.1%, similar to intercept but at least trees, crops and water are fine now
SCM(MESMAS/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE, scale=TRUE) # OA 12±1%, kappa -0.00±0.02
NSE(unlist(MESMAS/100), unlist(Truth[,Classes]/100)) # -1.24


cbp <- 5
i <- 3
nbp2 <- 7

# correct (HC)
sites_c_hc <- full_data$sites %>%
  filter(!(tolower(ALT)==tolower(AA)))

prop <- nrow(sites_c_hc)/nrow(full_data$sites)
# prop <- 0.946

# SKIP THIS WHEN adj = 3
#sites_c_hc <- sites_c_hc %>%
#  mutate(SEQA=substr(Motif, cbp-i, cbp+i),
#    SEQB=substr(Motif, cbp*3-i, cbp*3+i),
#    Motif=paste0(SEQA, "(", SEQB, ")"))

bindir <- paste0(parentdir, "/motif_counts/", nbp2, "-mers/full")
p1 <- "motifs_full.txt"
bins <- get_bins(bindir, p1)
mct <- get_mct(bins)
ancaggseq <- get_aggseq(sites_c_hc, mct)

maskdir <- paste0(parentdir, "/motif_counts/", nbp2, "-mers/mask")
p1 <- "motifs_mask.txt"
maskbins <- get_bins(maskdir, p1)
maskmct <- get_mct(maskbins)
# grepl("^[[:upper:]]+$", s)
# ancaggseq <- get_aggseq(sites_c_hc, maskmct)
# rm(masktmp)

ancgpdat <- ancaggseq %>%
  mutate(Type=gsub("cpg_", "", Category2)) %>%
  dplyr::select(Type, Motif,
		nERVs_anc=nERVs, nMotifs_anc=nMotifs,
		ERV_rel_rate_anc=rel_prop)

ancgpdat <- merge(ratelist[[4]], ancgpdat, by=c("Type", "Motif"))

test_anc <- ancgpdat %>%
	# filter(nERVs >= 10 & nERVs_anc >= 10) %>%
  # mutate(pval=prop.test())
  group_by(Type, Motif) %>%
  do(tidy(prop.test(c(.$nERVs, .$nERVs_anc), c(.$nMotifs, .$nMotifs_anc*prop)))) %>%
  # do(tidy(prop.test(c(.$nERVs, .$nERVs_anc), c(.$nMotifs, .$nMotifs_anc*0.946)))) %>%
	dplyr::select(Type, Motif, estimate1, estimate2, statistic, p.value)

test_anc <- merge(test_anc, ancgpdat, by=c("Type", "Motif"))

sig_anc <- test_anc %>%
  filter(p.value<0.05/nrow(test_anc)) %>%
  mutate(prop=estimate1/estimate2,
    gt10=ifelse(abs(log(prop))>log(1.2), TRUE, FALSE)) %>%
	filter(gt10==TRUE) %>%
	arrange(desc(prop))

# anc_motifs <- test_anc %>%
#   ungroup() %>%
#   filter(p.value<0.05/nrow(test_anc)) %>%
#   dplyr::select(Motif)
#
# mask_motifs <- test_mask %>%
#   ungroup() %>%
#   filter(p.value<0.05/nrow(test_mask)) %>%
#   dplyr::select(Motif)
#
#
# sum(anc_motifs$Motif %in% mask_motifs$Motif)


#弯月面Meniscus的高度和角度随流量，极间距离，电压变化而变化
#针头三种液体，ethanol，acetone， isoproply
#height高度和angle角度，在一张图上，分为上下部分
#三张图，分别对应三种x轴，流量，极间距离，电压
#两张大图，分别对应height和angle
#函数名为men_eh & men_ea, men_ah & men_aa，men_ih & men_ia

#设定工作区间
setwd("D:/data")
library(xlsx)

#读取数据
men_eh<-read.xlsx("meniscus.xls",sheetName="flowrate_h",header=TRUE)
men_ea<-read.xlsx("meniscus.xls",sheetName="flowrate_a",header=TRUE)

men_ah<-read.xlsx("meniscus.xls",sheetName="distance_h",header=TRUE)
men_aa<-read.xlsx("meniscus.xls",sheetName="distance_a", header=TRUE)

men_ih<-read.xlsx("meniscus.xls",sheetName="voltage_h", header=TRUE)
men_ia<-read.xlsx("meniscus.xls",sheetName="voltage_a", header=TRUE)

#规划figure界面
par(mfrow=c(2,1), mar=c(4,4,2,2), oma=c(1,1,1,1))

#保存pdf
pdf("men_flowrate.pdf")

################################画图-高度曲线###########################
plot(men_eh$flowrate, men_eh$ethanol, col=0, xaxs="i", xlim=c(-0.002, 0.026), ylim=c(0.2, 0.8),
xlab="Flow rate (nl/min)", cex.lab=1, ylab="Height of Meniscus (mm)", main="Height with Q in meniscus")

lines(lowess(men_eh$flowrate, men_eh$ethanol), col="red", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_eh$flowrate, men_eh$acetone), col="blue", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_eh$flowrate, men_eh$iso), col="darkgreen", pch=21, lwd=2, type="b", lty=2)

legend("topleft", c("ethanol", "acetone", "isoproply"), inset=.02, col=c("red", "blue", "darkgreen"), pch=21, lwd=2, lty=2, cex=0.9)

##############################画图--角度曲线############################
plot(men_ea$flowrate, men_ea$ethanol, col=0, xlim=c(-0.002, 0.026), ylim=c(45, 100),
xlab="Flow rate (nl/min)", cex.lab=1, ylab="Taylor Angle (mm)", main="Angle with Q in meniscus")

lines(lowess(men_ea$flowrate, men_ea$ethanol), col="red", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ea$flowrate, men_ea$acetone), col="blue", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ea$flowrate, men_ea$iso), col="darkgreen", pch=21, lwd=2, type="b", lty=2)

legend("bottomleft", c("ethanol", "acetone", "isoproply"), inset=.02, col=c("red", "blue", "darkgreen"), pch=21, lwd=2, lty=2, cex=0.9)

dev.off()


score <- function(input) {
    var0 <- exp(subroutine0(input))
    var1 <- exp(subroutine1(input))
    var2 <- exp(subroutine2(input))
    var3 <- ((var0) + (var1)) + (var2)
    return(c((var0) / (var3), (var1) / (var3), (var2) / (var3)))
}
subroutine0 <- function(input) {
    return(((0.5) + (subroutine3(input))) + (subroutine4(input)))
}
subroutine1 <- function(input) {
    return(((0.5) + (subroutine5(input))) + (subroutine6(input)))
}
subroutine2 <- function(input) {
    return(((0.5) + (subroutine7(input))) + (subroutine8(input)))
}
subroutine3 <- function(input) {
    if ((input[3]) >= (2.45000005)) {
        var0 <- -0.0733167157
    } else {
        var0 <- 0.143414631
    }
    return(var0)
}
subroutine4 <- function(input) {
    if ((input[3]) >= (2.45000005)) {
        var0 <- -0.0706516728
    } else {
        var0 <- 0.125176534
    }
    return(var0)
}
subroutine5 <- function(input) {
    if ((input[3]) >= (2.45000005)) {
        if ((input[4]) >= (1.75)) {
            var0 <- -0.0668393895
        } else {
            var0 <- 0.123041473
        }
    } else {
        var0 <- -0.0717073306
    }
    return(var0)
}
subroutine6 <- function(input) {
    if ((input[3]) >= (2.45000005)) {
        if ((input[4]) >= (1.75)) {
            var0 <- -0.0642274022
        } else {
            var0 <- 0.10819874
        }
    } else {
        var0 <- -0.069036141
    }
    return(var0)
}
subroutine7 <- function(input) {
    if ((input[4]) >= (1.6500001)) {
        var0 <- 0.13432835
    } else {
        if ((input[3]) >= (4.94999981)) {
            var0 <- 0.0724137947
        } else {
            var0 <- -0.0732467622
        }
    }
    return(var0)
}
subroutine8 <- function(input) {
    if ((input[4]) >= (1.6500001)) {
        var0 <- 0.117797568
    } else {
        if ((input[3]) >= (4.94999981)) {
            var0 <- 0.0702545047
        } else {
            var0 <- -0.0706570372
        }
    }
    return(var0)
}


context("Test occDetModel")

# Create data
n <- 15000 #size of dataset
nyr <- 20 # number of years in data
nSamples <- 100 # set number of dates
nSites <- 50 # set number of sites
set.seed(125)

# Create somes dates
first <- as.Date(strptime("2010/01/01", "%Y/%m/%d"))
last <- as.Date(strptime(paste(2010+(nyr-1),"/12/31", sep=''), "%Y/%m/%d"))
dt <- last-first
rDates <- first + (runif(nSamples)*dt)

# taxa are set as random letters
taxa <- sample(letters, size = n, TRUE)

# three sites are visited randomly
site <- sample(paste('A', 1:nSites, sep=''), size = n, TRUE)

# the date of visit is selected at random from those created earlier
survey <- sample(rDates, size = n, TRUE)

df <- data.frame(taxa, site, survey)

test_that("Test occDetModel", {

  sink(file=ifelse(Sys.info()["sysname"] == "Windows",
                   "NUL",
                   "/dev/null"))
  suppressWarnings(results <- occDetModel(taxa = df$taxa,
                         write_results = FALSE,
                         site = df$site,
                         survey = df$survey,
                         species_list = c('a','m','g'),
                         n_iterations = 100,
                         burnin = 10,
                         thinning = 2,
                         seed = 111))
  sink()

  expect_identical(names(results), c('a','m','g'))
  expect_identical(names(results[[1]]),
                   c("model", "BUGSoutput", "parameters.to.save", "model.file",
                     "n.iter", "DIC", "SPP_NAME", "min_year", "max_year", "sites_included",
                     "nsites", "nvisits", "species_sites", "species_observations"))

})


# Team Rython: Dainius Masiliunas and Tim Weerman
# Date: January 2016
# License: Apache License 2.0

# Extracts the mean of the pixels from brick within the borders (polygons).
# colname refers to the name to give the values in the returned data frame.
# years is the years that the brick contains, in a numeric vector.
# Other parameters are passed to reshape.
# The output is also saved into output/dataframes/colname.csv by default.
ExtractWithinBorders = function(brick, borders, colname, years, filename="", idvar="Municipality", overwrite=FALSE, ...)
{
    if (filename == "")
        filename = paste("output/dataframes/", colname, ".csv", sep="")
    if (!file.exists(filename) || overwrite)
    {
        print(paste("Extracting data for", colname,"and saving it. This may take a few minutes."))
        # Extract information
        Extract = extract(brick, borders, fun=mean, df=TRUE, na.rm=TRUE)
        # Make Year into a column with multiple rows rather than a lot of columns in one row
        Extract = reshape(Extract, direction="long", varying=list(names(Extract)[2:(length(years)+1)]), v.names=colname, timevar="Year", idvar=idvar, times=years, ...)
        # Divide LAI by 10 as per MODIS manual
        Extract[[colname]] = Extract[[colname]] / 10.0
        # Save into a CSV so it doesn't have to be recalculated
        write.table(Extract, file=filename)
    }
    else
        Extract = read.table(filename)
    return(Extract)
}


#!/usr/bin/env Rscript

library(igraph)

argv = commandArgs(trailingOnly=TRUE)

## Read adjacency matrix
adjs = as.matrix(read.csv(argv[1], sep='\t', header=TRUE,
                          check.names=FALSE, comment.char=''))

## Make a graph
net = graph.adjacency(1-adjs, mode='undirected', weighted=TRUE, diag=FALSE)

## Edge names
e = attr(E(net), 'vnames')

## Calculate betweenness (takes a long time)
bet = estimate_betweenness(net, cutoff=5, directed=FALSE)
write.table(cbind(rep('vertex', length(bet)), names(bet), bet),
            file=stdout(), quote=FALSE, col.names=c('type', 'gene', 'betweenness'),
            row.names=FALSE)

ebet = estimate_edge_betweenness(net, cutoff=5, directed=FALSE)
write.table(cbind(rep('edge', length(ebet)), e, ebet),
            file=stdout(), quote=FALSE, col.names=FALSE, row.names=FALSE)


library(lattice)
xyplot(y~x)


calculate_infectiousness = function(states,out, JOBID) {
  infectiousness_all <- vector("list", length = length(states))
  all_data_out <- data.frame()
  for (i in 1:length(states)){
    state <- states[[i]]
    N <- length(dates[[i]])
    print(state)
    inf <- colMeans(out$infectiousness[,1:N,i])
    inf_li <- colQuantiles(out$infectiousness[,1:N,i],prob=.025)
    inf_ui <- colQuantiles(out$infectiousness[,1:N,i],prob=.975)
    inf_li2 <- colQuantiles(out$infectiousness[,1:N,i],prob=.25)
    inf_ui2 <- colQuantiles(out$infectiousness[,1:N,i],prob=.75)
    state_data  <- data.frame("date" = dates[[i]],
                              "state" = rep(state, length(dates[[i]])),
                              "infectioussness" = inf,
                              "infectioussness_li" = inf_li,
                              "infectioussness_ui" = inf_ui,
                              "infectioussness_li2" = inf_li2,
                              "infectioussness_ui2" = inf_ui2)
    infectiousness_all[[i]] <- state_data
    state_data_csv <- state_data[,c("date", "state", "infectioussness", "infectioussness_li", "infectioussness_ui")]
    colnames(state_data_csv) <- c("date", "state", "mean_infectious_individuals", "infectious_individuals_lower_CI_95", "infectious_individuals_higher_CI_95")
    all_data_out <- rbind(all_data_out, state_data_csv)
  }
  saveRDS(all_data_out, paste0("usa/results/", "infectious-individuals-out-",JOBID,".RDS"))
  saveRDS(infectiousness_all, paste0('usa/results/infectiousness_all_', JOBID, '.RDS'))
}


#' Format numeric data
#'
#' @description Format data as "10.500,25"
#'
#' @param x numeric vector
#' @param digits number of decimals digits
#' @param dec_mark decimal mark
#' @param mil_mark tgousand mark
#'
#' @return formatted data
#' @export
#'
#' @examples
#'
#' num_format(12345.67)
#'

num_format <- function(x, digits = 2,decimal_mark = ",",thousand_mark = "."){

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  if(is.numeric(digits) == F){
    stop("digits must be numeric")
  }

  formatC(x,
          format="f",
          big.mark = thousand_mark,
          digits = digits,
          decimal.mark = decimal_mark)

}


resources <- tribble(
  ~rid, ~rcapacity, ~rbandwidth, ~rnum,
  "L1",  32000,    201, 0,
  "L2",  1024000,  131, 0.25,
  #"L2",  1024000,  95.6,
  "LLC", 22528000, 39.4, 0.5,
  #"LLC", 22528000, 24.7,
  #"Memory", 100000000000, 3.6
  #"Memory", 100000000000, 7
  "Memory", 100000000000, 20.4, 0.75
  #"Memory", 100000000000, 18
  #"Memory", 100000000000, 13
)

bytes <- function(value, ds_entry) {
  value * ds_entry[['fpSize']]
}

get_ts_size_1d <- function(., xname='xmax', yname='ymax', zname = 'zmax') {
  # Original
  .[['TotalMats']] * .[[xname]]

  #Considering cache replacement policy
  #.[[xname]] - .[['LongDistanceMats']]
  #.[[xname]]
}
get_ts_size_2d <- function(., xname='xmax', yname='ymax', zname = 'zmax') {
  .[['TotalMats']] * .[[xname]] * .[[yname]]
}
get_ts_size_3d <- function(., xname='xmax', yname='ymax', zname = 'zmax') {
  .[['TotalMats']] * .[[xname]] * .[[yname]] * .[[zname]]
}

get_reuse_1d <- function(., xname='xmax', yname='ymax', zname = 'zmax') {
  .[[xname]] + .[['TotalMats']]
}
get_reuse_2d <- function(., xname='xmax', yname='ymax', zname = 'zmax') {
  .[['Oa']] * .[[xname]] + (.[['TotalMats']]*.[[xname]])

  # Make this more general for when we add coefficient matrices
  #.[['Oa']] * .[[xname]] + (.[['Oa']] * (.[['TotalMats']]*.[[xname]]))
}
get_reuse_3d <- function(., xname='xmax', yname='ymax', zname = 'zmax') {
  (.[['Dim']] - 1) * .[['Oa']] * .[[xname]] * .[[yname]] + (.[['Oa']] * (.[['TotalMats']]*.[[xname]]*.[[yname]]))
}

get_ts_size <- function(entry, xname, yname, zname) {
  #print("entry is")
  #print(entry)
  if(entry[['Dim']] == 1) {
    get_ts_size_1d(entry, xname=xname)
  }
  else if(entry[['Dim']] == 2) {
    get_ts_size_2d(entry, xname=xname, yname=yname)
  }
  else if(entry[['Dim']] == 3) {
    get_ts_size_3d(entry, xname=xname, yname=yname, zname=zname)
  }
  else {
    stop("unrecognized dimension")
  }
}

get_reuse_size <- function(entry, xname, yname, zname) {
  if(entry[['Dim']] == 1) {
    get_reuse_1d(entry, xname=xname, yname=yname, zname=zname)
  }
  else if(entry[['Dim']] == 2) {
    get_reuse_2d(entry, xname=xname, yname=yname, zname=zname)
  }
  else if(entry[['Dim']] == 3) {
    get_reuse_3d(entry, xname=xname, yname=yname, zname=zname)
  }
  else {
    stop("unrecognized dimension")
  }
}

check_bottleneck_generic <- function(resource, entry, size_func, reuse_func) {
  size <- size_func(entry) * entry[['fpSize']]
  if(size < resource[['rcapacity']]) {
    return(TRUE)
  }
  FALSE
}

print_if_2d <- function(...,entry) {
  print(paste(..., sep=' '))
}

block_rsrc_pred <- function(resource, entry) {
  # Does everything fit within the resource?
  ts_size <- bytes(get_ts_size(entry, xname='bx', yname='by', zname='bz'), entry)
  if(ts_size < resource[['rcapacity']]) {
    #print_if_2d('entry has ts within capacity', entry[['Dim']], ts_size, resource[['rid']], resource[['rcapacity']], entry=entry)
    return(TRUE)
  }

#  reuse_size <- bytes(get_reuse_size(entry, xname='bx', yname='by', zname='bz'), entry)
#  if(reuse_size < resource[['rcapacity']]) {
#    print_if_2d('2d entry has reuse within capacity', reuse_size, resource[['rid']], resource[['rcapacity']], entry=entry)
#    return(TRUE)
#  }
#  print(paste('ts:', ts_size, sep=' '))
#  print(paste('reuse :', reuse_size, sep=' '))
  FALSE
}

resource_pred <- function(resource, entry) {
  if(entry[['Dim']] == 1) {
    return(check_bottleneck_generic(resource, entry, get_ts_size_1d, get_reuse_1d))
  }
  else if(entry[['Dim']] == 2) {
    return(check_bottleneck_generic(resource, entry, get_ts_size_2d, get_reuse_2d))
  }
  else if(entry[['Dim']] == 3) {
    return(check_bottleneck_generic(resource, entry, get_ts_size_3d, get_reuse_3d))
  }
  else {
    stop("unrecognized dimension")
  }
}

get_reuse_distance_direct <- function(dim, oa, to, xmax, ymax, fpsize) {
  if(dim == 1) {
    v <- 1 * to
  }
  else if(dim == 2) {
    v <-xmax * oa-1 *to
  }
  else {
    v <- xmax * ymax * (oa*2-1) *to
  }

  v * fpsize
}

get_reuse_distance <- function(entry, xmax_name='xmax', ymax_name='ymax') {
  if(entry[['Dim']] == 1) {
    v <- 1 * entry[['To']]
  }
  else if(entry[['Dim']] == 2) {
    v <- entry[[xmax_name]] * (entry[['Oa']]-1) * entry[['To']]
  }
  else {
    v <- entry[[xmax_name]] * entry[[ymax_name]] * (entry[['Oa']]*2-1) * entry[['To']]
  }

  bytes(v, entry)
}

reuse_resource_predicate <- function(resource, entry) {
  # Does the shape allow data reuse?
  rd_size <- bytes(get_reuse_distance(entry, xmax_name='xmax', ymax_name='ymax'), entry)

  if(rd_size < resource[['rcapacity']]) {
    #print_if_2d('entry has ts within capacity', entry[['Dim']], ts_size, resource[['rid']], resource[['rcapacity']], entry=entry)
    return(TRUE)
  }

  FALSE
}

get_total_size <- function(entry, xmax_name='xmax', ymax_name='ymax', zmax_name='zmax') {
  bytes(get_ts_size(entry, xmax_name, ymax_name, zmax_name), entry)
}

get_cpi_slowdown <- function(entry) {
  if(entry[['divsLup']] > 0) {
    return(0.5)
  }
  1
}

pick <- function(entry, df2, predicate, ..., default=df2[4,]) {
#  return(df2[4,])
  for (i in seq_along(1:nrow(df2))) {
    row = df2[i,]
    if(predicate(row,entry,...))
      return(row)
  }
  default
}

set_blocksize <- function(entry) {

  if (entry[['optId']] == "orig") {
    tibble(
           bt = 1,
           bx = entry[['xmax']],
           by = entry[['ymax']],
           bz = entry[['zmax']]
           )
  }
  else if(entry[['Dim']] == 1) {
    tibble(
           bt = 128,
           bx = 512,
           by = -1,
           bz = -1
           )
  }
  else if(entry[['Dim']] == 2) {
    tibble(
           bt = 64,
           bx = 32,
           by = 256,
           bz = -1
           )
  }
  else if(entry[['Dim']] == 3) {
    tibble(
           bt = 64,
           bx = 32,
           by = 8,
           bz = 256
           )
  }
  else {
    stop("unrecognized dimension")
  }
}


#Title: Estimate fitting decay curve
#Auther: Naoto Imamachi
#ver: 1.0.0
#Date: 2015-10-08

###Estimate_normalization_factor_function###
BridgeRHalfLifeCalcModel3 <- function(filename = "BridgeR_4_Normalized_expression_dataset.txt", group, hour, InforColumn = 4, CutoffRelExp = 0.1, CutoffDataPoint = 3, OutputFile = "BridgeR_5B_HalfLife_calculation_3model.txt"){
    ###Prepare_file_infor###
    time_points <- length(hour)
    group_number <- length(group)
    input_file <- fread(filename, header=T)
    output_file <- OutputFile

    ###print_header###
    cat("",file=output_file)
    hour_label <- NULL
    for(a in 1:group_number){
        if(!is.null(hour_label)){
            cat("\t", file=output_file, append=T)
        }
        hour_label <- NULL
        for(x in hour){
            hour_label <- append(hour_label, paste("T", x, "_", a, sep=""))
        }
        infor_st <- 1 + (a - 1)*(time_points + InforColumn)
        infor_ed <- (InforColumn)*a + (a - 1)*time_points
        infor <- colnames(input_file)[infor_st:infor_ed]
        cat(infor,hour_label, sep="\t", file=output_file, append=T)
        cat("\t", sep="", file=output_file, append=T)
        cat("status","model1","cor1","a_1","half1_1","half1_2","AIC1","model2","cor2","a_2","b_2","half2",
            "AIC2","model3","cor3","a_3","b_3","c_3","half3","AIC3","selected_model","Selected_R2","Selected_HalfLife",sep="\t",file=output_file, append=T)
    }
    cat("\n", sep="", file=output_file, append=T)

    ###calc_RNA_half_lives###
    gene_number <- length(input_file[[1]])
    for(x in 1:gene_number){
        data <- as.vector(as.matrix(input_file[x,]))
        for(a in 1:group_number){
            if(a != 1){
                cat("\t", sep="", file=output_file, append=T)
            }
            infor_st <- 1 + (a - 1)*(time_points + InforColumn)
            infor_ed <- (InforColumn)*a + (a - 1)*time_points
            exp_st <- infor_ed + 1
            exp_ed <- infor_ed + time_points

            #Write_gene_infor
            gene_infor <- data[infor_st:infor_ed]
            cat(gene_infor, sep="\t", file=output_file, append=T)
            cat("\t", file=output_file, append=T)

            #Write_time_point_data
            exp <- as.numeric(data[exp_st:exp_ed])
            cat(exp, sep="\t", file=output_file, append=T)
            cat("\t", file=output_file, append=T)

            #make_hour-exp_dataframe
            time_point_exp <- data.frame(hour,exp)
            time_point_exp <- time_point_exp[time_point_exp$exp >= CutoffRelExp, ]
            data_point <- length(time_point_exp$exp)

            if(!is.null(time_point_exp)){
                if(data_point >= CutoffDataPoint){
                    cat("ok","\t",sep="",file=output_file,append=T)

                    ###Model1: f(t) = exp(-a * t)###
                    optim1 <- function(x){
                        mRNA_exp <- exp(-x * time_point_exp$hour)
                        sum((time_point_exp$exp - mRNA_exp)^2)
                    }

                    out1 <- optim(1,optim1)
                    min1 <- out1$value
                    a_1 <- out1$par[1]
                    half1_1 <- log(2) / a_1

                    model1_pred <- function(x){
                        mRNA_exp <- exp(-x * time_point_exp$hour)
                        (cor(mRNA_exp, time_point_exp$exp, method="pearson"))^2
                    }

                    cor1 <- model1_pred(a_1)

                    model1_half <- function(x){
                        mRNA_half <- exp(-a_1 * x)
                        (mRNA_half - 0.5)^2
                    }

                    out1 <- optim(1,model1_half)
                    half1_2 <- out1$par
                    mRNA_pred <- exp(-a_1 * time_point_exp$hour)
                    s2 <- sum((time_point_exp$exp - mRNA_pred)^2) / data_point
                    AIC1 <- data_point * log(s2) + (2 * 0)

                    cat(min1,cor1,a_1,half1_1,half1_2,AIC1,sep="\t",file=output_file,append=T)
                    cat("\t",file=output_file,append=T)
                    ############################################

                    ###Model2: f(t) = (1 - b)exp(-a * t) + b###
                    optim2 <- function(x){
                        mRNA_exp <- (1.0 - x[2]) * exp(-x[1] * time_point_exp$hour) + x[2]
                        sum((time_point_exp$exp - mRNA_exp)^2)
                    }

                    out2 <- optim(c(1,0),optim2)
                    min2 <- out2$value
                    a_2 <- out2$par[1]
                    b_2 <- out2$par[2]

                    model2_pred <- function(a,b){
                        mRNA_exp <- (1.0 - b) * exp(-a * time_point_exp$hour) + b
                        (cor(mRNA_exp, time_point_exp$exp, method="pearson"))^2
                    }

                    cor2 <- model2_pred(a_2, b_2)

                    model2_half <- function(x){
                        mRNA_half <- (1.0 - b_2) * exp(-a_2 * x) + b_2
                        (mRNA_half - 0.5)^2
                    }

                    out2 <- optim(1,model2_half)
                    half2 <- out2$par

                    if(b_2 >= 0.5){
                        half2 <- Inf
                    }

                    mRNA_pred <- (1.0 - b_2) * exp(-a_2 * time_point_exp$hour) + b_2
                    s2 <- sum((time_point_exp$exp - mRNA_pred)^2) / data_point
                    AIC2 <- data_point * log(s2) + (2 * 1)

                    cat(min2,cor2,a_2,b_2,half2,AIC2,sep="\t",file=output_file,append=T)
                    cat("\t",file=output_file,append=T)
                    ############################################################

                    ###Model3: f(t) = c * exp(-a * t) + (1 - c) * exp(-b * t)###
                    optim3 <- function(x){
                        mRNA_exp <- x[3] * exp(-x[1] * time_point_exp$hour) + (1.0 - x[3]) * exp(-x[2] * time_point_exp$hour)
                        sum((time_point_exp$exp - mRNA_exp)^2)
                    }

                    out3 <- optim(c(1,1,0.1),optim3)
                    min3 <- out3$value
                    a_3 <- out3$par[1]
                    b_3 <- out3$par[2]
                    c_3 <- out3$par[3]

                    model3_pred <- function(a,b,c){
                        mRNA_exp <- c * exp(-a * time_point_exp$hour) + (1.0 - c) * exp(- b * time_point_exp$hour)
                        (cor(mRNA_exp, time_point_exp$exp, method="pearson"))^2
                    }

                    cor3 <- model3_pred(a_3,b_3,c_3)

                    model3_half <- function(x){
                        mRNA_half <- c_3 * exp(-a_3 * x) + (1.0 - c_3) * exp(-b_3 * x)
                        (mRNA_half - 0.5)^2
                    }

                    out3 <- optim(1,model3_half)
                    half3 <- out3$par
                    mRNA_pred <- c_3 * exp(-a_3 * time_point_exp$hour) + (1.0 - c_3) * exp(-b_3 * time_point_exp$hour)
                    s2 <- sum((time_point_exp$exp - mRNA_pred)^2) / data_point
                    AIC3 <- data_point * log(s2) + (2 * 2)

                    cat(min3,cor3,a_3,b_3,c_3,half3,AIC3,sep="\t",file=output_file,append=T)
                    cat("\t",file=output_file,append=T)
                    ############################################################

                    half_table <- data.frame(half=c(as.numeric(half1_2),as.numeric(half2),as.numeric(half3)),AIC=c(as.numeric(AIC1),as.numeric(AIC2),as.numeric(AIC3)))
                    AIC_list <- order(half_table$AIC)
                    #selected_half <- half_table$half[min_AIC_index]

                    AIC_flg <- 0
                    for(min_AIC_index in AIC_list){
                        ###Model1###
                        if(min_AIC_index == 1){
                            selected_half <- half1_2
                            if(selected_half > 24){
                                selected_half <- 24
                            }
                            if(a_1 > 0){
                                cat("model1",cor1,selected_half,sep="\t",file=output_file,append=T)
                                AIC_flg <- 1
                                break
                            }
                        }
                        ###Model2###
                        if(min_AIC_index == 2){
                            selected_half <- half2
                            if(selected_half == "Inf"){
                                selected_half <- 24
                            }else if(selected_half > 24){
                                selected_half <- 24
                            }
                            if(a_2 > 0 && b_2 > 0 && b_2 < 1){
                                cat("model2",cor2,selected_half,sep="\t",file=output_file,append=T)
                                AIC_flg <- 1
                                break
                            }
                        }
                        ###Model3###
                        if(min_AIC_index == 3){
                            selected_half <- half3
                            if(selected_half > 24){
                                selected_half <- 24
                            }
                            if(a_3 > 0 && b_3 > 0 && c_3 > 0 && c_3 < 1){
                                cat("model3",cor3,selected_half,sep="\t",file=output_file,append=T)
                                AIC_flg <- 1
                                break
                            }
                        }
                    }

                    if(AIC_flg == 0){
                        if(a_1 < 0){
                            cat("model1",cor1,24,sep="\t",file=output_file,append=T)
                            next
                        }else{
                            cat("no_good_model","NA",24,sep="\t",file=output_file,append=T)
                            next
                        }
                    }

                }else{
                    cat("few_data","NA","NA","NA","NA","NA","NA","NA","NA","NA","NA","NA",
                        "NA","NA","NA","NA","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                }
            }else{
                cat("low_expresion","NA","NA","NA","NA","NA","NA","NA","NA","NA","NA","NA",
                    "NA","NA","NA","NA","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
            }
        }
        cat("\n", file=output_file, append=T)
    }
}


# Since March 03
# Added 2182, mchanged 1725 to 1813 (from Wikipedia)
spain = c(1,2,3,8,10,17,
          30,36,55,86,133,196,294,
          342,533,638,831,1093,1381,1772,
          2311,2991,3647,4145)

startDate = ISOdate(2020, 3, 3)
population = 46660000
data = spain
source('./approxnlsLM.r')


#!/usr/bin/env Rscript
# From https://github.com/berkeley-dsep-infra/datahub/issues/814
#      https://github.com/berkeley-dsep-infra/datahub/issues/897

source("/tmp/class-libs.R")

class_name = "IA C188"
class_libs = c(
  "rdd", "0.57",
  "lm.beta", "1.5-1",
  "multcomp", "1.4-15"
  # "lfe", "???" # https://github.com/sgaure/lfe/issues/41
)

class_libs_install_version(class_name, class_libs)


#' Plot of RMSE values with 95 percent CI cone
#'
#' Root mean square error by likelihood component relative to 95 percent CI from N(0,1) distribution.
#' @param asap name of the variable that read in the asap.rdat file
#' @param index.names names of indices
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param liz.palette color definitions
#' @export

PlotRMSE95CI <- function(asap,index.names,save.plots,od,plotf,liz.palette){
  par(mfrow=c(2,1), mar=c(4,4,2,2) )#need to specify 2/3 layout

  max.txt<-16
  ci.vals <- matrix(NA, 9,3)
  ci.vals[,1] <- c(1,3,5,10,20,30,40,50, 100)
  ci.vals[,2] <- c(0.063, 0.348, 0.473, 0.634, 0.737, 0.786, 0.815, 0.832, 0.883)
  ci.vals[,3] <- c(1.96, 1.619, 1.487, 1.351, 1.253, 1.211, 1.183, 1.162, 1.116)

  #-- plot of just indices
  rmse.val <- as.vector(unlist(asap$RMSE))
  rmse.num <- as.vector(unlist(asap$RMSE.n))
  rmse.names <- names(asap$RMSE)
  rmse.ind1 <- which(substr(rmse.names,1,8)=="rmse.ind")
  rmse.ind <- rmse.ind1[which(rmse.val[rmse.ind1]>0)]
  tname1 <- rmse.names[rmse.ind]
  tname <- substr(tname1,6, max(nchar(tname1))  )
  tname[1:length(index.names)] <- index.names

  if (length(rmse.ind)>0) {

    plot(seq(0,100), rep(1, 101), lty=1, type='l', ylim=c(0,2), xlab="Number of Residuals",
         ylab="RMSE")
    lines(ci.vals[,1], ci.vals[,2], lty=2, lwd=2)
    lines(ci.vals[,1], ci.vals[,3], lty=2, lwd=2)

    points(rmse.num[rmse.ind], rmse.val[rmse.ind], pch=(seq(1,length(rmse.ind)) %% 20),
           col=liz.palette[seq(1,length(rmse.ind))], cex=1.5 )

    plot(seq(1,20), seq(1,20), type='n', axes=F, xlab="", ylab="")
    if (length(rmse.ind)<=20) {
      text( x= rep(1,length(rmse.ind)), y=seq(1, length(rmse.ind)),
            labels=tname,   pos=4, cex=0.8)
      points(x=rep(0.5, length(tname)), y=seq(1, length(tname)),
             pch=seq(1,length(tname)), col=liz.palette[seq(1,length(tname))] )
    }
    if (length(rmse.ind)>20 & length(rmse.ind)<=40) {
      text( x= rep(1,20), y=seq(1, 20), labels=tname[1:20],
            pos=4, cex=0.8)
      text( x= rep(7,(length(tname)-20)), y=seq(1, (length(tname)-20)),
            labels=tname[21:length(tname)], pos=4, cex=0.8)
      points(x=rep(0.5, 20), y=seq(1, 20),
             pch=seq(1,20), col=liz.palette[seq(1,20)] )
      points(x=rep(6.5, (length(tname)-20)), y=seq(1,(length(tname)-20)),
             pch=(seq(21,length(tname)) %% 20), col=liz.palette[seq(21, length(tname))] )
    }
    if (length(rmse.ind)>40 & length(rmse.ind)<=60) {
      text( x= rep(1,20), y=seq(1, 20), labels=tname[1:20], pos=4, cex=0.8)
      text( x= rep(7,20), y=seq(1,20), labels=tname[21:40], pos=4, cex=0.8)
      text( x= rep(13,(length(tname)-40)), y=seq(1,(length(tname)-40)),
            labels=tname[41:length(tname)], pos=4, cex=0.8)
      points(x=rep(0.5, 20), y=seq(1, 20),
             pch=seq(1,20), col=liz.palette[seq(1,20)] )
      points(x=rep(6.5,20), y=seq(1,20),
             pch=(seq(21, 40) %% 20), col=liz.palette[seq(21,40)] )
      points(x=rep(12.5, (length(tname)-40)), y=seq(1,(length(tname)-40)),
             pch=(seq(41, length(tname)) %% 20), col=liz.palette[seq(41, length(tname))] )
    }

    title(main="Root Mean Square Error for Indices", outer=T, cex=0.85, line=-1)
    if (save.plots) savePlot(paste0(od, "RMSE.95CI.Indices.",plotf), type=plotf)
  }    # end if-statement for rmse.ind

  #-- plot of just catch
  rmse.val <- as.vector(unlist(asap$RMSE))
  rmse.num <- as.vector(unlist(asap$RMSE.n))
  rmse.names <- names(asap$RMSE)
  rmse.cat1 <- which(substr(rmse.names,1,8)=="rmse.cat" | substr(rmse.names,1,8)=="rmse.dis")
  rmse.cat <- rmse.cat1[which(rmse.val[rmse.cat1]>0)]
  tname1 <- rmse.names[rmse.cat]
  tname <- substr(tname1,6, max(nchar(tname1))  )
  #if (asap$parms$nfleets>1 ) tname <- c(fleet.names, "catch.tot")

  if (length(rmse.cat)>0)  {

    par(mfrow=c(2,1) )#need to specify 2/3 layout
    plot(seq(0,100), rep(1, 101), lty=1, type='l', ylim=c(0,2), xlab="Number of Residuals",
         ylab="RMSE")
    lines(ci.vals[,1], ci.vals[,2], lty=2, lwd=2)
    lines(ci.vals[,1], ci.vals[,3], lty=2, lwd=2)

    points(rmse.num[rmse.cat], rmse.val[rmse.cat], pch=seq(1,length(rmse.cat)),
           col=liz.palette[seq(1,length(rmse.cat))], cex=1.5 )

    plot(seq(1,20), seq(1,20), type='n', axes=F, xlab="", ylab="")
    if (length(rmse.cat)<=20) {
      text( x= rep(1,length(rmse.cat)), y=seq(1, length(rmse.cat)),
            labels=tname,   pos=4, cex=0.8)
      points(x=rep(0.5, length(tname)), y=seq(1, length(tname)),
             pch=seq(1,length(tname)), col=liz.palette[seq(1,length(tname))] )
    }
    if (length(rmse.cat)>20 & length(rmse.cat)<=40) {
      text( x= rep(1,20), y=seq(1, 20), labels=tname[1:20],
            pos=4, cex=0.8)
      text( x= rep(7,(length(tname)-20)), y=seq(1, (length(tname)-20)),
            labels=tname[21:length(tname)], pos=4, cex=0.8)
      points(x=rep(0.5, 20), y=seq(1, 20),
             pch=seq(1,20), col=liz.palette[seq(1,20)] )
      points(x=rep(6.5, (length(tname)-20)), y=seq(1,(length(tname)-20)),
             pch=(seq(21,length(tname)) %% 20), col=liz.palette[seq(21,length(tname))] )
    }
    if (length(rmse.cat)>40 & length(rmse.cat)<=60) {
      text( x= rep(1,20), y=seq(1, 20), labels=tname[1:20], pos=4, cex=0.8)
      text( x= rep(7,20), y=seq(1,20), labels=tname[21:40], pos=4, cex=0.8)
      text( x= rep(13,(length(tname)-40)), y=seq(1,(length(tname)-40)),
            labels=tname[41:length(tname)], pos=4, cex=0.8)
      points(x=rep(0.5, 20), y=seq(1, 20),
             pch=seq(1,20), col=liz.palette[seq(1,20)] )
      points(x=rep(6.5,20), y=seq(1,20),
             pch=(seq(21,40) %% 20), col=liz.palette[seq(21,40)] )
      points(x=rep(12.5, (length(tname)-40)), y=seq(1,(length(tname)-40)),
             pch=(seq(41, length(tname)) %% 20), col=liz.palette[seq(41, length(tname))] )
    }

    title(main="Root Mean Square Error for Catch", outer=T, cex=0.85, line=-1)
    if (save.plots) savePlot(paste0(od, "RMSE.95CI.Catch.",plotf), type=plotf)
  }  # end if-statement for rmse.cat

  #-- plot of parameters with priors
  rmse.val <- as.vector(unlist(asap$RMSE))
  rmse.num <- as.vector(unlist(asap$RMSE.n))
  rmse.names <- names(asap$RMSE)
  #rmse.prior1 <- which(substr(rmse.names,1,8)=="rmse.cat" | substr(rmse.names,1,8)=="rmse.dis")
  rmse.prior1 <- rmse.names[c(-rmse.cat1, -rmse.ind1)]
  rmse.prior <- rmse.prior1[which(rmse.val[rmse.prior1]>0)]

  if (length(rmse.prior)>0) {
    par(mfrow=c(2,1) )#need to specify 2/3 layout
    plot(seq(0,100), rep(1, 101), lty=1, type='l', ylim=c(0,2), xlab="Number of Residuals",
         ylab="RMSE")
    lines(ci.vals[,1], ci.vals[,2], lty=2, lwd=2)
    lines(ci.vals[,1], ci.vals[,3], lty=2, lwd=2)

    points(rmse.num[rmse.prior], rmse.val[rmse.prior], pch=seq(1,length(rmse.prior)),
           col=liz.palette[seq(1,length(rmse.prior))], cex=1.5 )

    plot(seq(1,20), seq(1,20), type='n', axes=F, xlab="", ylab="")
    text( x= rep(1,length(rmse.prior)), y=seq(1, length(rmse.prior)), labels=rmse.names[rmse.prior],
          pos=4)
    points(x=rep(0.5, length(rmse.prior)), y=seq(1, length(rmse.prior)),
           pch=seq(1,length(rmse.prior)), col=liz.palette[seq(1,length(rmse.prior))] )
    title(main="Root Mean Square Error for Priors", outer=T, cex=0.85)
    if (save.plots) savePlot(paste0(od, "RMSE.95CI.Prior.",plotf), type=plotf)
  }
  return()
} #end function


# Research Question:
#
#   How many of the cyclists rode daily, how many of these riders were male and how many female, and what were their average ages?
#
#   Write the code for your Analysis

dataframe = read.csv('BikeData.csv')

#
# Conclusion:
#
#   We examined the data on ----- daily riders. Most of the daily riders ( a total of ---- out of  ----- were -------. The average age of all dailyriders was ------. The average age of female riders was ----- while the average age of male riders was ------.


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(broom))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(ggrepel))

col_types <- readr::cols(
    .default = readr::col_double(),
    Metadata_Plate = readr::col_character(),
    Metadata_Well = readr::col_character(),
    Metadata_Assay_Plate_Barcode = readr::col_character(),
    Metadata_Plate_Map_Name = readr::col_character(),
    Metadata_well_position = readr::col_character(),
    Metadata_clone_number = readr::col_character(),
    Metadata_clone_type = readr::col_character(),
    Metadata_plate_ID = readr::col_character(),
    Metadata_plate_filename = readr::col_character(),
    Metadata_treatment = readr::col_character(),
    Metadata_batch = readr::col_character()
)

profile_file <- file.path("data", "core_batch_profiles.tsv")
data_df <- readr::read_tsv(profile_file, col_types = col_types)

print(dim(data_df))
head(data_df)

cp_features <- colnames(
    data_df %>% dplyr::select(-starts_with("Metadata_"))
    )

num_cp_features <- length(cp_features)
print(num_cp_features)

all_results <- list()
for (feature in cp_features) {
    # Build formula call
    formula_call = paste(
        feature, "~",
        "Metadata_clone_type", "+",
        "Metadata_treatment", "+",
        "Metadata_batch", "+",
        "Metadata_plate_ID", "+",
        "Metadata_clone_number", "+",
        "Metadata_Well"
    )

    aov.out <- aov(
        formula = as.formula(formula_call),
        data = data_df
    )

    results <- broom::tidy(aov.out) %>%
        dplyr::mutate(feature = feature)

    all_results[[feature]] <- results
}

full_results_df <- do.call(rbind, all_results)

full_results_df <- full_results_df %>%
    dplyr::mutate(neg_log_p = -log10(p.value)) %>%
    tidyr::drop_na()

full_results_df$term <- factor(
    full_results_df$term, levels = c(
        "Metadata_batch",
        "Metadata_plate_ID",
        "Metadata_Well",
        "Metadata_treatment",
        "Metadata_clone_number",
        "Metadata_clone_type"
    )
)

print(dim(full_results_df))
head(full_results_df, 6)

difference_contribution_gg <- ggplot(full_results_df, aes(x = neg_log_p, y = term)) +
    ggridges::geom_density_ridges(aes(fill = term),
                                  alpha = 0.4,
                                  scale = 4) +
    theme_bw() +
    theme(legend.position = "none") +
    xlab("-log10 p value") +
    ylab("") +
    ggtitle(paste("ANOVA effects for all", num_cp_features, "CP features")) +
    theme(axis.text = element_text(size = 6),
          axis.title = element_text(size = 7),
          title = element_text(size = 8))

out_file <- file.path("figures", "anova_effect_term_distributions.png")
ggsave(out_file, dpi = 400, height = 5, width = 4)

difference_contribution_gg

feature_focus_df <- full_results_df %>%
    reshape2::dcast(feature ~ term, value.var = "neg_log_p")

head(feature_focus_df)

label_logic <- (
    (
        feature_focus_df$Metadata_treatment > 50
    ) | (
        feature_focus_df$Metadata_clone_number > 45
    )
    )

feature_interpret_gg <- ggplot(feature_focus_df,
       aes(x = Metadata_treatment,
           y = Metadata_clone_number,
           size = Metadata_Well)) +
    geom_point(alpha = 0.7) +
    geom_text_repel(data = subset(feature_focus_df, label_logic),
                    arrow = arrow(length = unit(0.01, "npc")),
                    box.padding = 0.7,
                    point.padding = 0.2,
                    segment.size = 0.5,
                    segment.alpha = 0.9,
                    size = 1.45,
                    fontface = "italic",
                    aes(label = feature,
                        x = Metadata_treatment,
                        y = Metadata_clone_number)) +
    scale_size_continuous(name = "Well Effect", range = c(0.1, 3)) +
    theme_bw() +
    theme(axis.text = element_text(size = 6),
          axis.title = element_text(size = 7))

out_file <- file.path("figures", "anova_effect_term_features_clone_vs_treatment.png")
ggsave(out_file, dpi = 400, height = 5, width = 5)

feature_interpret_gg

label_logic <- (
    (
        feature_focus_df$Metadata_treatment > 50
    ) | (
        feature_focus_df$Metadata_clone_type > 35
    )
    )

feature_interpret_gg <- ggplot(feature_focus_df,
       aes(x = Metadata_treatment,
           y = Metadata_clone_type,
           size = Metadata_clone_number)) +
    geom_point(alpha = 0.7) +
    geom_text_repel(data = subset(feature_focus_df, label_logic),
                    arrow = arrow(length = unit(0.01, "npc")),
                    box.padding = 0.7,
                    point.padding = 0.5,
                    segment.size = 0.5,
                    segment.alpha = 0.9,
                    size = 1.45,
                    fontface = "italic",
                    aes(label = feature,
                        x = Metadata_treatment,
                        y = Metadata_clone_type)) +
    theme_bw() +
    scale_size_continuous(name = "Sample Effect", range = c(0.1, 3)) +
    theme(axis.text = element_text(size = 6),
          axis.title = element_text(size = 7))

out_file <- file.path("figures", "anova_effect_term_features_clone_type_vs_treatment.png")
ggsave(out_file, dpi = 400, height = 5, width = 5)

feature_interpret_gg

split_feature_df <- full_results_df %>%
        tidyr::separate(feature,
                        into=c("compartment",
                               "feature_group",
                               "measurement",
                               "channel",
                               "parameter1",
                               "parameter2"), sep="_", remove=FALSE)

head(split_feature_df)

area_split_df <- split_feature_df %>%
    dplyr::filter(feature_group  == "AreaShape") %>%
    dplyr::group_by(term, compartment, feature_group) %>%
    dplyr::top_n(n = 1, wt = neg_log_p)

group <- "Metadata_treatment"

ggplot(area_split_df %>% dplyr::filter(term == !!group),
           aes(x = compartment, y = feature_group)) +
    geom_point(aes(fill = neg_log_p), size = 10, pch = 21) +
    ggtitle(group) +
    theme_bw() +
    theme(strip.text = element_text(size = 8, color = "black"),
          strip.background = element_rect(colour = "black", fill = "#fdfff4"))

out_file <- file.path("figures", "anova_effect_term_features_treatment_interpret_area.png")
ggsave(out_file, dpi = 400, height = 3, width = 5)

group <- "Metadata_clone_type"

ggplot(area_split_df %>% dplyr::filter(term == !!group),
           aes(x = compartment, y = feature_group)) +
    geom_point(aes(fill = neg_log_p), size = 10, pch = 21) +
    ggtitle(group) +
    theme_bw() +
    ylab("") +
    xlab("") +
    theme(strip.text = element_text(size = 8, color = "black"),
          strip.background = element_rect(colour = "black", fill = "#fdfff4"))

out_file <- file.path("figures", "anova_effect_term_features_clone_type_interpret_area.png")
ggsave(out_file, dpi = 400, height = 2, width = 5)

not_area_split_df <- split_feature_df %>%
    dplyr::filter(
        feature_group %in% c("Texture", "Intensity", "RadialDistribution", "Correlation", "Granularity")) %>%
    dplyr::group_by(term, compartment, feature_group, channel) %>%
    dplyr::top_n(n = 1, wt = neg_log_p)

group <- "Metadata_clone_type"

ggplot(not_area_split_df %>% dplyr::filter(term == !!group),
           aes(x = channel, y = feature_group)) +
    geom_point(aes(fill = neg_log_p), size = 10, pch = 21) +
    facet_grid(rows = vars(compartment)) +
    ggtitle(group) +
    theme_bw() +
    ylab("") +
    xlab("") +
    theme(strip.text = element_text(size = 8, color = "black"),
          strip.background = element_rect(colour = "black", fill = "#fdfff4"))

out_file <- file.path("figures", "anova_effect_term_features_clone_type_interpret.png")
ggsave(out_file, dpi = 400, height = 6, width = 5)

group <- "Metadata_Well"

ggplot(not_area_split_df %>% dplyr::filter(term == !!group),
           aes(x = channel, y = feature_group)) +
    geom_point(aes(fill = neg_log_p), size = 10, pch = 21) +
    facet_grid(rows = vars(compartment)) +
    ggtitle(group) +
    theme_bw() +
    ylab("") +
    xlab("") +
    theme(strip.text = element_text(size = 8, color = "black"),
          strip.background = element_rect(colour = "black", fill = "#fdfff4"))

out_file <- file.path("figures", "anova_effect_term_features_well_interpret.png")
ggsave(out_file, dpi = 400, height = 6, width = 5)

group <- "Metadata_clone_type"

ggplot(not_area_split_df %>% dplyr::filter(term == !!group),
           aes(x = channel, y = feature_group)) +
    geom_point(aes(fill = neg_log_p), size = 10, pch = 21) +
    facet_grid(rows = vars(compartment)) +
    ggtitle(group) +
    theme_bw() +
    theme(strip.text = element_text(size = 8, color = "black"),
          strip.background = element_rect(colour = "black", fill = "#fdfff4"))

out_file <- file.path("figures", "anova_effect_term_features_clone_type_interpret.png")
ggsave(out_file, dpi = 400, height = 6, width = 5)


pp.fit2 <- function (xdat, threshold, npy = 365, ydat = NULL, mul = NULL, sigl = NULL, shl = NULL, mulink = identity, siglink = identity, shlink = identity, muinit = NULL, siginit = NULL, shinit = NULL, show = TRUE, method = "Nelder-Mead", maxit = 10000, ndeps = 1e-3, exceedancesOnly = TRUE, nBlocks = NULL, propMissingByBlock = 0, ydatByBlock = NULL, thresholdByBlock = NULL, ...)
{
  # modification of pp.fit() from ismev by C. Paciorek
  # differences from pp.fit()
  # (1) modifies default initial values to be calculated only using exceedances, and modifies initial values for log link
  # (2) allows NA in data, adjusting intensity function calculation in likelihood to account for missing values
  # (3) allows user to provide only the exceedances for computational efficiency; in this case, for nonstationary models, the covariates must not vary within block (e.g., year) as the likelihood needs to calculate the intensity measure appropriate for every timepoint at which an observation is possible. The covariate values, proportion of missing values, and threshold for each block must be supplied when these are relevant
  # (4) returns data values and location, scale and shape values only for the exceedances
  # (5) adds 'flag' output that indicates if MLE or standard errors may not be legitimate
  # (6) allows one to change the default step size of the finite difference approximation to the gradient in the optimization

  # Note that this function operates in two fashions. First (exceedancesOnly = FALSE) it replicates pp.fit() but allows for missing data. In this case the data, threshold values, and covariates supplied should be given for every timepoint. Missing values are not allowed in the covariates or the threshold values as these are need for calculation of the intensity function in the likelihood.  In this case, information about the blocks is ignored. Second (exceedancesOnly = TRUE), it allows one to improve computational efficiency by providing only the exceedances.  In this case, the user is required to provide nBlocks and should provide propMissingByBlock, ydatByBlock, and thresholdByBlock as appropriate.  When only exceedances are supplied there should be no missing values in xdat.

  # for strict accuracy, one should specify npy to be equal to the total number of observation units in the number of blocks to be considered for analysis divided by the number of blocks; e.g., the total number of days in the years of the analysis divided by the number of years; note that blocks in general should be equal size for the parameter estimates and return values to be meaningful across multiple blocks, but slight deviations from, e.g., leap years should have limited effects

  # probably want to have sc and threshold checks for all timepoints not just exceedances, unlike in pp.fit(); for now I'm keeping the checks just for the exceedances, as in pp.fit()

  # note possible errors in pp.fit checking of legitimacy of parameters in terms of obs/thresholds not outside domain of distribution

  # add upper.tail? no, probably not; but if so give msg that says: provide me the maxima of negative data and that this will handle the results correctly?

  z <- list()
  npmu <- length(mul) + 1
  npsc <- length(sigl) + 1
  npsh <- length(shl) + 1

  z$trans <- FALSE
  if (is.function(threshold))
    stop("`threshold' cannot be a function")

  covars = FALSE
  if(!is.null(mul) || !is.null(sigl) || !is.null(shl))
    covars = TRUE  #

  if(covars || length(threshold) > 1)
    z$trans <- TRUE  # nonstationary model

  if(exceedancesOnly & is.null(nBlocks))
    stop("number of blocks (e.g., years) (nBlocks) is required for calculation of the likelihood when only exceedances are supplied")

  if(exceedancesOnly){ # check that nBlocks matches dimensionality of byBlock objects
    nBlocksError = FALSE
    if(length(propMissingByBlock) > 1 && length(propMissingByBlock) != nBlocks)
      nBlocksError = TRUE
    if(!is.null(ydatByBlock) && nrow(ydatByBlock) != nBlocks)
      nBlocksError = TRUE
    if(!is.null(thresholdByBlock) && length(thresholdByBlock) != nBlocks)
      nBlocksError = TRUE
    if(nBlocksError)
      stop("number of blocks indicated by nBlocks and one of {propMissingByBlock, ydatByBlock, thresholdByBlock} are in conflict")
  }

  if(exceedancesOnly && covars && is.null(ydatByBlock))
    stop("nonstationary modeling when providing only exceedances requires ydatByBlock to calculate the intensity function portion of the likelihood")

  if(exceedancesOnly &&  is.null(thresholdByBlock)){
    if(length(threshold) > 1){
      stop("require thresholdByBlock when threshold varies and only exceedances are supplied")
    } else{
      thresholdByBlock <- rep(threshold, nBlocks)
    }
  }

  if(exceedancesOnly && length(propMissingByBlock) == 1)
    propMissingByBlock = rep(propMissingByBlock, nBlocks)

  n <- length(xdat)
  if(exceedancesOnly){
    ny <- nBlocks # code below uses 'ny' since this is used in original pp.fit
    # nyEff <- sum(1-propMissingByBlock)
  } else{
    ny <- n/npy
    nyEff <- sum(!is.na(xdat))/npy
  }

  if(n == 1)
    stop("fitting will not be done correctly with a single observation or single exceedance")

  u <- threshold
  if(length(threshold) == 1)
    u <- rep(threshold, n)
  if(length(u) > 1 & length(u) != n)
    stop("number of threshold values should match number of observations, unless threshold does not vary")

  uInd <- !is.na(xdat) & xdat > u  # indicator of exceedances
  xdatu <- xdat[uInd]
  u[is.na(xdat)] = NA # sets things up so that intensity is not calculated when data are missing
  nu <- length(xdatu)
  in2 <- sqrt(6 * var(xdatu))/pi  # modified from pp.fit to make use only of exceedances
  in1 <- mean(xdatu) - 0.57722 * in2  # modified from pp.fit to make use only of exceedances

  if(identical(mulink, exp))
    in1 = log(in1)
  if(!identical(mulink, exp) && !identical(mulink, identity))
    warning("Default initial value for location is on incorrect scale; please supply your own.")
  if(identical(siglink, exp))
    in2 = log(in2)
  if(!identical(siglink, exp) && !identical(siglink, identity))
    warning("Default initial value for scale is on incorrect scale; please supply your own.")
  shinit.default = 0.1
  if(identical(shlink, exp))
    shinit.default = log(shinit.default)
  if(!identical(shlink, exp) && !identical(shlink, identity))
    warning("Default initial value for shape is on incorrect scale; please supply your own.")

  if(is.null(mul)) {
    mumat <- as.matrix(rep(1, n))
    if(is.null(muinit))
      muinit <- in1
    mumatByBlock <- matrix(rep(1, ny), nc = 1)
  } else {
    mumat <- cbind(rep(1, n), ydat[ , mul])
    mumatByBlock <- cbind(rep(1, ny), ydatByBlock[, mul])
    if(is.null(muinit))
      muinit <- c(in1, rep(0, length(mul)))
  }
  if(is.null(sigl)) {
    sigmat <- as.matrix(rep(1, n))
    if(is.null(siginit))
      siginit <- in2
    sigmatByBlock <- matrix(rep(1, ny), nc = 1)
  } else {
    sigmat <- cbind(rep(1, n), ydat[ , sigl])
    sigmatByBlock <- cbind(rep(1, ny), ydatByBlock[, sigl])
    if(is.null(siginit))
      siginit <- c(in2, rep(0, length(sigl)))
  }
  if(is.null(shl)) {
    shmat <- as.matrix(rep(1, n))
    if(is.null(shinit))
      shinit <- shinit.default
    shmatByBlock <- matrix(rep(1, ny), nc = 1)
  } else {
    shmat <- cbind(rep(1, n), ydat[ , shl])
    shmatByBlock <- cbind(rep(1, ny), ydatByBlock[, shl])
    if(is.null(shinit))
      shinit <- c(shinit.default, rep(0, length(shl)))
  }
  init <- c(muinit, siginit, shinit)
  z$model <- list(mul, sigl, shl)
  z$link <- deparse(substitute(c(mulink, siglink, shlink)))
  z$threshold <- threshold
  z$npy <- npy
  z$nexc <- nu
  z$data <- xdatu

  pp.lik <- function(a) {
    mu <- c(mulink(mumat %*% (a[1:npmu])))
    sc <- c(siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)])))
    xi <- c(shlink(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)])))
    if(exceedancesOnly){ # calculate parameters for each block for use in intensity function in likelihood
      muByBlock <- c(mulink(mumatByBlock %*% (a[1:npmu])))
      scByBlock <- c(siglink(sigmatByBlock %*% (a[seq(npmu + 1, length = npsc)])))
      xiByBlock <- c(shlink(shmatByBlock %*% (a[seq(npmu + npsc + 1, length = npsh)])))
    }

    # basic logic of the checks below is that the quantities that are exponentiated in (7.9) of Coles (p. 134) should be positive - i.e., for all exceedances and for all threshold values for all timepoints

    if(min(sc[uInd]) <= 0 || (exceedancesOnly && min(scByBlock) <= 0))
      return(10^6)  # note that pp.fit() only checks min(sc[uInd]) <=0, but presumably the scale should be positive for all potential observations

    # check that thresholds do not exceed the bounds of the distribution; pp.fit() does this only for the threshold values corresponding to the exceedances, but it's not clear why this shouldn't be checked for all timepoints
    if (min((1 + xi * (u - mu)/sc)[uInd]) <= 0)
      return(10^6)
    if(exceedancesOnly && min(1 + (xiByBlock * (thresholdByBlock - muByBlock))/scByBlock) <= 0)
      return(10^6)

    y <- (xdatu - mu[uInd])/sc[uInd]
    y <- 1 + xi[uInd] * y
    if(min(y) <= 0){  # check that exceedances do not exceed the bounds of the distribution; note that pp.fit() checks all observations, even those below the threshold, for reasons that are unclear
      l <- 10^6;
    } else{
      l <- sum(log(sc[uInd])) + sum(log(y) * (1/xi[uInd] + 1))  # PP density of the exceedances
      if(exceedancesOnly){  # calculate intensity function for all timepoints; using sum gives parameter estimates that correspond to GEV modeling of single block extrema (this is equivalent to multiplying by ny as in Coles (2001, p. 133) but ignoring the intensity values corresponding to the missing values)
        l <- l + sum( (1 - propMissingByBlock) * (1 + (xiByBlock * (thresholdByBlock - muByBlock))/scByBlock)^(-1/xiByBlock))
      } else{
        l <- l + nyEff * mean((1 + (xi * (u - mu))/sc)^(-1/xi), na.rm = TRUE) # need scaled mean if per-time-point intensity so that parameters correspond GEV modeling of single block extrema
      }
    }
    return(l)
  }
  x <- optim(init, pp.lik, hessian = TRUE, method = method,
             control = list(maxit = maxit, ndeps = rep(ndeps, length = length(init)), ...))
  # calculate parameters only for the exceedances, unlike pp.fit()
  mu <- mulink(c(mumat[uInd, , drop = FALSE] %*% (x$par[1:npmu])))
  sc <- siglink(c(sigmat[uInd, , drop = FALSE] %*% (x$par[seq(npmu + 1, length = npsc)])))
  xi <- shlink(c(shmat[uInd, , drop = FALSE] %*% (x$par[seq(npmu + npsc + 1, length = npsh)])))
  z$conv <- x$convergence
  z$nllh <- x$value
  z$vals <- cbind(mu, sc, xi, u[uInd])
  z$gpd <- apply(z$vals, 1, ppp, npy)
  if(z$trans) {
    z$data <- as.vector((1 + (xi * (xdatu - u[uInd]))/z$gpd[2, ])^(-1/xi))
  }
  z$mle <- x$par
  z$cov <- solve(x$hessian)
  z$se <- sqrt(diag(z$cov))
  if(show) {
    if(z$trans)
      print(z[c(2, 3)])
    if(length(z[[4]]) == 1)
      print(z[4])
    print(z[c(5, 6, 8)])
    if(!z$conv)
      print(z[c(9, 12, 14)])
  }
  z$flag = 0
  if(sum(is.na(c(z$mle, z$se))) || min(xi) < -1 || min(z$se) < 1e-5){
    z$flag = 1
    warning("MLEs and standard errors may not be reliable; please check convergence, estimates, standard errors, and input data.")
  }
  class(z) <- "pp.fit"
  invisible(z)
}


library(combinat)

col <- factor(c("Red","Green","White","Yellow","Blue"))
own <- factor(c("English","Swedish","Danish","German","Norwegian"))
pet <- factor(c("Dog","Birds","Cats","Horse","Zebra"))
drink <- factor(c("Coffee","Tea","Milk","Beer","Water"))
smoke <- factor(c("PallMall", "Blend", "Dunhill", "BlueMaster", "Prince"))

col_p <- permn(levels(col))
own_p <- permn(levels(own))
pet_p <- permn(levels(pet))
drink_p <- permn(levels(drink))
smoke_p <- permn(levels(smoke))

imright <- function(h1,h2){
  return(h1-h2==1)
}

nextto <- function(h1,h2){
  return(abs(h1-h2)==1)
}

house_with <- function(f,val){
  return(which(levels(f)==val))
}

for (i in seq(length(col_p))){
  col <- factor(col, levels=col_p[[i]])

  if (imright(house_with(col,"Green"),house_with(col,"White"))) {
    for (j in seq(length(own_p))){
      own <- factor(own, levels=own_p[[j]])

      if(house_with(own,"English") == house_with(col,"Red")){
        if(house_with(own,"Norwegian") == 1){
          if(nextto(house_with(own,"Norwegian"),house_with(col,"Blue"))){
            for(k in seq(length(drink_p))){
              drink <- factor(drink, levels=drink_p[[k]])

              if(house_with(drink,"Coffee") == house_with(col,"Green")){
                if(house_with(own,"Danish") == house_with(drink,"Tea")){
                  if(house_with(drink,"Milk") == 3){
                    for(l in seq(length(smoke_p))){
                      smoke <- factor(smoke, levels=smoke_p[[l]])

                      if(house_with(smoke,"Dunhill") == house_with(col,"Yellow")){
                        if(house_with(smoke,"BlueMaster") == house_with(drink,"Beer")){
                          if(house_with(own,"German") == house_with(smoke,"Prince")){
                            if(nextto(house_with(smoke,"Blend"),house_with(drink,"Water"))){
                              for(m in seq(length(pet_p))){
                                pet <- factor(pet, levels=pet_p[[m]])

                                if(house_with(own,"Swedish") == house_with(pet,"Dog")){
                                  if(house_with(smoke,"PallMall") == house_with(pet,"Birds")){
                                    if(nextto(house_with(smoke,"Blend"),house_with(pet,"Cats"))){
                                      if(nextto(house_with(smoke,"Dunhill"),house_with(pet,"Horse"))){
                                        res <- sapply(list(own,col,pet,smoke,drink),levels)
                                        colnames(res) <- c("Nationality","Colour","Pet","Drink","Smoke")
                                        print(res)
                                      }
                                    }
                                  }
                                }
                              }
                            }
                          }
                        }
                      }
                    }
                  }
                }
              }
            }
          }
        }
      }
    }
  }

}


if ( interactive() ) {

  library('zoom.plot')
  # To use older chromosome coordinates!! Only have to do this once per package load.
  load.gene.mart('hg37')
  # To go back to default (newer) coordinates use:
  # load.gene.mart()

  # Define colors for manhattan plot
  maf.colors <- c(rgb(20:0/20, 0, 0), rgb(0, 1:20/20, 0))

  # Set a location
  chrom <- 14
  start.pos <- 76398831
  end.pos <- 76594340

  # Make up SNP data for a manhattan plot
  snp.coords <- floor(runif(100, start.pos, end.pos))
  snp.logp <- -log10(runif(length(snp.coords)))
  snp.mafs <- runif(length(snp.coords), 0.1, 0.49)

  # Make up a fake LD matrix based on a subset of SNPs
  ld.mat <- matrix(runif(20*20), 20)
  ld.coords <- sort(sample(snp.coords, 20))

  # Get colors for SNPs according to maf
  snp.colors <- assign.scale.colors(snp.mafs, maf.colors, c(0, 0.5))

  # Get genes in region
  test.genes <- get.regional.genes(chrom, start.pos, end.pos)

  # To remake plot with visual adjustments you only need to rerun code below!
  # ( You do NOT have to look up genes or calculate LD every time! )

  # Set margins and layout for 4 plots
  par(mar=c(0, 4, 0, 4), oma=c(2, 1, 2, 0))
  layout(matrix(1:4, 4), height=c(30, 10, 10, 40))
#   layout.show(4)

  # Manhattan plot
  plot(snp.coords, snp.logp, pch=20, col=snp.colors,
       xaxt='n', bty='n', xlim=c(start.pos, end.pos), xaxs='i',
       ylab=expression(-log[10](p)), xlab='')
  draw.scale(maf.colors, c(0, 0.5), pos='right', outside=TRUE, horiz=FALSE)

  # Genes plot
  plotgenes(test.genes, highlight.gene='MOG', label.size=1)

  # Chromosome axis plot
  draw.chrom.axis(start.pos, end.pos, paste('chr', chrom))

  # LD plot
  ld.plot(ld.mat, ld.coords, start.pos, end.pos)

}


# Function for generating NOEC distributions for each species taking into account trophic levels
#
# Yields a matrix with dimensions number of species * number of iterations in the simulation
#
# Arguments:   - DP : matrix of endpoints
#              - UFt : matrix of uncertainty factors for the exposure time
#              - UFdd : matrix of uncertainty factors for the dose-descriptor
#              - SIM : number of iterations in the simulation
#              - CV.DP : coefficient of variation for the interlaboratory variation
#              - CV.UF : coefficient of variation for the use of non-substance-specific
#                uncertainty factors
#              - TrophLevel : Trophic levels of each species. 1 for primary producers, 2 for herbivores and 3 for carnivores
#              - Troph.Perc.Typ : Typical fractions in which each trophic level is represented in freshwater communities.
#
# Date of last modification: 03.07.2019
#
# Associated publication: Systematic consideration of parameter uncertainty and variability in
#                         probabilistic species sensitivity distributions
#
# Authors: Henning Wigger, Delphine Kawecki, Bernd Nowack and Veronique Adam
#
# Institute: Empa, Swiss Federal Laboratories for Materials Science and Technology,
#            Technology and Society Laboratory, Lerchenfeldstrasse 5, 9014 St. Gallen, Switzerland
#
# submitted to Integrated Environmental Assessment and Management in July 2019

# -------------------------------------------------------------------------------------------------

do.pSSD.troph <- function(DP,
                          UFt,
                          UFdd,
                          SIM,
                          CV.DP,
                          CV.UF,
                          TrophLevel,
                          Troph.Perc.Typ = c(0.65, 0.25, 0.1)){

  # test if there is no data available for one species
  if(any(apply(DP,2,function(x) length(which(!is.na(x)))) == 0)){
    warning("No data is available for one or more species, it/they won't contribute to the PSSD calculation.")
    # find which species has no data
    ind.sp.rem <- which(apply(DP, 2, function(x) length(which(!is.na(x)))) == 0)
    # remove those columns
    DP <- DP[,-ind.sp.rem]
    UFt <- UFt[,-ind.sp.rem]
    UFdd <- UFdd[,-ind.sp.rem]
  }

  # Create the step distributions (or triangular or trapezoidal) for each species
  # Create an empty matrix in which step distributions will be compiled
  NOEC_comb <- matrix(NA, ncol(DP), SIM,
                      dimnames = list(colnames(DP), NULL))

  # Fill in the matrix. If there is only one data point, NOEC stays the same. If  there are
  # 2 endpoints, a uniform distribution is produced. If  there are more than 2 endpoints, a step
  # distribution is produced. One line is for one species.
  require(trapezoid)
  require(mc2d)

  # store the corrected endpoints
  corr.endpoints <- DP/(UFdd*UFt)
  sort.endpoints <- apply(corr.endpoints, 2, sort)

  for (sp in colnames(DP)){

    # store the indices of the minimal and maximal data point
    ind.min <- which.min(corr.endpoints[,sp])
    ind.max <- which.max(corr.endpoints[,sp])

    # calculate the theoretical minimum and maximum of the distribution we are looking for
    sp.min <- corr.endpoints[ind.min,sp]*(1-(sqrt((CV.DP/2.45)^2 + (CV.UF/2.45)^2 + (CV.UF/2.45)^2)*2.45))
    sp.max <- corr.endpoints[ind.max,sp]*(1+(sqrt((CV.DP/2.45)^2 + (CV.UF/2.45)^2 + (CV.UF/2.45)^2)*2.45))

    # For species with one unique data point, NOEC stays the same:
    if(length(unique(sort.endpoints[[sp]])) == 1){
      NOEC_comb[sp,] <- rtrunc("rtriang", min = sp.min,
                               mode = sort.endpoints[[sp]][1],
                               max = sp.max,
                               n = SIM, linf = 0)

      # For species with two endpoints:
    } else if(length(sort.endpoints[[sp]]) == 2){
      # Create a trapezoidal distribution including both endpoints
      NOEC_comb[sp,] <- rtrunc("rtrapezoid", SIM,
                               mode1 = sort.endpoints[[sp]][1],
                               mode2 = sort.endpoints[[sp]][2],
                               min = sp.min, max = sp.max,
                               linf = 0)

      # For species with three endpoints or more:
    } else {

      # Sample from this step distribution for each species
      NOEC_comb[sp,] <- rmore(values = sort.endpoints[[sp]], max = sp.max, min = sp.min, N = SIM, linf = 0)

    }
  }

  # Sample species with typical proportions representative of a typical community (if terrestrial or marine, Troph.Perc need to be changed)
  Nb_Troph <- c(length(which(TrophLevel == 1)),
                length(which(TrophLevel == 2)),
                length(which(TrophLevel == 3)))
  # calculate the shares of the different trophic levels in the data
  Troph.Perc.Data <- Nb_Troph/ncol(DP)

  # identify the trophic level that will be unchanged
  if(length(which(Troph.Perc.Data < Troph.Perc.Typ)) == 1){
    lev.fix <- which(Troph.Perc.Data < Troph.Perc.Typ)
  } else {
    lev.fix <- which.max((Troph.Perc.Typ - Troph.Perc.Data)/Troph.Perc.Typ)
  }

  # create an empty vector to contain the corrected number of species for the species being corrected
  Nb_points <- rep(NA,3)
  # create an empty list with an element per trophic level
  NOEC_lev <- vector("list", 3)

  for(lev in 1:3){

    # for fix level, take as such
    if(lev == lev.fix){
      Nb_points[lev] <- Nb_Troph[lev.fix]

      # identify species corresponding to level lev
      ind.sp <- which(TrophLevel == lev) # vector of all indices for which the species level is the fixed one
      # store in list
      NOEC_lev[[lev]] <- NOEC_comb[ind.sp,]

    } else {

      # change the remaining levels
      Nb_points[lev] <- round(Nb_Troph[lev.fix] * Troph.Perc.Typ[lev] / Troph.Perc.Data[lev.fix]) # Nouveau nombre de lignes

      ind.sp <- which(TrophLevel == lev) # vector of all indices of the level
      # store in temporary matrix the NOEC distributions of all species of the level
      temp <- NOEC_comb[ind.sp,]

      NOEC_lev[[lev]] <- matrix(NA, Nb_points[lev],SIM)
      for(i in 1:SIM){
        NOEC_lev[[lev]][,i] <- sample(temp[,i], Nb_points[lev])
      }
    }

  }

  # combine that stuff
  NOEC_TrophCorr <- do.call(rbind,NOEC_lev)

  # return the whole matrix
  return(NOEC_TrophCorr)

}


#! /usr/bin/env Rscript

library(grid)
library(dplyr)
library(scales)
library(ggplot2)
library(gridExtra)

INPUT_TABLE_FILENAME = 'hotspots-in-normals.txt'
OUTPUT_PLOT_FILENAME = 'hotspots_in_normals.pdf'

THEME = theme(
  text = element_text(size=24),
  axis.text.x = element_text(angle=45, hjust=1, face='bold'),
  axis.text.y = element_text(face='bold'),
  plot.margin = unit(c(.1, .1, .1, 1), 'in')
)

counts = read.table(
    INPUT_TABLE_FILENAME,
    sep = '\t',
    header = TRUE,
    colClasses = c(rep('character', 4), rep('numeric', 3))
)

if (nrow(counts) == 0) {
    pdf(file = OUTPUT_PLOT_FILENAME, height=15, width=20, onefile=TRUE)
    no_hotspots_msg = textGrob(label = 'No hotspots found', gp=gpar(fontsize=22, col='black'))
    grid.draw(no_hotspots_msg)
    dev.off()
    quit()
}

counts$Sample = reorder(counts$Sample, counts$SampleType=='Tumor')

g = ggplot(filter(counts, AltCount>0), aes(Sample, Mutation)) +
    theme_bw() +
    geom_point(aes(color=SampleType, size=AF, shape=15)) +
    scale_shape_identity() +
    geom_text(aes(label=paste(sep='', AF, ' (', AltCount, '/', Total, ')')), vjust=0, nudge_y = -0.60, size=6) +
    ggtitle('Hotspot mutations in normals (normals: unfiltered > 3 fragments, tumors: duplex)') +
    THEME

ggsave(g, file=OUTPUT_PLOT_FILENAME, width=20, height=20)


### Model Complexity Mincerian wage example
## Use: Evaluate flexible and specified functional forms OOS
## Author: Mark Verhagen

## Load libraries
library(doParallel)
library(tidyverse)
library(MASS)
library(Metrics)
library(caret)
library(xgboost)

simul_df <- readRDS("mincerian/data/edit/analysis_df.csv")

## Run simulation

n_simul <- 200
cores <- detectCores()
cl <- makeCluster(cores[1] - 2)
registerDoParallel(cl)

results <- foreach(
    i = 1:n_simul, .combine = rbind,
    .packages = c(
        "MASS", "Metrics", "caret", "xgboost",
        "tidyverse"
    )
) %dopar% {
    set.seed(i)
    # make train set
    train_set <- simul_df %>%
        sample_frac(0.8)
    test_set <- simul_df %>%
        filter(!(id %in% train_set$id))
    stopifnot(dim(train_set)[1] + dim(test_set)[1] == dim(simul_df)[1])
    # run models: all four linear functional forms on all four datasets
    lm_1 <- lm_fits(formulas, train_set, test_set, "ln_y_I")[[2]]
    lm_2 <- lm_fits(formulas, train_set, test_set, "ln_y_II")[[2]]
    lm_3 <- lm_fits(formulas, train_set, test_set, "ln_y_III")[[2]]
    lm_4 <- lm_fits(formulas, train_set, test_set, "ln_y_IV")[[2]]

    # run models: GB model on all four datasets
    gb_1 <- fit_xgb(
        train_set = train_set, test_set = test_set,
        y_var = "ln_y_I"
    )
    gb_2 <- fit_xgb(
        train_set = train_set, test_set = test_set,
        y_var = "ln_y_II"
    )
    gb_3 <- fit_xgb(
        train_set = train_set, test_set = test_set,
        y_var = "ln_y_III"
    )
    gb_4 <- fit_xgb(
        train_set = train_set, test_set = test_set, y_var = "ln_y_IV",
        features = c("S", "X", "gender")
    )

    list(
        lm_1[[1]], lm_1[[2]], lm_1[[3]], lm_1[[4]], lm_1[[5]],
        lm_2[[1]], lm_2[[2]], lm_2[[3]], lm_2[[4]], lm_2[[5]],
        lm_3[[1]], lm_3[[2]], lm_3[[3]], lm_3[[4]], lm_3[[5]],
        lm_4[[1]], lm_4[[2]], lm_4[[3]], lm_4[[4]], lm_4[[5]],
        gb_1, gb_2, gb_3, gb_4
    )
}

df_results <- as.data.frame(results)
names(df_results) <- c(
    "lm_1_bench", "lm_1_1", "lm_1_2", "lm_1_3", "lm_1_4",
    "lm_2_bench", "lm_2_1", "lm_2_2", "lm_2_3", "lm_2_4",
    "lm_3_bench", "lm_3_1", "lm_3_2", "lm_3_3", "lm_3_4",
    "lm_4_bench", "lm_4_1", "lm_4_2", "lm_4_3", "lm_4_4",
    "gb_1", "gb_2", "gb_3", "gb_4"
)

i <- names(df_results)[[1]]

for (i in names(df_results)) {
    df_results[[i]] <- as.numeric(df_results[[i]])
}

saveRDS(df_results, "data/final/simul_4models_100.rds")


library("ggplot2")

options(warn=-1)

jpeg('/usr/src/app/data/chart.jpg', width = 465, height = 225, units='mm', res = 600, pointsize=16)

data <- read.table("/usr/src/app/data/nat2018_labeled.csv", header=TRUE, sep=";")

data <- subset(data, data$annais!="XXXX"
    & data$annais!=1935
    & data$annais!=1934
    & data$annais!=1933
    & data$annais!=1932
    & data$annais!=1931
    & data$annais!=1930
    & data$annais!=1929
    & data$annais!=1928
    & data$annais!=1927
    & data$annais!=1926
    & data$annais!=1925
    & data$annais!=1924
    & data$annais!=1923
    & data$annais!=1922
    & data$annais!=1921
    & data$annais!=1920
    & data$annais!=1919
    & data$annais!=1918
    & data$annais!=1917
    & data$annais!=1916
    & data$annais!=1915
    & data$annais!=1914
    & data$annais!=1913
    & data$annais!=1912
    & data$annais!=1911
    & data$annais!=1910
    & data$annais!=1909
    & data$annais!=1908
    & data$annais!=1907
    & data$annais!=1906
    & data$annais!=1905
    & data$annais!=1904
    & data$annais!=1903
    & data$annais!=1902
    & data$annais!=1901
    & data$annais!=1900)

data <- na.omit(data)

year <- data$annais
count <- data$nombre
cluster <- data$cluster

data <- data.frame(year, count, cluster)

ggplot(data[order(cluster, decreasing = T),], aes(fill=cluster, y=count, x=year)) +
    geom_bar(position="fill", stat="identity", width=1) +
    ggtitle("Proportion des naissances en France par Cluster Culturel") +
    scale_y_continuous(labels = scales::percent) +
    xlab("Année") + ylab("Proportion") +
    theme_grey(base_size = 22) +
    theme(axis.text.x = element_text(angle = 90, size = 12), plot.title = element_text(size = 32, face = "bold"))

dev.off()