#' NHDPlus Catchment
#'
#' Identifies catchments associated with network COMID
#'
#' catchment ploygons can be used to associate landscape attributes to NHDPlusV2
#' flowlines (COMID).
#'
#' Requires NHDPlusCatchment directory
#'
#' see
#' (\url{http://www.horizon-systems.com/NHDPlus/NHDPlusV2_documentation.php})
#' for information about Watershed boundary dataset and its use in NHDPlusV2
#' Only catchments matching network COMID are returned in sf object
#'
#' @param netdelin output form \code{link{net_delin}}
#' @param vpu NHDPlusV2 Vector Processing Unit
#' @param nhdplus_path Directory containing NHDPlusV2 see (\code{net_nhdplus})
#' @param dissolve dissolve catchments \code{(Y/N)}
#'
#' @return named list: \code{$sf_obj} is simple features object;
#'   \code{$group.comid} root COMID of network; \code{$net.comid} COMID upstream
#'   of root COMID; \code{vpu} NHDPlusV2 Vector Processing Unit. \code{$na_cat}
#'   contains comids without catchment \code{$na_cat} records comid's without
#'   catchment (see Details)
#'
#' @examples
#' #' # identify NHDPlusV2 COMID
#' a <- net_sample(nhdplus_path = getwd(), vpu = "01", ws_order = 6, n = 5)
#' # delineate stream network
#' b <- net_delin(group_comid = as.character(a[,"COMID"]), nhdplus_path = getwd(), vpu = "01")
#' C <- net_cat(netdelin = b, vpu = "01", nhdplus_path = getwd(), dissolve = "N")
#' #plot catchments
#' plot(st_geometry(c$sf_obj))
#' #write sf object as shapefile
#' sf::write(c$sf_obj, paste(getwd(),"c.shp",sep = ""))
#' @export

net_cat <- function(netdelin, vpu, nhdplus_path, dissolve){

  dir.spatial <- grep(paste(vpu, "/NHDPlusCatchment", sep = ""),
                      list.dirs(nhdplus_path, full.names = T),
                      value = T)
  dir.spatial <- dir.spatial[grep("NHDPlusCatchment/", dir.spatial, invert = T)]
  catch <- sf::st_read(dir.spatial, layer = "Catchment")
  names(catch)[c(1, 2)] <- toupper(names(catch)[c(1, 2)])
  #some networks do not have matching catchements
  na.cat <- data.frame(vpu = character(), group.comid = character(), net.comid = character())
  ids <- netdelin$Network
  count <- 1

  for (i in unique(ids[ ,"group.comid"])){
    group.comid <- as.character(i)
    net.comid <- as.character(ids[ids[ ,"group.comid"] == i, "net.comid"])
    cat_comid <- dim(catch[catch$FEATUREID %in% net.comid, "FEATUREID"])[1]
    na_len <- length(net.comid[net.comid %in% catch$FEATUREID == F])
    na.cat <- rbind(na.cat, data.frame(net.comid = net.comid[net.comid %in% catch$FEATUREID == F],
                             group.comid = rep(group.comid, na_len),
                             vpu = rep(vpu, na_len)))
    if (cat_comid > 0){
      if (count == 1) {
        save.shp <- catch[catch$FEATUREID %in% net.comid, "FEATUREID"]
        net.ids <- save.shp$FEATUREID
        save.shp <- lwgeom::st_make_valid(save.shp)
        geom <- sf::st_geometry(save.shp)
        save.shp <- sf::st_sf(geom, data.frame(group.comid = rep(group.comid, cat_comid),
                                         net.comid = net.ids,
                                         vpu = rep(vpu, cat_comid)))
      } else {
        temp <- catch[catch$FEATUREID %in% net.comid, "FEATUREID"]
        net.ids <- temp$FEATUREID
        temp <- lwgeom::st_make_valid(temp)
        geom <- sf::st_geometry(temp)
        temp <- sf::st_sf(geom, data.frame(group.comid = rep(group.comid, cat_comid),
                                     net.comid = net.ids,
                                     vpu = rep(vpu, cat_comid)))
        save.shp <- rbind(save.shp, temp)
      }
      count <- count + 1
    } else {
      net.comid <- NA
      na.cat <- rbind(na.cat, cbind(vpu, group.comid, net.comid))
    }
  }

  if (dissolve == "Y"){
    save.shp <- dplyr::group_by(save.shp, group.comid)
    save.shp <- dplyr::summarise(save.shp, subcat_count = length(vpu))
    save.shp <- sf::st_cast(save.shp)
  }

  out.list <- list(sf_obj = save.shp, na_cat = na.cat)
  return(out.list)
}


extract_day <- function(date_string)
{
  datetimestr = chron(date_string, "07:00:00")

  for (i in 1:11)
  {
    print(datetimestr)
    s <- extract_to_shp(datetimestr, format(as.POSIXct(datetimestr),"%Y_%m_%d_%H_%M_%S"))
    datetimestr = datetimestr + 1/24
  }
}

extract_to_shp <- function(date_string, filename)
{
  files <- list.files(".", pattern="a*.tts")
  res = ldply(files, data_for_time, date_string)
  station_locs <- read.csv("station_locs.txt")

  for_shp <- merge(res, station_locs, by="station")
  for_shp <- na.exclude(for_shp)
  s <- SpatialPointsDataFrame(for_shp[3:4], for_shp, proj4string=CRS("+proj=tmerc +lat_0=49 +lon_0=-2 +k=0.9996012717 +x_0=400000
+y_0=-100000 +ellps=airy +datum=OSGB36 +units=m +no_defs"))
  print(bbox(s))
  print(filename)
  #writeOGR(s, ".", filename, driver="ESRI Shapefile")

  return(list(df=for_shp, shp=s))
}


require(Morpho);require(RvtkStatismo);require(rPython)
#' run elastix with statismo-elastix plugin
#'
#' run elastix with statismo-elastix plugin and deform a mesh based on the transform
#' @param fixedimage fix image (in the domain of the deformation model) path
#' @param movingimage moving image path
#' @param model statismo deformation model path
#' @param mesh mesh3d
#' @param outdir where to write elastix output data
#' @param parafile character: optional read parameter file
#' @param IJK2RAS 4x4 transform to project mesh into image space
#'
statismoElastix <- function(fixedimage, movingimage, model, mesh, outdir="./", parafile=NULL, IJK2RAS = diag(c(-1,-1,1,1))) {
    rPython::python.load("statismoElastix.py")
    mesh2ras <- Morpho::applyTransform(mesh,IJK2RAS)
    outmesh <- paste0(tempdir(),"mesh2ras")
    if (is.null(parafile))
        parafile <- ""
    RvtkStatismo::vtkMeshWrite(mesh2ras,outmesh)
    outmeshname <- paste0(outmesh,".vtk")
    callit <- rPython::python.call("statismoElastix",fixedimage, movingimage, model,  outmeshname, outdir,parafile)
    out <- RvtkStatismo::read.vtk(callit)
    out <- Morpho::applyTransform(out,IJK2RAS)
    return(out)
}


PredictModel<-function(workspace=NULL,new.tifs=NULL,out.dir=NULL,thresh=NULL,make.btif=NULL,make.ptif=NULL){

#This functions separates the step of model fit from producing probability or binary surfaces
#the default is to read in a workspace and make predictions using the original tiffs supplied
#but if an mds with new tiff directories are supplied, the function will instead use these
#options are available for setting the threshold
#and true and false for whether to make binary or prob.tif

#my stuff to delete
#workspace=paste("C:\\VisTrails\\mtalbert_20110504T132851","modelWorkspace",sep="\\")
#new.tifs<-out$input$ma.name
#end delete

    load(workspace)

    if(!is.null(new.tifs)){

              ma.name <- new.tifs
                  #get the paths off of the new mds file
                      tif.info<-readLines(ma.name,3)
                      tif.info<-strsplit(tif.info,',')
                      include<-(as.numeric(tif.info[[2]]))
                      paths<-as.character(tif.info[[3]])

              paths<-paths[paths!=""]
            #this line needs to be changed eventually to deal with locations of model fit covaries from different models
            if(out$input$model.source.file=="brt.r") {model.covs<-levels(summary(out$mods$final.mod,plotit=FALSE)[,1])
            pred.fct=brt.predict
            }

            ma.cols <- match(model.covs,sub(".tif","",basename(paths)))
            paths<-paths[ma.cols]
            #checking that all tifs are present
            if(any(is.na(ma.cols))){

                              stop("ERROR: the following geotiff(s) are missing in ",
                                    tif.dir,":  ",paste(ma.names[-r.col][is.na(ma.cols)],collapse=" ,"),sep="")
                            }
            #checking that we have read access to all tiffs
             if(sum(file.access(paths),mode=0)!=0){
                              stop("ERROR: the following geotiff(s) are missing : ",
                                    paths[(file.access(paths)!=0),][1],sep="")

                            }
                            out$dat$tif.ind<-paths
      }

    if(out$input$model.source.file=="rf.r")   {
        pred.fct=rf.predict
        library(randomForest)
        }
    if(out$input$model.source.file=="mars.r") {
        pred.fct=pred.mars
        library(mda)
        }
    if(out$input$model.source.file=="glm.r")  pred.fct=glm.predict
    if(out$input$model.source.file=="brt.r")  {
        pred.fct=brt.predict
        library(gbm)
    }

    if(!is.null(thresh))out$mods$auc.output$thresh<-thresh
    if(!is.null(make.btif)) make.binary.tif<-make.btif
    if(!is.null(make.ptif)) make.p.tif<-make.ptif

       assign("Pred.Surface",Pred.Surface,envir=.GlobalEnv)
      mssg <- proc.tiff(model=out$mods$final.mod,vnames=as.character(out$mods$final.mod$contributions$var),
                  tif.dir=out$dat$tif.dir$dname,filenames=out$dat$tif.ind,pred.fct=pred.fct,factor.levels=out$dat$ma$factor.levels,make.binary.tif=make.binary.tif,
                  thresh=out$mods$auc.output$thresh,make.p.tif=make.p.tif,outfile.p=paste(out.dir,"prob_map.tif",sep="\\"),
                  outfile.bin=paste(out.dir,"bin_map.tif",sep="\\"),tsize=50.0,NAval=-3000,logname=logname,out=out)

}

brt.predict <- function(model,x) {
    # retrieve key items from the global environment #
    # make predictions from complete data only #
    #y <- rep(NA,nrow(x))
    #y[complete.cases(x)] <- predict.gbm(model, x[complete.cases(x),],model$target.trees,type="response")

    # make predictions from full data #
    y <- predict.gbm(model,x,model$target.trees,type="response")
    # encode missing values as -1.
     a<-complete.cases(x)
    y[!(a)]<- NaN

    # return predictions.
    return(y)
    }

pred.mars <- function(model,x) {
    # retrieve key items from the global environment #
    # make predictionss.
    y <- rep(NA,nrow(x))
    y[complete.cases(x)] <- as.vector(mars.predict(model,x[complete.cases(x),])$prediction[,1])

#if(sum(is.na(x))/dim(x)[2]!=sum(is.na(y)))
#h<-is.na(x)
#h<-apply(h,1,sum)
#h=h/35
#f<-is.na(y)
#which((h-f)!=0,arr.ind=TRUE)
#b<-cbind(x[which((h-f)!=0,arr.ind=TRUE),],y[which((h-f)!=0,arr.ind=TRUE)])

#which(is.na(y)
    # encode missing values as -1.
    y[is.na(y)]<- NaN

    # return predictions.
    return(y)
    }

glm.predict <- function(model,x) {
    # retrieve key items from the global environment #
    # make predictionss.

    y <- as.vector(predict(model,x,type="response"))

    # encode missing values as -1.
    y[is.na(y)]<- NaN

    # return predictions.
    return(y)
    }

"mars.predict" <-
function (mars.glm.object,new.data)
{
#
# j leathwick, j elith - August 2006
#
# version 3.1 - developed in R 2.3.1 using mda 0.3-1
#
# calculates a mars/glm object in which basis functions are calculated
# using an initial mars model with single or multiple responses
# data for individual species are then fitted as glms using the
# common set of mars basis functions with results returned as a list
#
# takes as input a dataset and args selecting x and y variables, and degree of interaction
# along with site and species weights, the CV penalty, and the glm family argument
# the latter would normally be one of "binomial" or "poisson" - "gaussian" could be used
# but in this case the model shouldn't differ from that fitted using mars on its own
#
# naming problem for dataframes fixed - je - 15/12/06
#
# requires mda and leathwick/elith's mars.export
#
  require(mda)

# first recreate both the original mars model and the glm model

# setup input data and create original temporary data

  dataframe.name <- mars.glm.object$mars.call$dataframe  # get the dataframe name
  mars.x <- mars.glm.object$mars.call$mars.x
  mars.y <- mars.glm.object$mars.call$mars.y
  n.spp <- length(mars.y)
  family <- mars.glm.object$mars.call$family
  mars.degree <- mars.glm.object$mars.call$degree
  penalty <- mars.glm.object$mars.call$penalty
  site.weights <- mars.glm.object$weights[[1]]
  spp.weights <- mars.glm.object$weights[[2]]

  print("creating original data frame...",quote=FALSE)

  base.data <- as.data.frame(eval.parent(parse(text = dataframe.name),n=3)) #aks

  x.temp <- eval(base.data[, mars.x])                 #form the temporary datasets
  base.names <- names(x.temp)

  xdat <- mars.new.dataframe(x.temp)[[1]]

  ydat <- as.data.frame(base.data[, mars.y])
  names(ydat) <- names(base.data)[mars.y]

  assign("xdat", xdat, pos = 1)               #and assign them for later use
  assign("ydat", ydat, pos = 1)

# now create the temporary dataframe for the new data

  print("checking variable matching with new data",quote = FALSE)

  new.names <- names(new.data)

  for (i in 1:length(base.names)) {

    name <- base.names[i]

    if (!(name %in% new.names)) {
      print(paste("Variable ",name," missing from new data",sep=""),quote = FALSE)  #aks
      return()
    }
  }

  print("and creating temporary dataframe for new data...",quote=FALSE)

  selector <- match(names(x.temp),names(new.data))

  pred.dat <- mars.new.dataframe(new.data[,selector])[[1]]

  assign("pred.dat", pred.dat, pos = 1)               #and assign them for later use

# fit the mars model and extract the basis functions

  print(paste("re-fitting initial mars model for",n.spp,"responses"),quote = FALSE)
  print(paste("using glm family of",family),quote = FALSE)

  #mars.fit <- mars(x = xdat, y = ydat, degree = mars.degree, w = site.weights,
  #  wp = spp.weights, penalty = penalty)

  mars.fit <- mars.glm.object$mars.object  #AKS

  old.bf.data <- as.data.frame(eval(mars.fit$x))
  n.bfs <- ncol(old.bf.data)
  bf.names <- paste("bf", 1:n.bfs, sep = "")
  old.bf.data <- as.data.frame(old.bf.data[,-1])
  names(old.bf.data) <- bf.names[-1]

  new.bf.data <- as.data.frame(mda:::model.matrix.mars(mars.fit,pred.dat))
  new.bf.data <- as.data.frame(new.bf.data[,-1])
  names(new.bf.data) <- bf.names[-1]

# now cycle through the species fitting glm models

  print("fitting glms for individual responses", quote = F)

  prediction <- as.data.frame(matrix(0, ncol = n.spp, nrow = nrow(pred.dat)))
  names(prediction) <- names(ydat)
  standard.errors <- as.data.frame(matrix(0, ncol = n.spp, nrow = nrow(pred.dat)))
  names(standard.errors) <- names(ydat)

  for (i in 1:n.spp) {

    print(names(ydat)[i], quote = FALSE)
    model.glm <- glm(ydat[, i] ~ ., data = old.bf.data, weights = site.weights,
      family = family, maxit = 100)
    temp <- predict.glm(model.glm,new.bf.data,type="response",se.fit=TRUE)
    prediction[,i] <- temp[[1]]
    standard.errors[,i] <- temp[[2]]

    }

  return(list("prediction"=prediction,"ses"=standard.errors))
}

"mars.new.dataframe" <-
function (input.data)
{
#
# j leathwick, j elith - August 2006
#
# version 3.1 - developed in R 2.3.1 using mda 0.3-1
#
# takes an input data frame and checks for factor variables
# converting these to dummy variables, one each for each factor level
# returning it for use with mars.glm so that factor vars can be included
# in a mars analysis
#

  if (!is.data.frame(input.data)) {
    print("input data must be a dataframe..",quote = FALSE)
    return()
  }

  n <- 1
  for (i in 1:ncol(input.data)) {  #first transfer the vector variables
    if (is.vector(input.data[,i])) {
      if (n == 1) {
        output.data <- as.data.frame(input.data[,i])
        names.list <- names(input.data)[i]
        var.type <- "vector"
        factor.level <- "na"
      }
      else {
        output.data[,n] <- input.data[,i]
        names.list <- c(names.list,names(input.data)[i])
        var.type <- c(var.type,"vector")
        factor.level <- c(factor.level,"na")
      }
      names(output.data)[n] <- names(input.data)[i]
      n <- n + 1
    }
  }

  for (i in 1:ncol(input.data)) {  # and then the factor variables
    if (is.factor(input.data[,i])) {
      temp.table <- summary(input.data[,i])
      for (j in 1:length(temp.table)) {
        names.list <- c(names.list,names(input.data)[i])
        var.type <- c(var.type,"factor")
        factor.level <- c(factor.level,names(temp.table)[j])
        output.data[,n] <- ifelse(input.data[,i] == names(temp.table)[j],1,0)
        names(output.data)[n] <- paste(names(input.data)[i],".",names(temp.table)[j],sep="")
        n <- n + 1
      }
    }
  }

  lineage <- data.frame(names(output.data),names.list,var.type,factor.level)
  for (i in 1:4) lineage[,i] <- as.character(lineage[,i])
  names(lineage) <- c("full.name","base.name","type","level")

  return(list(dataframe = output.data, lineage = lineage))
}

new.tifs=NULL
# Interpret command line argurments #
# Make Function Call #
Args <- commandArgs(trailingOnly=FALSE)

    for (i in 1:length(Args)){
     if(Args[i]=="-f") ScriptPath<-Args[i+1]
     }

    for (arg in Args) {
    	argSplit <- strsplit(arg, "=")
    	argSplit[[1]][1]
    	argSplit[[1]][2]
    	if(argSplit[[1]][1]=="ws") ws <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="new.tifs") new.tifs <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="o") out.dir <- argSplit[[1]][2]
    }

PredictModel(workspace=ws,new.tifs=new.tifs,out.dir=out.dir)


#' Epigenome-wide association study (OLD VERSION RETAINED FOR COMPARISON)
#'
#' Test association with each CpG site.
#'
#' @param beta Methylation levels matrix, one row per CpG site, one column per sample.
#' @param variable Independent variable vector.
#' @param covariates Covariates data frame to include in regression model,
#' one row per sample, one column per covariate (Default: NULL).
#' @param batch Batch vector to be included as a random effect (Default: NULL).
#' @param weights Non-negative observation weights.
#' Can be a numeric matrix of individual weights of same dimension as \code{beta},
#' or a numeric vector of weights with length \code{ncol(beta)},
#' or a numeric vector of weights with length \code{nrow(beta)}.
#' @param cell.counts Proportion of cell counts for one cell type in cases
#' where the samples are mainly composed of two cell types (e.g. saliva) (Default: NULL).
#' @param isva Apply Independent Surrogate Variable Analysis (ISVA) to the
#' methylation levels and include the resulting variables as covariates in a
#' regression model (Default: TRUE).
#' @param sva Apply Surrogate Variable Analysis (SVA) to the
#' methylation levels and covariates and include
#' the resulting variables as covariates in a regression model (Default: TRUE).
#' @param smartsva Apply the SmartSVA algorithm to the
#' methylation levels and include the resulting variables as covariates in a
#' regression model (Default: FALSE).
#' @param n.sv Number of surrogate variables to calculate (Default: NULL).
#' @param winsorize.pct Apply all regression models to methylation levels
#' winsorized to the given level. Set to NA to avoid winsorizing (Default: 0.05).
#' @param robust Test associations with the 'robust' option when \code{\link{limma::eBayes}}
#' is called (Default: TRUE).
#' @param rlm Test assocaitions with the 'robust' option when \code{\link{limma:lmFit}}
#' is called (Default: FALSE).
#' @param outlier.iqr.factor For each CpG site, prior to fitting regression models,
#' set methylation levels less than
#' \code{Q1 - outlier.iqr.factor * IQR} or more than
#' \code{Q3 + outlier.iqr.factor * IQR} to NA. Here IQR is the inter-quartile
#' range of the methylation levels at the CpG site, i.e. Q3-Q1.
#' Set to NA to skip this step (Default: NA).
#' @param most.variable Apply (Independent) Surrogate Variable Analysis to the
#' given most variable CpG sites (Default: 50000).
#' @param featureset Name from \code{\link{meffil.list.featuresets}()}  (Default: NA).
#' @param verbose Set to TRUE if status updates to be printed (Default: FALSE).
#'
#' @export
meffil.ewas.old <- function(beta, variable,
                        covariates=NULL, batch=NULL, weights=NULL,
                        cell.counts=NULL,
                        isva=T, sva=T, smartsva=F, ## cate?
                        n.sv=NULL,
                        isva0=F,isva1=F, ## deprecated
                        winsorize.pct=0.05,
                        robust=TRUE,
                        rlm=FALSE,
                        outlier.iqr.factor=NA, ## typical value = 3
                        most.variable=min(nrow(beta), 50000),
                        featureset=NA,
                        random.seed=20161123,
                        lmfit.safer=F,
                        verbose=F) {

    if (isva0 || isva1)
        stop("isva0 and isva1 are deprecated and superceded by isva and sva")

    stopifnot(is.matrix(beta))

    if (is.na(featureset))
        featureset <- guess.featureset(rownames(beta))
    features <- meffil.get.features(featureset)

    stopifnot(length(rownames(beta)) > 0 && all(rownames(beta) %in% features$name))
    stopifnot(ncol(beta) == length(variable))
    stopifnot(is.null(covariates) || is.data.frame(covariates) && nrow(covariates) == ncol(beta))
    stopifnot(is.null(batch) || length(batch) == ncol(beta))
    stopifnot(is.null(weights)
              || is.numeric(weights) && (is.matrix(weights) && nrow(weights) == nrow(beta) && ncol(weights) == ncol(beta)
                                         || is.vector(weights) && length(weights) == nrow(beta)
                                         || is.vector(weights) && length(weights) == ncol(beta)))
    stopifnot(most.variable > 1 && most.variable <= nrow(beta))
    stopifnot(!is.numeric(winsorize.pct) || winsorize.pct > 0 && winsorize.pct < 0.5)

    original.variable <- variable
    original.covariates <- covariates
    if (is.character(variable))
        variable <- as.factor(variable)

    stopifnot(!is.factor(variable) || is.ordered(variable) || length(levels(variable)) == 2)

    msg("Simplifying any categorical variables.", verbose=verbose)
    variable <- simplify.variable(variable)
    if (!is.null(covariates))
        covariates <- do.call(cbind, lapply(covariates, simplify.variable))

    sample.idx <- which(!is.na(variable))
    if (!is.null(covariates))
        sample.idx <- intersect(sample.idx, which(apply(!is.na(covariates), 1, all)))

    msg("Removing", ncol(beta) - length(sample.idx), "missing case(s).", verbose=verbose)

    if (is.matrix(weights))
        weights <- weights[,sample.idx]
    if (is.vector(weights) && length(weights) == ncol(beta))
        weights <- weights[sample.idx]

    beta <- beta[,sample.idx]
    variable <- variable[sample.idx]

    if (!is.null(covariates))
        covariates <- covariates[sample.idx,,drop=F]

    if (!is.null(batch))
        batch <- batch[sample.idx]

    if (!is.null(cell.counts))
        cell.counts <- cell.counts[sample.idx]

    if (!is.null(covariates)) {
        pos.var.idx <- which(apply(covariates, 2, var, na.rm=T) > 0)
        msg("Removing", ncol(covariates) - length(pos.var.idx), "covariates with no variance.",
            verbose=verbose)
        covariates <- covariates[,pos.var.idx, drop=F]
    }

    covariate.sets <- list(none=NULL)
    if (!is.null(covariates))
        covariate.sets$all <- covariates

    if (is.numeric(winsorize.pct))  {
        msg(winsorize.pct, "- winsorizing the beta matrix.", verbose=verbose)
        beta <- winsorize(beta, pct=winsorize.pct)
    }

    too.hi <- too.lo <- NULL
    if (is.numeric(outlier.iqr.factor)) {
        q <- rowQuantiles(beta, probs = c(0.25, 0.75), na.rm = T)
        iqr <- q[,2] - q[,1]
        too.hi <- which(beta > q[,2] + outlier.iqr.factor * iqr, arr.ind=T)
        too.lo <- which(beta < q[,1] - outlier.iqr.factor * iqr, arr.ind=T)
        if (nrow(too.hi) > 0) beta[too.hi] <- NA
        if (nrow(too.lo) > 0) beta[too.lo] <- NA
    }

    surrogates.ret <- NULL
    if (isva || sva || smartsva) {
        beta.sva <- beta

        autosomal.sites <- meffil.get.autosomal.sites(featureset)
        autosomal.sites <- intersect(autosomal.sites, rownames(beta.sva))

        if (is.null(most.variable))
            most.variable <- length(autosomal.sites)

        beta.sva <- beta.sva[autosomal.sites,]

        var.idx <- order(rowVars(beta.sva, na.rm=T), decreasing=T)[1:most.variable]
        beta.sva <- impute.matrix(beta.sva[var.idx,,drop=F])

        if (!is.null(covariates)) {
            cov.frame <- model.frame(~., data.frame(covariates, stringsAsFactors=F), na.action=na.pass)
            mod0 <- model.matrix(~., cov.frame)
        }
        else
            mod0 <- matrix(1, ncol=1, nrow=length(variable))
        mod <- cbind(mod0, variable)

        if (isva) {
            msg("ISVA.", verbose=verbose)
            set.seed(random.seed)
            isva.ret <- isva(beta.sva, mod, ncomp=n.sv, verbose=verbose)
            if (!is.null(covariates))
                covariate.sets$isva <- data.frame(covariates, isva.ret$isv, stringsAsFactors=F)
            else
                covariate.sets$isva <- as.data.frame(isva.ret$isv)
            surrogates.ret <- isva.ret
            cat("\n")
        }

        if (sva) {
            msg("SVA.", verbose=verbose)
            set.seed(random.seed)
            sva.ret <- sva(beta.sva, mod=mod, mod0=mod0, n.sv=n.sv)
            if (!is.null(covariates))
                covariate.sets$sva <- data.frame(covariates, sva.ret$sv, stringsAsFactors=F)
            else
                covariate.sets$sva <- as.data.frame(sva.ret$sv)
            surrogates.ret <- sva.ret
            cat("\n")
        }

        if (smartsva) {
            msg("smartSVA.", verbose=verbose)
            set.seed(random.seed)
            if (is.null(n.sv)) {
                beta.res <- t(resid(lm(t(beta.sva) ~ ., data=as.data.frame(mod))))
                n.sv <- EstDimRMT(beta.res, FALSE)$dim + 1
            }
            smartsva.ret <- smartsva.cpp(beta.sva, mod=mod, mod0=mod0, n.sv=n.sv)
            if (!is.null(covariates))
                covariate.sets$smartsva <- data.frame(covariates, smartsva.ret$sv, stringsAsFactors=F)
            else
                covariate.sets$smartsva <- as.data.frame(smartsva.ret$sv)
            surrogates.ret <- smartsva.ret
            cat("\n")
        }
    }

    analyses <- sapply(names(covariate.sets), function(name) {
        msg("EWAS for covariate set", name, verbose=verbose)
        covariates <- covariate.sets[[name]]
        ewas.old(variable,
             beta=beta,
             covariates=covariates,
             batch=batch,
             weights=weights,
             cell.counts=cell.counts,
             winsorize.pct=winsorize.pct,
             robust=robust,
             rlm=rlm,
             lmfit.safer=lmfit.safer,
             verbose=verbose)
    }, simplify=F)

    p.values <- sapply(analyses, function(analysis) analysis$table$p.value)
    coefficients <- sapply(analyses, function(analysis) analysis$table$coefficient)
    rownames(p.values) <- rownames(coefficients) <- rownames(analyses[[1]]$table)

    for (name in names(analyses)) {
        idx <- match(rownames(analyses[[name]]$table), features$name)
        analyses[[name]]$table$chromosome <- features$chromosome[idx]
        analyses[[name]]$table$position <- features$position[idx]
    }

    list(class="ewas",
         version=packageVersion("meffil"),
         samples=sample.idx,
         variable=original.variable[sample.idx],
         covariates=original.covariates[sample.idx,,drop=F],
         winsorize.pct=winsorize.pct,
         robust=robust,
         rlm=rlm,
         outlier.iqr.factor=outlier.iqr.factor,
         most.variable=most.variable,
         p.value=p.values,
         coefficient=coefficients,
         analyses=analyses,
         random.seed=random.seed,
         sva.ret=surrogates.ret,
         too.hi=too.hi,
         too.lo=too.lo)
}

# Test associations between \code{variable} and each row of \code{beta}
# while adjusting for \code{covariates} (fixed effects) and \code{batch} (random effect).
# If \code{cell.counts} is not \code{NULL}, then it is assumed that
# the methylation data is derived from samples with two cell types.
# \code{cell.counts} should then be a vector of numbers
# between 0 and 1 of length equal to \code{variable} corresponding
# to the proportions of cell of a selected cell type in each sample.
# The regression model is then modified in order to identify
# associations specifically in the selected cell type (PMID: 24000956).
ewas.old <- function(variable, beta, covariates=NULL, batch=NULL, weights=NULL, cell.counts=NULL, winsorize.pct=0.05,
                 robust=TRUE, rlm=FALSE, lmfit.safer=F, verbose=F) {
    stopifnot(all(!is.na(variable)))
    stopifnot(length(variable) == ncol(beta))
    stopifnot(is.null(covariates) || nrow(covariates) == ncol(beta))
    stopifnot(is.null(batch) || length(batch) == ncol(beta))
    stopifnot(is.null(cell.counts)
              || length(cell.counts) == ncol(beta)
              && all(cell.counts >= 0 & cell.counts <= 1))

    method <- "ls"
    if (rlm) method <- "robust"

    if (is.null(covariates))
        design <- data.frame(intercept=1, variable=variable)
    else
        design <- data.frame(intercept=1, variable=variable, covariates)
    rownames(design) <- colnames(beta)

    if (!is.null(cell.counts)) {
        ## Irizarray method: Measuring cell-type specific differential methylation
        ##      in human brain tissue
        ## Mi is methylation level for sample i
        ## Xi is the value of the variable of interest for sample i
        ## pi is the proportion of the target cell type for sample i
        ## thus: Mi ~ target cell methylation * pi + other cell methylation * (1-pi)
        ## and target cell methylation = base target methylation + effect of Xi value
        ## and other cell methylation = base other methylation + effect of Xi value
        ## thus:
        ## Mi = (T + U Xi)pi + (O + P Xi)(1-pi) + e
        ##    = C + A Xi pi + B Xi (1-pi) + e
        design <- design[,-which(colnames(design) == "intercept")]

        design <- cbind(design * cell.counts,
                        typeB=design * (1-cell.counts))
    }

    msg("Linear regression with limma::lmFit", verbose=verbose)
    fit <- NULL
    batch.cor <- NULL
    if (!is.null(batch)) {
        msg("Adjusting for batch effect", verbose=verbose)
        corfit <- duplicateCorrelation(beta, design, block=batch, ndups=1)
        batch.cor <- corfit$consensus
        msg("Linear regression with batch as random effect", verbose=verbose)
        tryCatch(fit <- lmFit(beta, design, method=method, block=batch, cor=batch.cor, weights=weights),
                 error=function(e) {
                     print(e)
                     msg("lmFit failed with random effect batch variable, omitting", verbose=verbose)
                 })
    }
    if (is.null(fit)) {
        msg("Linear regression with only fixed effects", verbose=verbose)
        batch <- NULL
        if (!lmfit.safer)
           fit <- lmFit(beta, design, method=method, weights=weights)
        else
           fit <- lmfit.safer.old(beta, design, method=method, weights=weights, verbose=verbose)
    }

    msg("Empirical Bayes", verbose=verbose)
    if (is.numeric(winsorize.pct) && robust) {
      fit.ebayes <- eBayes(fit, robust=T, winsor.tail.p=c(winsorize.pct, winsorize.pct))
    } else {
      fit.ebayes <- eBayes(fit, robust=robust)
    }

    alpha <- 0.975
    std.error <- (sqrt(fit.ebayes$s2.post) * fit.ebayes$stdev.unscaled[,"variable"])
    margin.error <- (std.error * qt(alpha, df=fit.ebayes$df.total))
    n <- apply(beta, 1, function(v) sum(!is.na(v)))

    list(design=design,
         batch=batch,
         batch.cor=batch.cor,
         cell.counts=cell.counts,
         table=data.frame(p.value=fit.ebayes$p.value[,"variable"],
             fdr=p.adjust(fit.ebayes$p.value[,"variable"], "fdr"),
             p.holm=p.adjust(fit.ebayes$p.value[,"variable"], "holm"),
             t.statistic=fit.ebayes$t[,"variable"],
             coefficient=fit.ebayes$coefficient[,"variable"],
             coefficient.ci.high=fit.ebayes$coefficient[,"variable"] + margin.error,
             coefficient.ci.low=fit.ebayes$coefficient[,"variable"] - margin.error,
             coefficient.se=std.error,
             n=n))
}

## apply lmFit to subsets of the methylation matrix to hopefully avoid
## out-of-memory errors (mainly for really large datasets or low memory servers)
lmfit.safer.old <- function(beta, design, method, weights, n.partitions=8, verbose=F) {
  partitions <- sample(1:n.partitions, nrow(beta), replace=T)
  fits <- lapply(1:n.partitions, function(part) {
    msg("Applying limma::lmFit to partition ", part, " of ", n.partitions, ".", verbose=verbose)
    idx <- which(partitions == part)
    lmFit(beta[idx,], design, method=method, weights=weights)
  })
  idx <- unlist(lapply(1:n.partitions, function(part) which(partitions==part)))
  idx <- match(1:nrow(beta), idx)
  fit <- fits[[1]]
  for (item in c("coefficients", "stdev.unscaled")) {
      fit[[item]] <- do.call(rbind, lapply(fits, function(fit) fit[[item]]))[idx,]
  }
  for (item in c("df.residual", "sigma", "Amean")) {
     fit[[item]] <- do.call(c, lapply(fits, function(fit) fit[[item]]))[idx]
  }
  fit
}


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

BridgeRDraw <- function(InputFile="BridgeR_5C_HalfLife_calculation_R2_selection.txt",
                        group,
                        hour,
                        ComparisonFile,
                        CutoffRelExp = 0,
                        CutoffDataPoint = 4,
                        InforColumn = 4,
                        GeneInfor = 2,
                        OutputDir = "BridgeRDraw_fig",
                        ModelMode = "R2_selection",
                        DrawMode = "Simple",
                        Color = c("black","red")){
    ###Check_ModelMode & DrawMode###
    if(ModelMode == "Raw_model" || ModelMode == "Three_model" || ModelMode == "R2_selection"){
        if(DrawMode == "Simple" || DrawMode == "Ribbon"){
            ###Make_stored_directory###
            ComparisonFile_name <- paste(ComparisonFile, collapse = "_")
            output_dir_name <- paste(OutputDir, ComparisonFile_name, sep="_")
            dir.create(output_dir_name)

            ###Prepare_file_infor###
            time_points <- length(hour)
            group_number <- length(group)
            input_file <- fread(InputFile, header = T)
            comp_file_number <- NULL
            for(a in 1:length(ComparisonFile)){
                comp_file_number <- append(comp_file_number, which(group == ComparisonFile[a])) #1,2,3 => 1,2 || 1,3
            }

            ###Draw_fitting_curve###
            gene_number <- length(input_file[[1]])
            for(x in 1:gene_number){
                data <- as.vector(as.matrix(input_file[x,]))

                #Save_fig
                gene_name <- as.character(data[GeneInfor])
                file_name <- sprintf("%1$s.png",gene_name)
                file_name <- paste(output_dir_name, "/", file_name, sep="")
                png(filename = file_name, width=640, height=640)

                #Prepare_ggplot2
                p <- ggplot()

                flg <- 0
                fig_color <- NULL
                for(a in comp_file_number){
                    #Select_color
                    if(flg == 0){
                        fig_color <- Color[1]
                    }else if(flg == 1){
                        fig_color <- Color[2]
                    }

                    infor_st <- NULL
                    infor_ed <- NULL
                    model_name <- NULL
                    if(ModelMode == "Raw_model" || ModelMode == "R2_selection"){
                        infor_st <- 1 + (a - 1)*(time_points + InforColumn + 3)
                        infor_ed <- (InforColumn)*a + (a - 1)*(time_points + 3)
                        model_index <- infor_ed + time_points + 1
                        model_name <- data[model_index]
                    }else if(ModelMode == "Three_model"){
                        infor_st <- 1 + (a - 1)*(time_points + InforColumn + 23)
                        infor_ed <- (InforColumn)*a + (a - 1)*(time_points + 23)
                        model_index <- infor_ed + time_points + 21
                        model_name <- data[model_index]
                    }
                    exp_st <- infor_ed + 1
                    exp_ed <- infor_ed + time_points

                    exp_data <- as.numeric(data[exp_st:exp_ed])
                    time_point_exp_original <- data.frame(hour=hour, exp=exp_data)

                    if(ModelMode == "R2_selection"){
                        if(model_name == "Raw" || model_name == "Notest"){
                        }else{
                            select_name <- gsub("Delete_", "", model_name)
                            select_name <- gsub("hr", "", select_name)
                            select_name <- as.numeric(as.vector(strsplit(select_name, "_")[[1]])) #Delete_1hr_2hr
                            for(test in select_name){
                                time_point_exp_original <- time_point_exp_original[time_point_exp_original$hour != test,]
                            }
                        }
                    }

                    #Draw_time_points
                    p <- p + geom_point(data = time_point_exp_original,
                                   mapping = aes(x = hour, y = exp),
                                   size = 4,
                                   shape = 19,
                                   colour = fig_color)

                    #Remove_exp0_data
                    time_point_exp <- time_point_exp_original[time_point_exp_original$exp > CutoffRelExp,]
                    data_point <- length(time_point_exp$exp)

                    #Draw_fitting_curve
                    if(!is.null(time_point_exp)){
                        if(data_point >= CutoffDataPoint){
                            if(ModelMode == "Raw_model" || ModelMode == "R2_selection"){
                                model <- lm(log(time_point_exp$exp) ~ time_point_exp$hour - 1)
                                fig_data <- data.frame(hour=time_point_exp$hour)
                                predicted <- as.numeric(as.vector(as.matrix(predict(model, fig_data))))
                                fig_data$exp <- exp(as.vector(as.matrix(predicted)))

                                p <- p + geom_line(data=fig_data,
                                               mapping=(aes(x=hour, y=exp)),
                                               size=1.2,
                                               colour=fig_color)

                            }else if(ModelMode == "Three_model"){
                                if(!is.na(model_name) || model_name != "no_good_model" ||
                                   model_name != "few_data" || model_name != "low_expresion"){
                                    #Parameter_setting
                                    a_1_index <- exp_ed + 4
                                    a_2_index <- exp_ed + 10
                                    b_2_index <- exp_ed + 11
                                    a_3_index <- exp_ed + 16
                                    b_3_index <- exp_ed + 17
                                    c_3_index <- exp_ed + 18
                                    model_index <- exp_ed + 21
                                    model <- data[model_index]

                                    #model_curve
                                    if(flg == 0){
                                        model_curve_1 <- NULL
                                        a_1_1 <- as.numeric(data[a_1_index])
                                        a_2_1 <- as.numeric(data[a_2_index])
                                        b_2_1 <- as.numeric(data[b_2_index])
                                        a_3_1 <- as.numeric(data[a_3_index])
                                        b_3_1 <- as.numeric(data[b_3_index])
                                        c_3_1 <- as.numeric(data[c_3_index])
                                        if(model == "model1"){
                                            model_curve_1 <- function(t){exp(-a_1_1 * t)}
                                        }else if(model == "model2"){
                                            model_curve_1 <- function(t){(1.0 - b_2_1) * exp(-a_2_1 * t) + b_2_1}
                                        }else if(model == "model3"){
                                            model_curve_1 <- function(t){(c_3_1) * exp(-a_3_1 * t) + (1.0 - c_3_1) * exp(-b_3_1 * t)}
                                        }
                                        p <- p + geom_path(stat="function",
                                                       fun=model_curve_1,
                                                       mapping=aes(color="model_curve_1"),
                                                       size=1.2)
                                    }else if(flg == 1){
                                        model_curve_2 <- NULL
                                        a_1_2 <- as.numeric(data[a_1_index])
                                        a_2_2 <- as.numeric(data[a_2_index])
                                        b_2_2 <- as.numeric(data[b_2_index])
                                        a_3_2 <- as.numeric(data[a_3_index])
                                        b_3_2 <- as.numeric(data[b_3_index])
                                        c_3_2 <- as.numeric(data[c_3_index])
                                        if(model == "model1"){
                                            model_curve_2 <- function(t){exp(-a_1_2 * t)}
                                        }else if(model == "model2"){
                                            model_curve_2 <- function(t){(1.0 - b_2_2) * exp(-a_2_2 * t) + b_2_2}
                                        }else if(model == "model3"){
                                            model_curve_2 <- function(t){(c_3_2) * exp(-a_3_2 * t) + (1.0 - c_3_2) * exp(-b_3_2 * t)}
                                        }
                                        p <- p + geom_path(stat="function",
                                                       fun=model_curve_2,
                                                       mapping=aes(color="model_curve_2"),
                                                       size=1.2)
                                    }
                                }else{ #!is.na(model_name) || model_name != "no_good_model" || model_name != "few_data" || model_name != "low_expresion"
                                }
                            } #ModelMode: Raw_model, R2_selection, Three_model
                        }else{ #data_point >= CutoffDataPoint
                        }
                    }else{ #!is.null(time_point_exp)
                    }
                    flg <- 1
                } #a in comp_file_number

                if(ModelMode == "Three_model"){
                    p <- p + scale_colour_manual(name="Sample",
                                                 values=c("model_curve_1"="black","model_curve_2"="red"),
                                                 labels=ComparisonFile)
                }

                p <- p + ggtitle(gene_name)
                p <- p + xlab("Time")
                p <- p + ylab("Relative RPKM (Time0 = 1)")
                p <- p + xlim(0,12)
                ybreaks <- seq(0,10,0.1)[2:101]
                p <- p + scale_y_log10(breaks=ybreaks,labels=ybreaks)
                plot(p)

                dev.off() #close_fig
                plot.new()
            }
        }else{
            return(print("ERROR: Defined wrong DrawMode. Choose the following DrawMode: Simple, Ribbon. You cannot choose Ribbon mode
                         if you use Three_model ModelMode."))
        }
    }else{
        return(print("ERROR: Defined wrong ModelMode. Choose the following ModelMode: Raw_model, Three_model, R2_selection"))
    }
}

#####################################################
BridgeRDrawFittingCurve <- function(filename="BridgeR_4_Normalized_expression_dataset.txt", group, hour, ComparisonFile, CutoffRelExp = 0.1, CutoffDataPoint = 3, InforColumn = 4, OutputDir = "BridgeR_fig", OutputFile = "BridgeR_4_HalfLife_Pvalue.txt"){
    ###Import_library###
    #library(data.table)
    #library(ggplot2)

    ###Make_stored_directory###
    ComparisonFile_name = paste(ComparisonFile,collapse="_")
    output_dir_name <- paste(OutputDir,ComparisonFile_name,sep="_")
    dir.create(output_dir_name)

    ###Prepare_file_infor###
    time_points <- length(hour)
    group_number <- length(group)
    input_file <- fread(filename, header=T)
    comp_file_number <- NULL
    for(a in 1:length(ComparisonFile)){
        comp_file_number <- append(comp_file_number, which(group == ComparisonFile[a]))
    }
    output_file <- OutputFile

    #setwd(output_dir_name)

    ###print_header###
    cat("",file=output_file)
    hour_label <- NULL
    for(a in comp_file_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("Model","Decay_rate_coef","coef_error","coef_p-value","R2","Adjusted_R2","Residual_standard_error","half_life","SD_ori","half_exp_minus","half_exp_plus","half_life_SD", sep="\t", file=output_file, append=T)
    }
    cat("\t", sep="", file=output_file, append=T)
    cat("p_value(Welch Modified Two-Sample t-Test)","\n", sep="\t", file=output_file, append=T)

    ###Draw_fitting_curve###
    gene_number <- length(input_file[[1]])
    for(x in 1:gene_number){
        data <- as.vector(as.matrix(input_file[x,]))

        #Save_fig
        gene_name <- as.character(data[2])
        file_name <- sprintf("%1$s.png",gene_name)
        file_name <- paste(output_dir_name,"/",file_name,sep="")
        png(filename=file_name,width = 640, height = 640)

        #Prepare_ggplot2
        p.fitting <- ggplot()

        flg <- 0
        fig_color <- NULL
        N_for_p <- NULL
        SD_for_p <- NULL
        X_for_p <- NULL
        flg_for_p <- 0
        for(a in comp_file_number){
            if(flg == 0){
                fig_color <- "black"
            }else{
                fig_color <- "red"
                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

            gene_infor <- data[infor_st:infor_ed]
            cat(gene_infor, sep="\t", file=output_file, append=T)
            cat("\t", file=output_file, append=T)
            exp <- as.numeric(data[exp_st:exp_ed])
            cat(exp, sep="\t", file=output_file, append=T)
            cat("\t", file=output_file, append=T)
            #hour <- c(0,1,2,4,8,12) ###TEST###
            #exp <- c(1,0.8350178,0.7806458,0.6386572,0.3946119,0.2603135) #
            ##exp <- c(1,0.9637603,1.131551,1.025119,1.246695,1.437431) #
            #gene_name <- "test" #
            #fig_color <- "black" #
            #CutoffRelExp <- 0.1 #
            #CutoffDataPoint <- 3 #
            time_point_exp_original <- data.frame(hour,exp)

            #p.fitting <- ggplot() #
            p.fitting <- p.fitting + geom_point(data=time_point_exp_original,
                                           mapping=aes(x=hour, y=exp),
                                           size=4,
                                           shape=19,
                                           colour=fig_color)

            time_point_exp <- time_point_exp_original[time_point_exp_original$exp >= CutoffRelExp, ] #>=0.1
            data_point <- length(time_point_exp$exp)

            if(!is.null(time_point_exp)){
                if(data_point >= CutoffDataPoint){ #>=3
                    model <- lm(log(time_point_exp$exp) ~ time_point_exp$hour - 1)
                    model_summary <- summary(model)
                    coef <- -model_summary$coefficients[1]
                    coef_error <- model_summary$coefficients[2]
                    coef_p <- model_summary$coefficients[4]
                    r_squared <- model_summary$r.squared
                    adj_r_squared <- model_summary$adj.r.squared
                    residual_standard_err <- model_summary$sigma
                    half_life <- log(2)/coef
                    #if(coef < 0 || half_life >= 24){
                    #    half_life <- 24
                    #}
                    if(coef < 0){
                        half_life <- Inf
                    }
                    cat("Exponential_Decay_Model",coef,coef_error,coef_p,r_squared,adj_r_squared,residual_standard_err,half_life, sep="\t", file=output_file, append=T)

                    half_life_exp_lm <- exp(log(0.5))

                    xmin <- min(hour[1])
                    xmax <- max(hour[length(hour)])

                    predicted2 <- data.frame(hour=time_point_exp$hour)
                    predicted2_ribbon <- data.frame(hour=time_point_exp$hour)

                    pred_conf <- predict(model, predicted2, interval="prediction",level=0.95)

                    pred_conf2_SE <- predict(model, predicted2, se.fit=T)

                    Fit <- pred_conf2_SE$fit
                    df <- pred_conf2_SE$df
                    SE_fit <- pred_conf2_SE$se.fit
                    Residual_fit <- pred_conf2_SE$residual.scale

                    Space_minus <- function(Fit,SE_fit){
                        Fit-sqrt(SE_fit^2+Residual_fit^2)*qt(0.950,df)
                    }
                    Space_plus <- function(Fit,SE_fit){
                        Fit+sqrt(SE_fit^2+Residual_fit^2)*qt(0.950,df)
                    }
                    SE_test <- function(Fit,SE_fit){
                        sqrt(SE_fit^2+Residual_fit^2)
                    }
                    test_minus <- Space_minus(Fit,SE_fit)
                    test_plus <- Space_plus(Fit,SE_fit)
                    test_SE <- SE_test(Fit,SE_fit)

                    SE_table <- data.frame(hour=time_point_exp$hour,exp=SE_fit)
                    SE_model <- lm((SE_table$exp) ~ SE_table$hour - 1)
                    SE_model_coef <- (summary(SE_model))$coefficients[1]
                    SE_half_life <- SE_model_coef*half_life

                    SE_fitting_curve <- sqrt(SE_half_life^2 + Residual_fit^2)
                    SD_fitting_curve <- SE_fitting_curve * sqrt(data_point-1)

                    half_life_exp_lm_minus <- exp(log(0.5)-SD_fitting_curve)
                    half_life_exp_lm_plus <- exp(log(0.5)+SD_fitting_curve)
                    half_life_plus <- -log(half_life_exp_lm_minus)/coef
                    half_life_minus <- -log(half_life_exp_lm_plus)/coef
                    SD_for_test <- half_life_plus - half_life
                    SD_for_test <- half_life - half_life_minus

                    N_for_p <- append(N_for_p,data_point)
                    SD_for_p <- append(SD_for_p, SD_for_test)
                    X_for_p <- append(X_for_p, half_life)

                    cat("\t", sep="\t", file=output_file, append=T)
                    cat(SD_fitting_curve,half_life_exp_lm_minus,half_life_exp_lm_plus,SD_for_test, sep="\t", file=output_file, append=T)

                    #model1_pred <- function(x)
                    #{
                    #    mRNA_exp <- (x * hour)
                    #}
                    #SE_data <- data.frame(hour=hour,exp=model1_pred(SE_model_coef))

                    #pred_conf <- predict(model, predicted2, interval="confidence",level=0.95)
                    predicted2$exp <- exp(as.vector(as.matrix(pred_conf[,1])))
                    predicted2_ribbon$exp_minus <- exp(as.vector(as.matrix(pred_conf[,2])))
                    predicted2_ribbon$exp_plus <- exp(as.vector(as.matrix(pred_conf[,3])))

                    p.fitting <- p.fitting + geom_line(data=predicted2,
                                                   mapping=(aes(x=hour, y=exp)),
                                                   size=1.2,
                                                   colour=fig_color)
                    p.fitting <- p.fitting + geom_ribbon(data=predicted2_ribbon,
                                                   mapping=aes(x=hour,ymin=exp_minus,ymax=exp_plus),
                                                   alpha=0.1,
                                                   fill=fig_color)
                    p.fitting <- p.fitting + ggtitle(gene_name)
                    p.fitting <- p.fitting + xlab("Time")
                    p.fitting <- p.fitting + ylab("Relative RPKM (Time0 = 1)")
                    p.fitting <- p.fitting + xlim(0,12)
                    ybreaks <- seq(0,10,0.1)[2:101]
                    p.fitting <- p.fitting + scale_y_log10(breaks=ybreaks,labels=ybreaks)
                    plot(p.fitting)
                }else{
                    cat("few_data","NA","NA","NA","NA","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                    flg_for_p <- 1
                }
            }else{  ###TEST###
                cat("low_expresion","NA","NA","NA","NA","NA","NA","NA","NA","NA","NA","NA", sep="\t", file=output_file, append=T)
                flg_for_p <- 1
            }
            flg = 1
        }
        t_test <- "NA"
        p_value <- "NA"
        if(flg_for_p != 1){
            t_test <- tsum.test(mean.x=X_for_p[1], s.x=SD_for_p[1], n.x=N_for_p[1],
                                mean.y=X_for_p[2], s.y=SD_for_p[2], n.y=N_for_p[2])
            p_value <- t_test$p.value
        }
        cat("\t", sep="\t", file=output_file, append=T)
        cat(p_value,"\n", sep="\t", file=output_file, append=T)
        dev.off() #close_fig
        plot.new()
    }
}


open methanol.xyz
bond 1.55
%hybridize 0 SP2
model GAFF
thermostat ANDERSEN
energy
minimize 0.0001 0.00001 40000 1000 min.xyz
energy
heat 300 50 400 0.01 0.01 0.0001 0.00001 0.3 heat.xyz
temperature
energy
prod 0.0001 0.0001 300 .3 500000 1000 prod.xyz


###############################################################################
#                               Curate CEDEN Data
#                          Gabilan Creek Turbidity TMDL
#                                   11/27/2019
#                         john.inman@waterboards.ca.gov
###############################################################################
options(max.print=1000)
rm(list =ls())
today <- format(Sys.Date(), "%Y%m%d")

# Pull in raw CEDEN download
data_dir <- 'H:\\gabilan-turbidity-tmdl\\data\\'
data <- # downloaded from CEDEN on 5/16/2019
    read.csv(paste0(data_dir, 'ceden-turbidity-raw.csv'))

# remove non-creeks, etc.
site_desc <- read.csv(paste0(data_dir, 'removed-sites.csv'))
rem_sites <- site_desc$StationCode[site_desc$Remove == 1]
data <- data[is.na(match(data$StationCode, rem_sites)), ]

# remove NAs
data <- data[!is.na(data$Result), ]

# Remove rows with "Failed" QAQC flags
# rows with "failed" flags
failed <- which(substr(as.character(data$QACode), 1, 1) == "F")
# remove rows with "failed" flags
data <- data[-failed, ]

# Remove duplicates
data$date <- # format date for unique id
    as.Date(data$SampleDate, format = "%m/%d/%Y")
data$sample_id <- # create unique id for each sampling event
    paste0(data$StationCode, "-", data$date)
ids <- # get list of unique ids
    unique(sort(data$sample_id))
dupe_ids <- # get list of duplicate ids
    which(table(data$sample_id) > 1)
dupes <- # df of dupes
    data[data$sample_id %in% names(dupe_ids), ]
dupes <- # sorted
    dupes[order(dupes$sample_id), ]
uniques <- # df without dupes
    data[!(data$sample_id %in% dupes$sample_id), ]

ccamp <- # df of ccamp dupes
    dupes[dupes$Program == "Surface Water Ambient Monitoring Program", ]
lab_samples <- # dupes due to lab samples (we are keeping these)
    ccamp[ccamp$Meth == "EPA 180.1", ]
not_labs <- # dupes not due to lab samples (we are avering these)
    ccamp[!(ccamp$sample_id %in% lab_samples$sample_id), ]
not_labs_mean <- # df of uniqe sample ids
    not_labs[match(unique(not_labs$sample_id), not_labs$sample_id), ]
not_labs_mean$Result <- # replace with averaged Result
    tapply(not_labs$Result, not_labs$sample_id, mean)

other <- # df of non-ccamp dupes
    dupes[!(dupes$Program == "Surface Water Ambient Monitoring Program"), ]
other <-  # sorted
    other[order(other$sample_id), ]
other_mean <- # df of unique sample ids
    other[match(unique(other$sample_id), other$sample_id), ]
other_mean$Result <- # replace with averaged Result
    tapply(other$Result, other$sample_id, mean)

# Combine all
data <- rbind(uniques, lab_samples, not_labs_mean, other_mean)
# remove tmp cols
data <- data[-match(c("date", "sample_id"), names(data))]

# Export table to shared drive and personal drive
# write.csv(data, paste0(data_dir, "ceden-turbidity.csv"), row.names = F)


get# multicore support and other packages
library(foreach)
library(doParallel)
library(data.table)
library(plyr)
library(dplyr)
library(igraph)
source("infection.r")

monteCarloSirListCont <- function(graph, nRuns) {
  infectedGraphs <- list()
  no_cores <- detectCores() - 1
  cl <- makeCluster(no_cores)
  registerDoParallel(cl)
  infectedGraphs1 <- foreach(i = 1:nRuns) %dopar% {
    # add infection functions to cluster environment
    source("infection.r")
    # add tables to tableList
    temp = runContSIR(graph, 0.5)
    temp

  }

  infectedGraphs2 <- foreach(i = 1:nRuns) %dopar% {
    # add infection functions to cluster environment
    source("infection.r")
    # add tables to tableList
    temp = runContSIR(graph, 1)
    temp

  }

  infectedGraphs3 <- foreach(i = 1:nRuns) %dopar% {
    # add infection functions to cluster environment
    source("infection.r")
    # add tables to tableList
    temp = runContSIR(graph, 5)
    temp

  }

  stopCluster(cl)

  # return average
  # tableList<-rbindlist(tableList)[,lapply(.SD,mean), list(id, graphName)]
  infectedGraphs <-
    c(infectedGraphs1, infectedGraphs2, infectedGraphs3)
  tableList <-
    ldply(infectedGraphs, igraph::as_data_frame, what = "vertices")

  return(tableList)

}

# read the graphs
# get the file names
graphs <-
  list.files("graphs with prop/", pattern = "*.xml", full.names = TRUE)
# read them as igraph objects and put them in a list
graphList <- lapply(graphs, read_graph, format = "graphml")

# for each graph, run the infections
for (g in graphList) {
  n <- 500
  infectionTable <- monteCarloSirListCont(g, n)

  # remove columns that are no longer interesting
  dropColumns <- c("id", "community", "currentState", "wasInfected")
  infectionTable <-
    infectionTable %>% dplyr::select(-dplyr::one_of(dropColumns)) %>% mutate(Iduration =
                                                                               SIduration - Sduration)

  # Export the table with all results
  name <- V(g)$graphName[1]
  type <- V(g)$type[1]
  version <- V(g)$version[1]
  path <- paste0("fullinfection/", name, "_", type, version, ".csv")
  fwrite(
    infectionTable,
    file = path,
    append = FALSE,
    quote = "auto",
    eol = "\n",
    nThread = 6
  )

  # remove columns that are no longer interesting
  dropColumns <-
    c("SIduration", "maxTime", "percentageInfected", "Iduration")
  infectionTable <-
    infectionTable %>% dplyr::select(-dplyr::one_of(dropColumns))

  infectionTable <- infectionTable %>%
    group_by_at(names(infectionTable)[-grep("Sduration", names(infectionTable))]) %>%
    dplyr::summarise(
      sentinel = Sduration %>% mean() %>% round(5),
      sentinelVar = var(Sduration) %>% round(5)
    )

  # Export the graph
  path <- paste0("infectionresult/", name, "_", type, version, ".csv")

  fwrite(
    infectionTable,
    file = path,
    append = FALSE,
    quote = "auto",
    eol = "\n",
    nThread = 6
  )
}


install.packages(c("gganimate", "viridis"))

library(gganimate)
library(viridis)

source("../utility_scripts/data_prep.r")
source("../utility_scripts/annotation_defaults.r")

get_breed_percentage_at_level <- function(levels_filter, levels_string, levels_order) {
  breed_percentages <- scent_data %>%
    filter(level %in% levels_filter) %>%
    select(breed, team) %>%
    distinct(team, .keep_all=TRUE) %>%
    mutate(total_dogs = n()) %>%
    group_by(breed) %>%
    summarize(number_of_dogs_this_breed = n(), total_dogs=total_dogs) %>%
    ungroup() %>%
    distinct(breed, .keep_all=TRUE) %>%
    mutate(
      breed_percentage = 100 * number_of_dogs_this_breed / total_dogs,
      level = levels_string,
      levels_order = levels_order) %>%
    arrange(desc(breed_percentage))
}

summit_top_data <- get_breed_percentage_at_level("Summit", "Summit", 5) %>%
  slice_max(breed_percentage, n=5) %>%
  select(breed, level, levels_order, breed_percentage)
summit_top_breeds <- summit_top_data$breed

elite_data <- get_breed_percentage_at_level("Elite", "Elite", 4) %>%
  filter(breed %in% summit_top_breeds) %>%
  select(breed, level, levels_order, breed_percentage)

nw3l3_data <- get_breed_percentage_at_level(c("NW3", "L3"), "L3-NW3", 3) %>%
  filter(breed %in% summit_top_breeds) %>%
  select(breed, level, levels_order, breed_percentage)

nw2l2_data <- get_breed_percentage_at_level(c("NW2", "L2"), "L2-NW2", 2) %>%
  filter(breed %in% summit_top_breeds) %>%
  select(breed, level, levels_order, breed_percentage)

nw1l1_data <- get_breed_percentage_at_level(c("NW1", "L1"), "L1-NW1", 1) %>%
  filter(breed %in% summit_top_breeds) %>%
  select(breed, level, levels_order, breed_percentage)

breed_percentage_data <- bind_rows(
  nw1l1_data,
  nw2l2_data,
  nw3l3_data,
  elite_data,
  summit_top_data) %>%
  mutate(
    breed_order = case_when(
      breed == "Labrador Retriever" ~ 1,
      breed == "Australian Shepherd" ~ 2,
      breed == "Golden Retriever" ~ 3,
      breed == "German Shepherd Dog" ~ 4,
      breed == "Border Collie" ~ 5,
      TRUE ~ 6
    )) %>%
  mutate(breed = str_replace_all(breed, " ", "\n"))
write_csv(breed_percentage_data, "test.csv")

plot <- ggplot(data = breed_percentage_data) +
  geom_col(
    mapping = aes(x = breed_percentage, y = fct_reorder(breed, breed_order, .desc=TRUE), fill = breed),
    color = "grey85",
    width = 0.7) +
  scale_fill_viridis(option="turbo", name="Breed", discrete=TRUE) +
  coord_cartesian(xlim=c(0,15)) +
  scale_x_continuous(
    breaks = c(0, 5, 7, 10, 15),
    labels = c("", "5% of all\ndogs that\nlevel", "7% of all\ndogs that\nlevel", "10% of all\ndogs that\nlevel",
               "15% of all\ndogs that\nlevel")) +
  annotate(geom="curve", x=7, y=5, xend=9.5, yend =4.5, curvature =0.6, arrow=arrow(angle=10), size = 0.75,
           color = "orange") +
  annotate(geom="text", x = 10, y = 4.4,
           label = "Labrador Retrievers grew in proportion from\n7% of all NW1/L1 competing dogs to\n14% of all Summit level dogs",
           hjust = "left", family = "mono", size = 7) +
  annotate(geom="segment", x=5, y=1, xend=9.5, yend = 1, arrow=arrow(angle=10), size = 0.75, color = "orange") +
  annotate(geom="text", x = 10, y = 1,
           label = "The proportion of Border Collies\nremained fairly constant between\n5% and 6% of competing dogs\nacross the levels of competition",
           hjust = "left", family = "mono", size = 7) +
  theme_minimal() +
  theme(
    text = element_text("mono"),
    legend.position = 'none',
    legend.key.height = unit(1.2, "cm"),
    axis.title = element_blank(),
    axis.text = element_text(size = 16),
    plot.title = element_text(size = 24),
    plot.subtitle = element_text(size = 22)
  ) +
  labs(
    title = "Breed Proportions at Various Competition Levels",
    subtitle = 'Competition Level: {closest_state}',
    caption = getCaption()
  ) +
  transition_states(
    fct_reorder(level, levels_order, min),
    transition_length = 2,
    state_length = 1
  ) +
  enter_fade() +
  exit_shrink() +
  ease_aes("sine-in-out")

animation <- animate(annotated_plot, width = 1920, height = 1080, bg="white")
anim_save(filename = "breed_proportions_at_levels.gif", animation = animation, path = ".")


#' Bubble plots of catch age comps
#'
#' Makes bubble plots of fishery catch age composition by fleet.
#' @param asap name of the variable that read in the asap.rdat file
#' @param fleet.names names of fleets
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param scale.catch.bubble.data larger values increase size of catch age comp bubbles (defaults to 6)
#' @param is.catch.flag true means only catch plotted, false also plots discards (defaults to TRUE)
#' @export

PlotCatchAgeCompBubbles <- function(asap,fleet.names,save.plots,od,plotf,scale.catch.bubble.data=6,
                                    is.catch.flag=T){

  par(mar=c(4,4,2,2), oma=c(1,1,1,1), mfrow=c(1,1))

  years=seq(asap$parms$styr, asap$parms$endyr)
  nyrs=asap$parms$nyears
  bubble.color <- "#11aaffaa"

  for (i in 1:asap$parms$nfleets) {
    # fix for fleet selectivity start age > 1 or end age < nages (thanks Kiersten!)
    # ages = seq(1, asap$parms$nages)
    ages=seq(asap$fleet.sel.start.age[i], asap$fleet.sel.end.age[i])
    nages=length(ages)

    acomp.obs <- as.data.frame(asap$catch.comp.mats[4*(i-1)+1])
    catch.yrs <- which(asap$fleet.catch.Neff.init[i,]>0)
    missing.catch.yrs <- which(asap$fleet.catch.Neff.init[i,] <= 0)
    acomp.obs[missing.catch.yrs,] <- rep(NA, nages)
    my.title <- "Age Comps for Catch by Fleet "
    my.save <- "obs.catch.bubble.plots."
    if (!is.catch.flag){
      acomp.obs <- as.data.frame(asap$catch.comp.mats[4*(i-1)+3])
      catch.yrs <- which(asap$fleet.discard.Neff.init[i,]>0)
      missing.catch.yrs <- which(asap$fleet.catch.Neff.init[i,] <= 0)
      acomp.obs[missing.catch.yrs,] <- rep(NA, nages)
      my.title <- "Age Comps for Discards by Fleet "
      my.save <- "obs.discard.bubble.plots."

    }
    if (length(catch.yrs)>0){

      z3 <- as.matrix(acomp.obs) * scale.catch.bubble.data

      plot(ages, rev(ages),  xlim = range(ages), ylim = c(years[nyrs],(years[1]-2)),
           xlab = "Age", ylab = "", type = "n", axes=F)
      axis(1, at= ages, lab=ages)
      axis(2, at = rev(years), lab = rev(years), cex.axis=0.75, las=1)
      box()
      abline(h=years, col="lightgray")
      segments(x0=ages, y0=rep(years[1],nages),
               x1=ages, y1=rep(years[nyrs],nages), col = "lightgray", lty = 1)

      for (j in 1:nyrs){
        points(ages, rep((years[1]+j-1), nages), cex=z3[j,], col="black",
               bg = bubble.color, pch = 21)
      }

      bubble.legend1 <- c(0.05,0.2,0.4)
      bubble.legend2 <- bubble.legend1 * scale.catch.bubble.data
      legend("topright", xpd=T, legend=bubble.legend1, pch=rep(21, 3),
             pt.cex=bubble.legend2, horiz=T , col='black', pt.bg = bubble.color  )
      title(paste0(my.title,i, " (", fleet.names[i], ")"), outer=T, line=-1 )
      if (save.plots) savePlot(paste0(od, my.save, i, ".", plotf), type=plotf)
    } # end catch.yrs test
  }   #end loop nfleets
  return()
}


library(DEsingle)

#------------------spin1 vs spin 2---------------------
#params
grp1=69
grp2=54

#files
f_in <- "./out/a06_deg_00_pp/RNAlater_spin-root_69_54.csv"
f_out <- "./out/a06_deg_01_de/RNAlater_spin-root.csv"

#1. load
counts<- read.table(f_in, sep=",", header=TRUE, row.names = 1)
group <- factor(c(rep(1,grp1), rep(2,grp2)))

#2. analysis
results <- DEsingle(counts = counts, group = group, parallel = TRUE)
results.classified <- DEtype(results = results, threshold = 0.05)

#3. write
write.csv(results.classified, f_out)

##------------------spin vs others---------------------
##params
#grp1=280
#grp2=5391

##files
#f_in <- "./out/a06_deg_00_pp/spin_others.csv"
#f_out <- "./out/a06_deg_01_de/spin_others.csv"

##1. load
#counts<- read.table(f_in, sep=",", header=TRUE, row.names = 1)
#group <- factor(c(rep(1,grp1), rep(2,grp2)))

##2. analysis
#results <- DEsingle(counts = counts, group = group, parallel = TRUE)
#results.classified <- DEtype(results = results, threshold = 0.05)

##3. write
#write.csv(results.classified, f_out)


# Ranking all potential allel-specific DHBs to identify potential regulatory MHBs
# input: identified stable maternal-specific MHBs and paternal-specific MHBs

mat_score <- read.csv("stable.maternalSpecific.DHBs.bed", header = FALSE, sep = "\t", stringsAsFactors = F)
pat_score <- read.csv("stable.paternalSpecific.DHBs.bed", header = FALSE, sep = "\t", stringsAsFactors = F)
colnames(mat_score) <- c("chrom", "start", "end", "DHB")
colnames(pat_score) <- c("chrom", "start", "end", "DHB")
mat_DHBs <- mat_score[,"DHB"]
pat_DHBs <- pat_score[,"DHB"]
rownames(mat_score) <- mat_DHBs
rownames(pat_score) <- pat_DHBs

asym_fold <- function(allele, df){
  colnames(df) <- c("chrom", "start", "end", "DHB", "oocyte", "sperm", "2cell.GG", "2cell.AG", "morula.GG", "morula.AG", "ICM.GG", "ICM.AG", "TE.GG", "TE.AG")
  rownames(df) <- df[,"DHB"]
  DHBs <- rownames(df)
  if(allele=="M"){
    df_asym <- cbind( df[DHBs,"sperm"] / df[DHBs,"oocyte"], df[DHBs,"2cell.AG"] / df[DHBs,"2cell.GG"], df[DHBs,"morula.AG"] / df[DHBs,"morula.GG"], df[DHBs,"ICM.AG"] / df[DHBs,"ICM.GG"], df[DHBs,"TE.AG"] / df[DHBs,"TE.GG"])
  }else{
    df_asym <- cbind( df[DHBs,"oocyte"] / df[DHBs,"sperm"], df[DHBs,"2cell.GG"] / df[DHBs,"2cell.AG"], df[DHBs,"morula.GG"] / df[DHBs,"morula.AG"], df[DHBs,"ICM.GG"] / df[DHBs,"ICM.AG"], df[DHBs,"TE.GG"] / df[DHBs,"TE.AG"])
  }
  df_asym <- as.matrix(df_asym)
  rownames(df_asym) <- DHBs
  return(df_asym)
}

asym_score <- function(df, cutoff){
  df[df>=cutoff] <- 1007
  df[df<cutoff] <- 1
  df[df==1007] <- 0
  vec_sum <- as.vector(rowSums(df))
  return(vec_sum)
}

# ------------
#  H3K9me3
# ------------

mat_H3K9me3 <- read.csv("H3K9me3/stable.maternalSpecific.DHB_H3K9me3.txt", header = FALSE,sep = "\t", stringsAsFactors = F)
pat_H3K9me3 <- read.csv("H3K9me3/stable.paternalSpecific.DHB_H3K9me3.txt", header = FALSE,sep = "\t", stringsAsFactors = F)

mat_H3K9me3_fold <- asym_fold("M",mat_H3K9me3)
pat_H3K9me3_fold <- asym_fold("P",pat_H3K9me3)

mat_score$asym.H3K9me3 <- asym_score(mat_H3K9me3_fold[mat_DHBs,],0.5)
pat_score$asym.H3K9me3 <- asym_score(pat_H3K9me3_fold[pat_DHBs,],0.5)

# --------------------------
#  DNA methylation density
# --------------------------

mat_methyl <- read.csv("MethylationDensity/stable.maternalSpecific.DHB_MethylationDensity.txt", header = FALSE, sep = "\t", stringsAsFactors = F)
pat_methyl <- read.csv("MethylationDensity/stable.paternalSpecific.DHB_MethylationDensity.txt", header = FALSE, sep = "\t", stringsAsFactors = F)

mat_methyl_fold <- asym_fold("M",mat_methyl)
pat_methyl_fold <- asym_fold("P",pat_methyl)

mat_score$asym.methyl <- asym_score(mat_methyl_fold[mat_DHBs,],0.5)
pat_score$asym.methyl <- asym_score(pat_methyl_fold[pat_DHBs,],0.5)

# ------------------------
#   Regulatory elements
# -----------------------

# morula DHS (including allele-specific DHS)
mat_DHS <- read.csv("RegulatoryElements/DHS/stable.maternalSpecific.DHBs.morula.AG.DHS.bed", header = FALSE, sep = "\t", stringsAsFactors = F)
pat_DHS <- read.csv("RegulatoryElements/DHS/stable.paternalSpecific.DHBs.morula.GG.DHS.bed", header = FALSE, sep = "\t", stringsAsFactors = F)

mat_DHS_as <- unique(mat_DHS[which(mat_DHS[,5]>0 & mat_DHS[,6]>0),4])
mat_DHS_bi <- unique(mat_DHS[which(mat_DHS[,5]>0 & mat_DHS[,6]==0),4])
pat_DHS_as <- unique(pat_DHS[which(pat_DHS[,5]>0 & pat_DHS[,6]>0),4])
pat_DHS_bi <- unique(pat_DHS[which(pat_DHS[,5]>0 & pat_DHS[,6]==0),4])

mat_score$DHS <- 0
mat_score[mat_DHS_as,"DHS"] <- 2
mat_score[mat_DHS_bi,"DHS"] <- 1
pat_score$DHS <- 0
pat_score[pat_DHS_as,"DHS"] <- 2
pat_score[pat_DHS_bi,"DHS"] <- 1

# CTCF
mat_CTCF <- read.csv("RegulatoryElements/CTCF.lncRNA/stable.maternalSpecific.DHBs.CTCF.bed", header = F, sep = "\t", stringsAsFactors = F)
pat_CTCF <- read.csv("RegulatoryElements/CTCF.lncRNA/stable.paternalSpecific.DHBs.CTCF.bed", header = F, sep = "\t", stringsAsFactors = F)

mat_score$CTCF <- 0
mat_score[mat_CTCF[which(mat_CTCF[,5]>0),4],"CTCF"] <- 1
pat_score$CTCF <- 0
pat_score[pat_CTCF[which(pat_CTCF[,5]>0),4],"CTCF"] <- 1

# lncRNA
mat_lncRNA <- read.csv("RegulatoryElements/CTCF.lncRNA/stable.maternalSpecific.DHBs.lncRNA.bed", header = F, sep = "\t", stringsAsFactors = F)
pat_lncRNA <- read.csv("RegulatoryElements/CTCF.lncRNA/stable.paternalSpecific.DHBs.lncRNA.bed", header = F, sep = "\t", stringsAsFactors = F)

mat_score$lncRNA <- 0
mat_score[mat_lncRNA[which(mat_lncRNA[,5]>0),4],"lncRNA"] <- 1
pat_score$lncRNA <- 0
pat_score[pat_lncRNA[which(pat_lncRNA[,5]>0),4],"lncRNA"] <- 1

# methylated ZFP57 motif
mat_ZFP57 <- read.csv("RegulatoryElements/Methylated.ZFP57/stable.maternalSpecific.DHBs.ZFP57.morula.GG.methyl.bed", header = F, sep = "\t", stringsAsFactors = F)
pat_ZFP57 <- read.csv("RegulatoryElements/Methylated.ZFP57/stable.paternalSpecific.DHBs.ZFP57.morula.AG.methyl.bed", header = F, sep = "\t", stringsAsFactors = F)

mat_ZFP57_methylated <- unique(mat_ZFP57[which(mat_ZFP57[,5]>0.5),4])
pat_ZFP57_methylated <- unique(pat_ZFP57[which(pat_ZFP57[,5]>0.5),4])

mat_score$methylated.ZFP57 <- 0
mat_score[mat_ZFP57_methylated,"methylated.ZFP57"] <- 1
pat_score$methylated.ZFP57 <- 0
pat_score[pat_ZFP57_methylated,"methylated.ZFP57"] <- 1

# -------------
#  Expression
# -------------

# allele-specific gene expression in pre-implantation embryos (FC=2, stage = 2)
mat_expression <- read.csv("Expression/allelic.specific.2fold.2stage/stable.maternalSpecific.DHBs.350k.ASGene.bed", header = F,sep = "\t", stringsAsFactors = F)
pat_expression <- read.csv("Expression/allelic.specific.2fold.2stage/stable.paternalSpecific.DHBs.350k.ASGene.bed", header = F,sep = "\t", stringsAsFactors = F)
mat_score$asym.expression <- 0
mat_score[mat_expression[which(mat_expression[,5]==1),4],"asym.expression"] <- 1
pat_score$asym.expression <- 0
pat_score[pat_expression[which(pat_expression[,5]==1),4],"asym.expression"] <- 1

# allele-specific gene expression in pre-implantation embryos (FC=2, stage = 1)
# mat_expression <- read.csv("Expression/allelic.specific.2fold.1stage/stable.maternalSpecific.DHBs.350k.ASGene.bed", header = F,sep = "\t", stringsAsFactors = F)
# pat_expression <- read.csv("Expression/allelic.specific.2fold.1stage/stable.paternalSpecific.DHBs.350k.ASGene.bed", header = F,sep = "\t", stringsAsFactors = F)
# mat_score$asym.expression <- 0
# mat_score[mat_expression[which(mat_expression[,5]==1),4],"asym.expression"] <- 1
# pat_score$asym.expression <- 0
# pat_score[pat_expression[which(pat_expression[,5]==1),4],"asym.expression"] <- 1

# known imprinting genes
mat_KnownIG <- read.csv("Expression/Known.IG/stable.maternalSpecific.DHBs.350k.Known.IG.bed", header = F, sep = "\t", stringsAsFactors = F)
pat_KnownIG <- read.csv("Expression/Known.IG/stable.paternalSpecific.DHBs.350k.Known.IG.bed", header = F, sep = "\t", stringsAsFactors = F)
mat_score[mat_expression[which(mat_KnownIG[,5]==1),4],"asym.expression"] <- 1
pat_score[pat_expression[which(pat_KnownIG[,5]==1),4],"asym.expression"] <- 1

# ----------
#  ranking
# ---------

mat_score$asym.modification <- (mat_score$asym.H3K9me3 / 5 + mat_score$asym.methyl / 5) / 2
mat_score$regulatory.elements <- (mat_score$DHS + mat_score$CTCF + mat_score$lncRNA + mat_score$methylated.ZFP57) / 5
mat_score$score <- mat_score$asym.modification + mat_score$regulatory.elements + mat_score$asym.expression
# mat_score$score <- mat_score$asym.modification + mat_score$regulatory.elements

pat_score$asym.modification <- (pat_score$asym.H3K9me3 / 5 + pat_score$asym.methyl / 5) / 2
pat_score$regulatory.elements <- (pat_score$DHS + pat_score$CTCF + pat_score$lncRNA + pat_score$methylated.ZFP57) / 5
pat_score$score <- pat_score$asym.modification + pat_score$regulatory.elements + pat_score$asym.expression
# pat_score$score <- pat_score$asym.modification + pat_score$regulatory.elements

mat_score <- mat_score[order(mat_score$score,decreasing = TRUE),]
pat_score <- pat_score[order(pat_score$score,decreasing = TRUE),]

write.table(mat_score, 'stable.maternalSpecific.DHB.score.txt', row.names = F, col.names = T, sep = "\t", quote = F)
write.table(pat_score, 'stable.paternalSpecific.DHB.score.txt', row.names = F, col.names = T, sep = "\t", quote = F)

merge_score <- rbind(mat_score, pat_score)
merge_score <- merge_score[order(merge_score$score,decreasing = TRUE),]
write.table(merge_score, 'stable.alleleSpecific.DHB.score.txt', row.names = F, col.names = T, sep = "\t", quote = F)


#   qcmi.test.r
#   version 2021.12.24

rm(list=ls())

#   计算消耗时间
#   to calculate time cost
t0=Sys.time()

#   加载相关R包
#   load R packages and data
library("phyloseq")
library("ggClusterNet")
library("tidyverse")
library("WGCNA")
library("igraph")
library("Matrix")
library("vegan")
library("qcmi")

#   设置工作路径
#   the folder saving the input files
wd="D:\\YANJIUSHENG\\method\\qcmi\\test"
save.wd="D:\\YANJIUSHENG\\method\\qcmi\\test\\result"

# 1 # 整理涉及到的数据，计算微生物共存网络
# 1 # Collate the data involved and calculate the microbial correlation network
#   导入数据
#   load  data
setwd(wd)
otu=read.table("otu_table.txt",header=TRUE, row.names=1)
tax=read.table("tax.txt",header=TRUE, row.names=1)
env=read.table("env.txt",header=TRUE, row.names=1)
geo=read.table("geo.txt",header=TRUE, row.names=1)

if(!dir.exists(save.wd)){dir.create(save.wd)}
setwd(save.wd)

#   数据格式转化为phyloseq
#   The data format is transformed into the phyloseq
ps= trans_ps(otu_table = otu, taxa_table =  tax)

#   按照频率和丰度过滤数据集
#   Filter the data  by occurrence and abundance
filteredps= filter_ps(ps= ps, occurrence.threshold=60 ,  abundance.threshold= 99)

#   通过WGCNA包计算相关性网络
#   The correlation network is calculated using the WGCNA package
result_net= cal_network(ps = filteredps, N = 100,r.threshold=0.6, p.threshold=0.05,method ="spearman") #    通常N设置为0，为计算速度在此设置前100个otu进行计算

#   将igraph格式结果文件赋值
#   Assign the igraph format result file
ig.wgcna=result_net$igraph

#   查看网络点和边的数量
#   Check the number of network nodes and edges
length(V(ig.wgcna))#number of nodes
length(E(ig.wgcna))#number of edges

#   保存edgelist格式文件
#   Save the edgelist file
write.graph(ig.wgcna,file="edgelist.csv",format="ncol")

#   导入edgelist格式文件三联表
#   re-import the edgelist as triad table
edgelist=read.csv("edgelist.csv",header = FALSE,sep=' ')

#   得到过滤后的OTU表
#   Get filtered OTU table
ps_sub = filter_OTU_ps(ps = filteredps,Top = 100)
otu_table = as.data.frame(t(vegan_otu(ps_sub)))

#   扩散限制
#   classifies ecological associations of dispersal limitation
result_dl= assigned_process(link_table_row=edgelist, OTUabd=otu_table, p=0.05 , data= geo,cutoff=0, method="dl")

#   检测环境变量冗余
#   Detect redundancy of environment variables
library(Hmisc)
plot(varclus(as.matrix(env) ))

#   去除 rho>0.5 的变量
#   Remove variables with rho>0.5
env=env[,-3]
env=env[,-5]
plot(varclus(as.matrix(env) ))

#   环境过滤
#   classifies ecological associations of environmental filtering
result_ef= assigned_process(link_table_row=edgelist, OTUabd=otu_table, p=0.05 , data= env,cutoff=0, method="ef")

#   手动分类edge归属并导入得到新的网络
#   Manually classify edge ownership and import the new network
filteredlist <- read.csv("filteredlist.csv")
filteredlist=filteredlist[which( filteredlist[,4]=='bi'),]

#   转化为igraph格式并赋值weight
#   Convert to igraph format and assign weight
ig=graph_from_edgelist(as.matrix(filteredlist[,1:2]) , directed = FALSE)
ig=set_edge_attr(ig, 'weight', index = E(ig),  as.numeric(filteredlist[,3]) )

#   定量生物互作强度
#   Quantify the local intensity of microbial biotic interaction
result_bi= qcmi(igraph= ig, OTU= otu_table, pers.cutoff=0)

data=cbind(env,result_bi[[3]],result_bi[[4]])

#   检测生物互作与非生物环境因子对微生物多样性分布格局的影响，包括alpha多样性和beta多样性
#   The effects of biotic interactions and abiotic factors on microbial diversity patterns, including alpha diversity and beta diversity, were examined
#alpha
library(MASS)
library(adespatial)
library(lmerTest)
#data=scale(data,center=T,scale=T)
data=as.matrix(data)
res_forward.sel=cal_alphacon(data,"forward.sel",ps)
res_olslm=cal_alphacon(data,"olslm",ps)

#beta
library(vegan)
data=cbind(env,result_bi[[3]],result_bi[[4]])
otu_abund=as.data.frame(t(vegan_otu(ps)))
res_mantel= cal_betacon(data,otu_abund,"spearman")

#   计算所用时间
#   Calculate total time
(t=format(Sys.time()-t0))


if(!require(devtools)) install.packages("devtools")
devtools::install_github("kassambara/ggpubr")
devtools::install_github("hadley/ggplot2")
devtools::install_github("hadley/dplyr")
devtools::install_github("hadley/tidyr")
devtools::install_github("tidyverse/glue")
devtools::install_github("tidyverse/readxl")

library(tableone)
library(readxl)
library(dplyr)
library(ggplot2)
library(ggpubr)
library(tidyr)
library(glue)
library(rstatix)
library(lemon)

## ============================== General settings and loading data ==============================
# Define a theme to be used in figures
my.theme 		<- theme_light()
my.theme 		<- my.theme + theme(panel.border=element_blank(),
axis.line 		<- element_line(),
axis.ticks 		<- element_line(colour='black'),
axis.title.y 	<- element_text(margin = margin(t = 0, r = 20, b = 0, l = 0)),
text 			<- element_text(size=20, family="serif"))

# Load data in a wide format and convert to something that may be used for estimations of ANOVA and for plotting purposes
wdir 				<- getwd()
df 					<- read_excel(paste(wdir, "data-guideXT.xlsx", sep=""), sheet = "table_all")
df 					<- df %>% drop_na(updrs_GXT)
df 					<- as.data.frame(df)
df 					<- df[df$include==1,]
df_wide 			<- df %>% select(pseud, updrs_off, updrs_GXT, updrs_MT) %>% gather(condition, UPDRS_score, updrs_off, updrs_GXT, updrs_MT)
df_wide$pseud 		<- as.factor(df_wide$pseud)
df_wide$condition 	<- as.factor(df_wide$condition)
df$gender 			<- recode(as.factor(df$gender), "1" = "female", "2" = "male", .default = NA_character_)

# Create stats, which are necessary for plotting later
df.summary <- df_wide %>% group_by(condition) %>% summarise(sd = sd(UPDRS_score), updrs_mn = mean(UPDRS_score))
df.summary

## ============================== Demographics ==============================
listVars<- c("age", "gender", "ledd", "disease_duration")
catVars <- c("gender") # categorial variables
table1 	<- CreateTableOne(vars = listVars, data = df, factorVars = catVars)
print(table1, showAllLevels = TRUE)

## ============================== Visualisation for UPDRS changes ==============================
p1 <- ggplot(df_wide, aes(x=condition, y=UPDRS_score)) +
geom_jitter(position = position_jitter(width=0.1, height=0),
color = "darkgray") +
scale_x_discrete(labels= c("GuideXT", "Clinical \ntesting", "DBS-OFF")) +
geom_line(aes(x=condition, y=updrs_mn, group = 1), data = df.summary, linetype="twodash", size=1) +
geom_errorbar(
aes(x=condition, y=updrs_mn, ymin = updrs_mn-sd, ymax = updrs_mn+sd),
data = df.summary, width = 0.1,  size=1) +
geom_point(aes(x=condition, y=updrs_mn), data = df.summary, size=2) +
# coord_capped_cart(left='none', bottom=brackets_horizontal(direction='up')) +
ylim(0, 75) + labs(y = "Score at Unified Parkinson's Disease \nRating Scale (UPDRS)", x = "")
my.theme

# Statistics on changes of UPDRS due to DBS settings (conditions)
df_wide %>% group_by(condition) %>% identify_outliers(UPDRS_score) # Outliers
df_wide %>% group_by(condition) %>% shapiro_test(UPDRS_score) # Normality
ggqqplot(df_wide, "UPDRS_score", facet.by = "condition")
res.aov <- anova_test(data = df_wide, dv = UPDRS_score, wid = pseud, within = condition)
get_anova_table(res.aov)

# pairwise comparisons
pwc <- df_wide %>% pairwise_t_test(
UPDRS_score ~ condition, paired = TRUE,
p.adjust.method = "bonferroni")
pwc

# Add statistics on visualisation
pwc <- pwc %>% add_xy_position(x = "condition")
p1 +
stat_pvalue_manual(pwc, tip.length = 0.005, y.position= c(60, 65, 70),
family="serif", bracket.size=.5) +
labs(subtitle = get_test_label(res.aov, detailed = TRUE), caption = get_pwc_label(pwc)
)


#!/usr/bin/env R

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

library(data.table)
library(geojsonio)
library(rgdal)
library(jsonlite)

rm(list=ls())

# ILLINOIS CENSUS TRACTS
ftract <- "./data/chicago_tracts_clipped.geojson"
censusTracts <- readOGR(ftract, "OGRGeoJSON", stringsAsFactors = FALSE)

# RISK SCORE DATA
friskscore <- "./data/fire_model_data_output.csv"
riskScore <- fread(friskscore)
riskScore$fire_score_bin_orig <- riskScore$fire_score_bin
fireScoreBins <- c(.0125, .0250, .0375, .0500)
riskScore[, fire_score_bin := dplyr::case_when(
  riskScore$fire_score < fireScoreBins[1] ~ 0
  , riskScore$fire_score < fireScoreBins[2] ~ 1
  , riskScore$fire_score < fireScoreBins[3] ~ 2
  , riskScore$fire_score < fireScoreBins[4] ~ 3
  , TRUE ~ 4
)]

riskScore[, TRACTA := as.character(TRACTA)]
riskScore[nchar(TRACTA) == 5, TRACTA := paste0("0", TRACTA)]

# Tracts in the risk score file but not the census file
setdiff(riskScore$TRACTA, censusTracts@data$tractce10)
# Tracts in the census file but not the risk score file
setdiff(censusTracts@data$tractce10, riskScore$TRACTA)

# MERGE
censusTracts@data <- data.frame(
  censusTracts@data,
  riskScore[match(censusTracts@data$tractce10, riskScore$TRACTA)
            , c("TRACTA", "NAME_E", "prediction", "fire_score"
                , "fire_score_bin", "fire_score_bin_orig")]
  )

# RED CROSS RESPONSES
fRedCrossResponses <- "./data/red_cross_responses_tract.csv"
redCrossResponses <- fread(fRedCrossResponses)
redCrossResponses <- redCrossResponses[, c("CensusTract", "responses_per_tract")]

summary(redCrossResponses$responses_per_tract)

table(nchar(redCrossResponses$CensusTract))
ct <- redCrossResponses$CensusTract
ct <- as.character(ct)
hasdec <- stringi::stri_detect_fixed(ct, ".")
ct[!hasdec] <- paste0(ct[!hasdec], "00")
table(nchar(ct[hasdec]))
table(nchar(ct[!hasdec]))
ct[hasdec & nchar(ct)==6] <- paste0("0", ct[hasdec & nchar(ct)==6])
ct[!hasdec & nchar(ct)==5] <- paste0("0", ct[!hasdec & nchar(ct)==5])
ct <- stringi::stri_replace_all_fixed(ct, ".", "")
table(nchar(ct))
redCrossResponses$new_tract <- as.character(ct)

setdiff(redCrossResponses$new_tract, tract_fire@data$tractce10)
setdiff(tract_fire@data$tractce10, redCrossResponses$new_tract)

tract_fire@data <- data.frame(
  tract_fire@data,
  redCrossResponses[match(tract_fire@data$tractce10, redCrossResponses$new_tract), ]
)
summary(tract_fire@data$responses_per_tract)

geojsonio::geojson_write(
  tract_fire,
  file = "./data/tract_fire_scores_responses.geojson")


WISP.getPureCentro = function(data,cl,pureSamples_filtering = TRUE, nb_markers_selection = c("custom", "optim_kappa")[1],   nb_markers_max_perClass = 50, markers_cutoff_pval_anovatest = 0.05, markers_pval_anovatest_fdr = TRUE, markers_cutoff_auc = 0.8, pureSamples_deltaTopWeights = 0.5, plot_heatmap = TRUE, add_markers = NULL, col_purePop = NULL, sum_LessThanOne = TRUE){

    datatot = data
    if(is.null(names(cl))){
        names(cl) = colnames(data)
        warning("The vector cl of the classes does not contain names, WISP assumes that the samples are in the same order as in the data.")
    } else if(all(names(cl) == colnames(data)) == "FALSE"){
        stop("The names in the vector cl of the classes do not match the sample names in the data.")
    }
    cltot = cl
    totsample = colnames(data)
    ind2keep = 0
    if(pureSamples_filtering == TRUE){
        resW = data.frame(1:ncol(data))
        while(length(ind2keep) != nrow(resW)){
            print("Retrieving markers")
            resTest = testmarkers(data,cl,markers_cutoff_pval_anovatest, markers_pval_anovatest_fdr)
            print("Centroid calculation")
            centrores = centroestim(data, cl, resTest = resTest, nb_markers_selection=nb_markers_selection, nb_markers_max_perClass = nb_markers_max_perClass, markers_cutoff_auc = markers_cutoff_auc, add_markers = add_markers,markers_cutoff_pval_anovatest = 0.05, markers_pval_anovatest_fdr = TRUE)
            genescentro = centrores$centroid
            if(length(setdiff(levels(as.factor(cl)), levels(as.factor(centrores$cl)))>0)){
                popweak =  setdiff(levels(as.factor(cl)), levels(as.factor(centrores$cl)))
                print(paste("Population", popweak, "has no specific markers and has been removed.", sep=" "))
                warning(paste("Population", popweak, "has no specific markers and has been removed.", sep=" "))
            }
            cl = centrores$cl
            data = centrores$data
            print("Weight estimation")
            resW = WISP.getWeight(as.matrix(data[rownames(genescentro),]), as.matrix(genescentro), sum_LessThanOne)
            names(cl) = colnames(data)
            resW$labelhisto = as.factor(cl[rownames(resW)])
            resW=resW[resW$WARNING == "OK",]
            ind2keep = rownames(resW)[which(resW[,"topWeightedClass"] == resW[,"labelhisto"] & abs(resW$deltaTopWeights)> pureSamples_deltaTopWeights)]
            if(length(setdiff(colnames(data), ind2keep)) == 0){
                print(paste("No sample was removed" ,setdiff(colnames(data), ind2keep)))
            } else if(length(setdiff(colnames(data), ind2keep)) == 1){
                print(paste(length(setdiff(colnames(data), ind2keep)), "sample was removed:" ,setdiff(colnames(data), ind2keep)))
            } else {
                print(paste(paste(length(setdiff(colnames(data), ind2keep)), "samples were removed:", collapse=" "), paste(setdiff(colnames(data), ind2keep), collapse=" "), collapse=" "))

            }
            data = data[,ind2keep]
            cl = cl[ind2keep]
        }
        print(paste("Final Centroid calculation (on ", paste(ncol(data), sep=" "), " samples)", sep=""))
        resTest = testmarkers(data,cl)
        genescentroRes = centroestim(data, cl, resTest = resTest, nb_markers_selection=nb_markers_selection, nb_markers_max_perClass = nb_markers_max_perClass, markers_cutoff_auc = markers_cutoff_auc, add_markers = add_markers)
        genescentro = genescentroRes$centroid
    } else {
        resTest = testmarkers(datatot,cltot,markers_cutoff_pval_anovatest, markers_pval_anovatest_fdr)
        genescentroRes = centroestim(data=datatot, cl=cltot, resTest = resTest, nb_markers_selection=nb_markers_selection, nb_markers_max_perClass = nb_markers_max_perClass, markers_cutoff_auc = markers_cutoff_auc, add_markers = add_markers,markers_cutoff_pval_anovatest = 0.05, markers_pval_anovatest_fdr = TRUE)
        genescentro = genescentroRes$centroid
        ind2keep = colnames(datatot)
    }
    indremoved = setdiff(colnames(datatot),ind2keep)

    if(plot_heatmap == TRUE){
        data.before = datatot[rownames(genescentro), ]
        data.before = data.before-rowMeans(data.before)

        data.after = data[rownames(genescentro), ]
        data.after = data.after-rowMeans(data.after)
        cl = cl[colnames(data.after)]

        nbclasses = nlevels(as.factor(cltot))

        if(is.null(col_purePop)){
            BaseColors <- stats::setNames(grDevices::rainbow(nbclasses), levels(as.factor(cltot)))

        } else {
            BaseColors = col_purePop
        }

        SelectionColors.after = BaseColors[levels(as.factor(as.character(cl)))]

        annot1 = data.frame(Classes = sort(cl))
        ha1 = HeatmapAnnotation(df = annot1,
        col = list("Classes" = SelectionColors.after))
        ht1 = ComplexHeatmap::Heatmap(data.after[,names(sort(cl))], circlize::colorRamp2(c(-2, 0, 2), c("blue", "white", "red")), cluster_columns = FALSE,show_column_names = T, cluster_rows = FALSE,row_names_side="left",column_names_side="top", name = "Expression",top_annotation = ha1, row_names_gp = grid::gpar(fontsize = 6),column_names_gp = grid::gpar(fontsize = 7), column_title = "Samples kept")

        genesclassList = genescentroRes$marksList
        genesclass = unlist(genesclassList)
        names(genesclass) = rep(names(genesclassList), lapply(genesclassList, length))
        if(sum(duplicated(genesclass))>0){
            genesdup = genesclass[ which(duplicated(genesclass))]
            genesclassuniq = genesclass[-which(duplicated(genesclass))]
            names(genesclassuniq)[which(genesclassuniq %in% genesdup)]="notspecific"
            genesclass=genesclassuniq
        }
        annotgenes = data.frame("Classes_marker" = names(genesclass)[match(rownames(data.before),genesclass)])
        hr = rowAnnotation(df = annotgenes, col = list("Classes_marker" = c(SelectionColors.after,"notspecific"="grey")),width = unit(1, "cm"))

        if(length(indremoved)!=0){
            if(length(indremoved)==1){
                data.removed = data.frame(data.before[,indremoved])
                rownames(data.removed) = rownames(data.before)
                colnames(data.removed) =indremoved
                cl.removed = cltot[indremoved]
                SelectionColors.removed = BaseColors[levels(as.factor(as.character(cl.removed)))]
                annot2 = data.frame(Classes = cl.removed)
                ha2 = HeatmapAnnotation(df = annot2,
                col = list("Classes" =  SelectionColors.removed))
                ht2 = ComplexHeatmap::Heatmap(data.removed, circlize::colorRamp2(c(-2, 0, 2), c("blue", "white", "red")), cluster_columns = FALSE,show_row_names = FALSE,show_column_names = T, cluster_rows = FALSE,column_names_side="top",top_annotation = ha2, column_names_gp = grid::gpar(fontsize = 7), show_heatmap_legend = FALSE,column_title = "Samples removed")
            } else {
                data.removed = data.before[,indremoved]
                cl.removed = cltot[indremoved]
                SelectionColors.removed = BaseColors[levels(as.factor(as.character(cl.removed)))]
                annot2 = data.frame(Classes = sort(cl.removed))
                ha2 = HeatmapAnnotation(df = annot2,
                col = list("Classes" =  SelectionColors.removed))
                ht2 = ComplexHeatmap::Heatmap(data.removed[,names(sort(cl.removed))], circlize::colorRamp2(c(-2, 0, 2), c("blue", "white", "red")), cluster_columns = FALSE,show_row_names = FALSE,show_column_names = T, cluster_rows = FALSE,column_names_side="top",top_annotation = ha2, column_names_gp = grid::gpar(fontsize = 7), show_heatmap_legend = FALSE,column_title = "Samples removed")
            }
            ComplexHeatmap::draw(hr+ht1+ht2,gap = unit(1.5, "cm"))
            names(indremoved) = cltot[indremoved]

        } else {
            ComplexHeatmap::draw(hr+ht1)

        }
    }

    names(ind2keep) = cltot[ind2keep]
    if(nb_markers_selection == "optim_kappa"){
        message("Creation of the file \'table_with_allConditionNumber.txt\'")
    }
    return(list("genescentro"  = genescentro, "indkept"=ind2keep, "indremoved"=indremoved, "genesclasses" = genescentroRes$marksList))

}


Use.OP.stock.dist<-T

la<-SMS.control@max.age.all
fa<-SMS.control@first.age
years<-c(1,1)
years[1]<-SMS.control@first.year
years[2]<-SMS.control@last.year
ny<-years[2]-years[1]+1
if (Use.OP.stock.dist) {
  years[1]<-0
  years[2]<-0
  ny<-1
}
npr<-sum(SMS.control@species.info[,'predator']>=1)
nsp<-SMS.control@no.species
nq<-SMS.control@last.season
noAreas<-SMS.control@no.areas
area.names<-Read.area.names()

nox<-3;
noy<-3;

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

noxy<-nox*noy
if (Use.OP.stock.dist) {
  l<-scan(file.path(data.path,'OP_Stock_distribution.in'),comment.char='#')
  b<-expand.grid(quarter=1:nq,area=1:noAreas,species.n=1:nsp,year=years[1]:years[2],age=fa:la)
}
if (!Use.OP.stock.dist) {
  l<-scan(file.path(data.path,'Stock_distribution.in'),comment.char='#')
}
b<-expand.grid(area=1:noAreas,species.n=1:nsp,year=years[1]:years[2],quarter=1:nq,age=fa:la)
b$species<-sp.names[b$species.n]

if (Use.OP.stock.dist) b<-b[order(b$quarter,b$area,b$species.n,b$year,b$age),] else b<-b[order(b$area,b$species.n,b$year,b$quarter,b$age),]

b<-data.frame(b,dist=l)
b<-subset(b,select=c(year,species,species.n,age,quarter,area,dist))

b$maxAge<-SMS.control@species.info[b$species.n,'last-age']
b<-subset(b,(age<=maxAge) & (quarter<SMS.control@rec.season & age<=(noxy-1)) | (quarter>=SMS.control@rec.season & age<=(noxy-2)))
b<-droplevels(subset(b,!(age==fa & quarter<SMS.control@rec.season)))
head(b)

#ftable(tapply(b$dist,list(b$species,b$quarter,b$age,b$year,b$area),sum))

palette(rainbow(noAreas))
cleanup()

if (!Use.OP.stock.dist) by(b,list(b$species.n,b$quarter),function(x){
  by(x,list(x$species.n,x$quarter),function(x){
    newplot(dev='screen',nox=nox,noy=noy)
    par(mar=c(3,3,3,1)) # c(bottom, left, top, right)
    plot.new();
    legend(x=0,y=1,rev(area.names),fill=rev(2:(noAreas+1)),cex=1.5,col=rev(2:(noAreas+1)),ncol=1,title=paste(x[1,'species'],"Q:",x[1,'quarter']))

    by(x,list(x$age),function(x){
      a<-tapply(x$dist,list(x$area,x$year),sum)
      barplot(a,main=paste('Age',x[1,'age']),col=2:(noAreas+1))
    })
  })
})

#ftable(tapply(x$dist,list(x$age,x$area,x$quarter),sum))
b<-droplevels(subset(b,age<=noxy-2))
if (Use.OP.stock.dist) by(b,list(b$species.n),function(x){
    x$quarter<-paste("Q",x$quarter,sep='')
    newplot(dev='screen',nox=nox,noy=noy)
    par(mar=c(3,3,3,1)) # c(bottom, left, top, right)
    plot.new();
    legend(x=0,y=1,rev(area.names),fill=rev(2:(noAreas+1)),cex=1.5,col=rev(2:(noAreas+1)),ncol=1,title=paste(x[1,'species']))

    by(x,list(x$age),function(x){
      a<-tapply(x$dist,list(x$area,x$quarter),sum)
      barplot(a,main=paste('Age',x[1,'age']),col=2:(noAreas+1))
    })
})