#!/usr/bin/env Rscript

################################################
################################################
## REQUIREMENTS                               ##
################################################
################################################

## DIFFERENTIAL ANALYSIS, SCATTERPLOTS, HEATMAP AND PCA FROM COUNT FILE
    ## - COUNT FILE IS PRODUCED FROM SEACR PEAK BED FILES AND ALIGNMENT BAMS
    ## - PACKAGES BELOW NEED TO BE AVAILABLE TO LOAD WHEN RUNNING R

################################################
################################################
## LOAD LIBRARIES                             ##
################################################
################################################

library(optparse)
library(stringr)
library(BiocParallel)
library(magrittr)
library(GenomicRanges)
library(chromVAR)
library(DESeq2)
library(ggplot2)
library(RColorBrewer)
library(pheatmap)
library(lattice)

################################################
################################################
## PARSE COMMAND-LINE PARAMETERS              ##
################################################
################################################

option_list <- list(
    make_option(c("-g", "--groups"), type="character", default=NULL    , metavar="string"   , help="comma-separated list of experimental group names" ),
    make_option(c("-b", "--bed"    ), type="character", default=NULL    , metavar="path"   , help="TODO" ),
    make_option(c("-a", "--bam"    ), type="character", default=NULL    , metavar="path"   , help="TODO"  ),
    make_option(c("-i", "--include"), type="character", default=NULL    , metavar="string"   , help="experimental groups to include in analysis"),
    make_option(c("-e", "--exclude"), type="character", default=NULL    , metavar="string"   , help="experimental groups to exclude in analysis"),
    make_option(c("-o", "--outdir"        ), type="character", default='./'    , metavar="path"   , help="Output directory."  ),
    make_option(c("-p", "--outprefix"     ), type="character", default='deseq2', metavar="string" , help="Output prefix."     ),
    make_option(c("-s", "--count_thresh"     ), type="integer", default='5', metavar="string" , help="TODO"     ),
    make_option(c("-v", "--vst"           ), type="logical"  , default=FALSE   , metavar="boolean", help="Run vst transform instead of rlog." ),
    make_option(c("-@", "--cores"         ), type="integer"  , default=1       , metavar="integer", help="Number of cores."   )
)

#make_option(c("-c", "--control"    ), type="character", default=NULL    , metavar="path"   , help="TODO" ),
#make_option(c("-t", "--treatment"    ), type="character", default=NULL    , metavar="path"   , help="TODO" ),
opt_parser <- OptionParser(option_list=option_list)
opt        <- parse_args(opt_parser)

if (is.null(opt$groups)){
    print_help(opt_parser)
    stop("Please provide group names for analysis.", call.=FALSE)
}

#if (is.null(opt$control)){
#    print_help(opt_parser)
#    stop("Please provide a control group name.", call.=FALSE)
#}
#
#if (is.null(opt$treatment)){
#    print_help(opt_parser)
#    stop("Please provide a treatment group name.", call.=FALSE)
#}

if (is.null(opt$bed)){
    print_help(opt_parser)
    stop("Please provide a list of bed files to load.", call.=FALSE)
}

if (is.null(opt$bam)){
    print_help(opt_parser)
    stop("Please provide a list of bam files to load", call.=FALSE)
}

# Get file lists
bed_list <- unlist(strsplit(opt$bed, ","))
bam_list <- unlist(strsplit(opt$bam, ","))

# Check same length <- MAYBE TAKE THIS OUT IF WE SIMPLY PASS THE ALIGNMENT CHANNEL AS IT WILL CONTAIN IGG
#if (length(bed_list) != length(bam_list)) {
#    print_help(opt_parser)
#    stop("Bed and bam file list are different lengths", call.=FALSE)
#}

################################################
################################################
## READ IN DATA FILES                         ##
################################################
################################################

# Create group list
# groups = c(opt$control, opt$treatment) <- groups is now just opt$group
groups = unlist(strsplit(opt$groups, split=","))
if (!is.null(opt$include)) {
    groups = unlist(strsplit(opt$include, split=","))
}
if (!is.null(opt$exclude)) {
    exclude_vec = unlist(strsplit(opt$exclude, split=","))
    matching = match(groups, exclude_vec)
    groups = groups[!matching]
}

# Init
mPeak = GRanges()
file_count = 0
file_list=vector()
# Read in bed files that match the control or treatment group
for(group in groups){
    search_res <-  str_detect(bed_list, group)
    if (!any(search_res)) {
        stop(paste("group", group, "was not found amongst bed files"))
    }
    file_list <- bed_list[search_res] %>% append(file_list, .)
}
for(file in file_list) {
    peakRes = read.table(file, header = FALSE, fill = TRUE)
    mPeak = GRanges(seqnames = peakRes$V1, IRanges(start = peakRes$V2, end = peakRes$V3), strand = "*") %>% append(mPeak, .)
    file_count = file_count + 1
}

# Create replicate counts and names
group_count = length(groups)
rep_count = file_count / group_count
reps = paste0("rep", 1:rep_count)
expected_rep_str = paste0("_R", 1:rep_count)

# Create peak table and count matrix
masterPeak = reduce(mPeak)
countMat = matrix(NA, length(masterPeak), file_count)
colnames(countMat) = paste(rep(groups, rep_count), rep(reps, each = group_count, sep = "_"))

# Read in bam files that match the control or treatment group
for(i in seq_along(groups)){
    search_res <-  str_detect(bam_list, groups[i])
    if (!any(search_res)) {
        stop(paste("group", i, "was not found amongst bam files"))
    }
    file_list <- bam_list[search_res]

    for(j in seq_along(file_list)) {
        rep_search <- str_detect(file_list, expected_rep_str[j])
        file_now <- file_list[rep_search]
        fragment_counts <- getCounts(file_now, masterPeak, paired = TRUE, by_rg = FALSE, format = "bam")
        countMat[, ((j*group_count) - (group_count - i))] = counts(fragment_counts)[,1]
    }
}

################################################
################################################
## RUN DESEQ2                                 ##
################################################
################################################

if (file.exists(opt$outdir) == FALSE) {
    dir.create(opt$outdir,recursive=TRUE)
}
setwd(opt$outdir)
#if (FALSE) {
## Create index list for peak count filter
selectR = which(rowSums(countMat) > opt$count_thresh)
dataS = countMat[selectR,] ## Select data from filter
condition = factor(rep(groups, each = length(reps)))

samples.vec <- sort(colnames(countMat))
#groups      <- sub("_[^_]+$", "", samples.vec)
if (length(unique(groups)) == 1 || length(unique(groups)) == length(samples.vec)) {
    quit(save = "no", status = 0, runLast = FALSE)
}

DDSFile <- paste(opt$outprefix,".dds.RData",sep="")
if (file.exists(DDSFile) == FALSE) {
    dds = DESeqDataSetFromMatrix(countData = dataS,colData = DataFrame(condition),design = ~ condition)
    dds     <- DESeq(dds, parallel=TRUE, BPPARAM=MulticoreParam(opt$cores))
    if (!opt$vst) {
        vst_name <- "rlog"
        rld      <- rlog(dds)
    } else {
        vst_name <- "vst"
        rld      <- varianceStabilizingTransformation(dds)
    }
    assay(dds, vst_name) <- assay(rld)
    save(dds,file=DDSFile)
} else {
    load(DDSFile)
    vst_name <- intersect(assayNames(dds), c("vst", "rlog"))
    if (length(vst_name)==0) { # legacy might mean vst was saved as a separate object called rld
        vst_name <- "loaded_rld"
        assay(dds, vst_name) <- assay(rld)
    } else {
        vst_name==vst_name[1]
    }
}

## Normalised results
DDS = DESeq(dds)
normDDS = counts(DDS, normalized = TRUE) ## normalization with respect to the sequencing depth
colnames(normDDS) = paste0(colnames(normDDS), "_norm")
res = results(DDS, independentFiltering = FALSE, altHypothesis = "greaterAbs")
countMatDiff = cbind(dataS, normDDS, res) ## Combine deseq results
write.csv(countMatDiff, paste(opt$outprefix, "count_mat_diff.csv", sep=""), row.names=FALSE)

################################################
################################################
## NEW PLOT QC                                ##
################################################
################################################
if (FALSE) {
PlotFile <- paste(opt$outprefix,".plots.pdf",sep="")
if (file.exists(PlotFile) == FALSE) {
    pdf(file=PlotFile,onefile=TRUE,width=7,height=7)

    ## PCA
    pca.data <- DESeq2::plotPCA(rld,intgroup=c("condition"),returnData=TRUE)
    percentVar <- round(100 * attr(pca.data, "percentVar"))
    plot <- ggplot(pca.data, aes(PC1, PC2, color=condition)) +
        geom_point(size=3) +
        xlab(paste0("PC1: ",percentVar[1],"% variance")) +
        ylab(paste0("PC2: ",percentVar[2],"% variance")) +
        theme(panel.grid.major = element_blank(),
                panel.grid.minor = element_blank(),
                panel.background = element_blank(),
                panel.border = element_rect(colour = "black", fill=NA, size=1))
    print(plot)

    ## WRITE PC1 vs PC2 VALUES TO FILE
    pca.vals <- pca.data[,1:2]
    colnames(pca.vals) <- paste(colnames(pca.vals),paste(percentVar,'% variance',sep=""), sep=": ")
    pca.vals <- cbind(sample = rownames(pca.vals), pca.vals)
    write.table(pca.vals,file=paste(opt$outprefix,".pca.vals.txt",sep=""),row.names=FALSE,col.names=TRUE,sep="\t",quote=TRUE)

    ## SAMPLE CORRELATION HEATMAP
    sampleDists <- dist(t(assay(rld)))
    sampleDistMatrix <- as.matrix(sampleDists)
    colors <- colorRampPalette( rev(brewer.pal(9, "Blues")) )(255)
    pheatmap(sampleDistMatrix,clustering_distance_rows=sampleDists,clustering_distance_cols=sampleDists,col=colors)

    ## WRITE SAMPLE DISTANCES TO FILE
    write.table(cbind(sample = rownames(sampleDistMatrix), sampleDistMatrix),file=paste(opt$outprefix,".sample.dists.txt",sep=""),row.names=FALSE,col.names=TRUE,sep="\t",quote=FALSE)

    dev.off()
}
}

################################################
################################################
## PLOT QC                                    ##
################################################
################################################

##' PCA pre-processeor
##'
##' Generate all the necessary information to plot PCA from a DESeq2 object
##' in which an assay containing a variance-stabilised matrix of counts is
##' stored. Copied from DESeq2::plotPCA, but with additional ability to
##' say which assay to run the PCA on, and adds an assessment of how well
##' each PC explains the experimental grouping of the data.
##'
##' @param object The DESeq2DataSet object.
##' @param intgroup interesting groups: a character vector of names in 'colData(x)' to use for grouping.
##' @param ntop number of top genes to use for principla components, selected by highest row variance.
##' @param assay the name or index of the assay that stores the variance-stabilised data.
##' @return A data.frame containing the projected data alongside the grouping columns.
##' A 'percentVar' attribute is set which includes the percentage of variation each PC explains,
##' and additionally how much the variation within that PC is explained by the grouping variable.
##' @author Gavin Kelly
plotPCA_vst <- function (object, intgroup = "condition", ntop = 500, assay=length(assays(object))) {
    rv         <- rowVars(assay(object, assay))
    select     <- order(rv, decreasing = TRUE)[seq_len(min(ntop, length(rv)))]
    pca        <- prcomp(t(assay(object, assay)[select, ]))
    percentVar <- pca$sdev^2/sum(pca$sdev^2)
    if (!all(intgroup %in% names(colData(object)))) {
        stop("the argument 'intgroup' should specify columns of colData(dds)")
    }
    intgroup.df <- as.data.frame(colData(object)[, intgroup, drop = FALSE])
    group <- if (length(intgroup) > 1) {
        factor(apply(intgroup.df, 1, paste, collapse = ":"))
    }  else {
        colData(object)[[intgroup]]
    }
    d <- cbind(pca$x, group = group, intgroup.df, name = colnames(object))
    percentFrame <- data.frame(PC=seq(along=percentVar), percentVar=100*percentVar, groupR=0.0)
    for (ipc in seq(along=percentVar)) {
        fit1 <- lm(pca$x[,ipc]  ~ group)
        percentFrame$groupR[ipc] <- 100*summary(fit1)$r.squared
    }
    attr(d, "percentVar") <- percentFrame
    return(d)
}

PlotFile <- paste(opt$outprefix,".plots.pdf",sep="")
if (file.exists(PlotFile) == FALSE) {
    pdf(file=PlotFile,onefile=TRUE,width=7,height=7)

    ## PCA
    ntop <- c(500, Inf)
    for (n_top_var in ntop) {
        pca.data      <- plotPCA_vst(dds, assay=vst_name,intgroup="condition",ntop=n_top_var)
        percentVar    <- round(attr(pca.data, "percentVar")$percentVar)
        plot_subtitle <- ifelse(n_top_var==Inf, "All peaks", paste("Top", n_top_var, "peaks"))
        pl <- ggplot(pca.data, aes(PC1, PC2, color=condition)) +
            geom_point(size=3) +
            xlab(paste0("PC1: ",percentVar[1],"% variance")) +
            ylab(paste0("PC2: ",percentVar[2],"% variance")) +
            labs(title = paste0("First PCs on ", vst_name, "-transformed data"), subtitle = plot_subtitle) +
            theme(legend.position="top",
                    panel.grid.major = element_blank(),
                    panel.grid.minor = element_blank(),
                    panel.background = element_blank(),
                    panel.border = element_rect(colour = "black", fill=NA, size=1))
        print(pl)

        pl <- ggplot(attr(pca.data, "percentVar"), aes(x=PC, y=percentVar)) +
            geom_line(aes(colour="explained by PC")) +
            geom_line(aes(y=groupR, colour="of PC explained by condition")) +
            scale_x_continuous(breaks=seq(along=percentVar), minor_breaks=NULL)  +
            labs(title="Diagnostics of PCs", subtitle=plot_subtitle, x="Component", y="Percentage explaned", colour="Percentage variation") +
            theme_bw() +
            theme(legend.position="top")
        print(pl)

        pc_r <- order(attr(pca.data, "percentVar")$groupR, decreasing=TRUE)
        pl <- ggplot(pca.data, aes_string(paste0("PC", pc_r[1]), paste0("PC", pc_r[2]), color="condition")) +
            geom_point(size=3) +
            xlab(paste0("PC", pc_r[1], ": ",percentVar[pc_r[1]],"% variance")) +
            ylab(paste0("PC", pc_r[2], ": ",percentVar[pc_r[2]],"% variance")) +
            labs(title = paste0("Group-Explanatory PCs of ", vst_name, "-tranformed data"), subtitle = plot_subtitle) +
            theme(legend.position="top",
                panel.grid.major = element_blank(),
                panel.grid.minor = element_blank(),
                panel.background = element_blank(),
                panel.border = element_rect(colour = "black", fill=NA, size=1))
        print(pl)
    } # at end of loop, we'll be using the user-defined ntop if any, else all peaks

    ## VOLCANO PLOT
    plotMA(dds)

    ## WRITE PC1 vs PC2 VALUES TO FILE
    pca.vals           <- pca.data[,1:2]
    colnames(pca.vals) <- paste0(colnames(pca.vals), ": ", percentVar[1:2], '% variance')
    pca.vals           <- cbind(sample = rownames(pca.vals), pca.vals)
    write.table(pca.vals,file=paste(opt$outprefix,".pca.vals.txt",sep=""),row.names=FALSE,col.names=TRUE,sep="\t",quote=TRUE)

    ## SAMPLE CORRELATION HEATMAP
    sampleDists      <- dist(t(assay(dds, vst_name)))
    sampleDistMatrix <- as.matrix(sampleDists)
    colors           <- colorRampPalette( rev(brewer.pal(9, "Blues")) )(255)
    pheatmap(
        sampleDistMatrix,
        clustering_distance_rows=sampleDists,
        clustering_distance_cols=sampleDists,
        col=colors,
        main=paste("Euclidean distance between", vst_name, "of samples")
    )

    ## WRITE SAMPLE DISTANCES TO FILE
    write.table(cbind(sample = rownames(sampleDistMatrix), sampleDistMatrix),file=paste(opt$outprefix,".sample.dists.txt",sep=""),row.names=FALSE,col.names=TRUE,sep="\t",quote=FALSE)

    dev.off()
}

################################################
################################################
## LOOP THROUGH COMPARISONS                   ##
################################################
################################################

if (FALSE) {
    ResultsFile <- paste(opt$outprefix,".results.txt",sep="")
    if (file.exists(ResultsFile) == FALSE) {
        raw.counts <- counts(dds,normalized=FALSE)
        colnames(raw.counts) <- paste(colnames(raw.counts),'raw',sep='.')
        pseudo.counts <- counts(dds,normalized=TRUE)
        colnames(pseudo.counts) <- paste(colnames(pseudo.counts),'pseudo',sep='.')

        deseq2_results_list <- list()
        comparisons <- combn(unique(groups),2)
        for (idx in 1:ncol(comparisons)) {
            control.group <- comparisons[1,idx]
            treat.group <- comparisons[2,idx]
            CompPrefix <- paste(control.group,treat.group,sep="vs")
            cat("Saving results for ",CompPrefix," ...\n",sep="")

            CompOutDir <- paste(CompPrefix,'/',sep="")
            if (file.exists(CompOutDir) == FALSE) {
                dir.create(CompOutDir,recursive=TRUE)
            }

            control.samples <- samples.vec[which(groups == control.group)]
            treat.samples <- samples.vec[which(groups == treat.group)]
            comp.samples <- c(control.samples,treat.samples)

            comp.results <- results(dds,contrast=c("condition",c(control.group,treat.group)))
            comp.df <- as.data.frame(comp.results)
            #comp.table <- cbind(interval.table, as.data.frame(comp.df), raw.counts[,paste(comp.samples,'raw',sep='.')], pseudo.counts[,paste(comp.samples,'pseudo',sep='.')])
            comp.table <- cbind(as.data.frame(comp.df), raw.counts[,paste(comp.samples,'raw',sep='.')], pseudo.counts[,paste(comp.samples,'pseudo',sep='.')])

            ## WRITE RESULTS FILE
            CompResultsFile <- paste(CompOutDir,CompPrefix,opt$outsuffix,".deseq2.results.txt",sep="")
            write.table(comp.table, file=CompResultsFile, col.names=TRUE, row.names=FALSE, sep='\t', quote=FALSE)

            ## FILTER RESULTS BY FDR & LOGFC AND WRITE RESULTS FILE
            pdf(file=paste(CompOutDir,CompPrefix,opt$outsuffix,".deseq2.plots.pdf",sep=""),width=10,height=8)
            if (length(comp.samples) > 2) {
                for (MIN_FDR in c(0.01,0.05)) {

                    ## SUBSET RESULTS BY FDR
                    #pass.fdr.table <- subset(comp.table, padj < MIN_FDR)
                    #pass.fdr.up.table <- subset(comp.table, padj < MIN_FDR & log2FoldChange > 0)
                    #pass.fdr.down.table <- subset(comp.table, padj < MIN_FDR & log2FoldChange < 0)

                    ## SUBSET RESULTS BY FDR AND LOGFC
                    #pass.fdr.logFC.table <- subset(comp.table, padj < MIN_FDR & abs(log2FoldChange) >= 1)
                    #pass.fdr.logFC.up.table <- subset(comp.table, padj < MIN_FDR & abs(log2FoldChange) >= 1 & log2FoldChange > 0)
                    #pass.fdr.logFC.down.table <- subset(comp.table, padj < MIN_FDR & abs(log2FoldChange) >= 1 & log2FoldChange < 0)

                    ## WRITE RESULTS FILE
                    #CompResultsFile <- paste(CompOutDir,CompPrefix,opt$outsuffix,".deseq2.FDR",MIN_FDR,".results.txt",sep="")
                    #CompBEDFile <- paste(CompOutDir,CompPrefix,opt$outsuffix,".deseq2.FDR",MIN_FDR,".results.bed",sep="")
                    #write.table(pass.fdr.table, file=CompResultsFile, col.names=TRUE, row.names=FALSE, sep='\t', quote=FALSE)
                    #write.table(pass.fdr.table[,c("Chr","Start","End","Geneid","log2FoldChange","Strand")], file=CompBEDFile, col.names=FALSE, row.names=FALSE, sep='\t', quote=FALSE)

                    ## MA PLOT & VOLCANO PLOT
                    DESeq2::plotMA(comp.results, main=paste("MA plot FDR <= ",MIN_FDR,sep=""), ylim=c(-2,2),alpha=MIN_FDR)
                    #plot(comp.table$log2FoldChange, -1*log10(comp.table$padj), col=ifelse(comp.table$padj<=MIN_FDR, "red", "black"), xlab="logFC", ylab="-1*log10(FDR)", main=paste("Volcano plot FDR <=",MIN_FDR,sep=" "), pch=20)

                    ## ADD COUNTS TO LOGFILE
                    #cat(CompPrefix," genes with FDR <= ",MIN_FDR,": ",nrow(pass.fdr.table)," (up=",nrow(pass.fdr.up.table),", down=",nrow(pass.fdr.down.table),")","\n",file=LogFile,append=TRUE,sep="")
                    #cat(CompPrefix," genes with FDR <= ",MIN_FDR," & FC > 2: ",nrow(pass.fdr.logFC.table)," (up=",nrow(pass.fdr.logFC.up.table),", down=",nrow(pass.fdr.logFC.down.table),")","\n",file=LogFile,append=TRUE,sep="")

                }
                cat("\n",file=LogFile,append=TRUE,sep="")
            }

            ## SAMPLE CORRELATION HEATMAP
            rld.subset <- assay(rld)[,comp.samples]
            sampleDists <- dist(t(rld.subset))
            sampleDistMatrix <- as.matrix(sampleDists)
            colors <- colorRampPalette( rev(brewer.pal(9, "Blues")) )(255)
            pheatmap(sampleDistMatrix,clustering_distance_rows=sampleDists,clustering_distance_cols=sampleDists,col=colors)

            ## SCATTER PLOT FOR RLOG COUNTS
            combs <- combn(comp.samples,2,simplify=FALSE)
            clabels <- sapply(combs,function(x){paste(x,collapse=' & ')})
            plotdat <- data.frame(x=unlist(lapply(combs, function(x){rld.subset[, x[1] ]})),y=unlist(lapply(combs, function(y){rld.subset[, y[2] ]})),comp=rep(clabels, each=nrow(rld.subset)))
            plot <- xyplot(y~x|comp,plotdat,
                    panel=function(...){
                        panel.xyplot(...)
                        panel.abline(0,1,col="red")
                    },
                    par.strip.text=list(cex=0.5))
            print(plot)
            dev.off()

            colnames(comp.df) <- paste(CompPrefix,".",colnames(comp.df),sep="")
            deseq2_results_list[[idx]] <- comp.df
        }

        ## WRITE RESULTS FROM ALL COMPARISONS TO FILE
        deseq2_results_table <- cbind(do.call(cbind, deseq2_results_list),raw.counts,pseudo.counts)
        write.table(deseq2_results_table, file=ResultsFile, col.names=TRUE, row.names=FALSE, sep='\t', quote=FALSE)
    }
}

################################################
################################################
## SAVE SIZE FACTORS                          ##
################################################
################################################

SizeFactorsDir <- "size_factors/"
if (file.exists(SizeFactorsDir) == FALSE) {
    dir.create(SizeFactorsDir,recursive=TRUE)
}

NormFactorsFile <- paste(SizeFactorsDir,opt$outprefix,".size_factors.RData",sep="")
if (file.exists(NormFactorsFile) == FALSE) {
    normFactors <- sizeFactors(dds)
    save(normFactors,file=NormFactorsFile)

    for (name in names(sizeFactors(dds))) {
        sizeFactorFile <- paste(SizeFactorsDir,name,".txt",sep="")
        if (file.exists(sizeFactorFile) == FALSE) {
            write(as.numeric(sizeFactors(dds)[name]),file=sizeFactorFile)
        }
    }
}

################################################
################################################
## R SESSION INFO                             ##
################################################
################################################

RLogFile <- "R_sessionInfo.log"
if (file.exists(RLogFile) == FALSE) {
    sink(RLogFile)
    a <- sessionInfo()
    print(a)
    sink()
}
#}
################################################
################################################
################################################
################################################


ivmodelFormula <- function(formula,data,subset,
                            beta0=0,alpha=0.05,k=c(0,1),
                            heteroSE = FALSE, clusterID = NULL,
                            deltarange=NULL, na.action = na.omit) {
  if(!inherits(formula,"formula")) {
  	stop("method is only for formula objects!")
  }
  # code gratefully stolen from ivreg() (package AER).
  if (missing(data))
    data <- environment(formula)
  mf = match.call()
  m <- match(c("formula", "data", "subset", "na.action"), names(mf), 0)
  mf <- mf[c(1, m)]
  mf$drop.unused.levels <- TRUE
  formula <- as.Formula(formula)

  stopifnot(length(formula)[1] == 1L, length(formula)[2] %in%
        1:2)
  has_dot <- function(formula) inherits(try(terms(formula),silent = TRUE), "try-error")
  if (has_dot(formula)) {
    f1 <- formula(formula, rhs = 1)
    f2 <- formula(formula, lhs = 0, rhs = 2)
    if (!has_dot(f1) & has_dot(f2)) {
      formula <- as.Formula(f1, update(formula(formula, lhs = 0, rhs = 1), f2))
    }
  }
  mf$formula <- formula
  mf[[1]] <- as.name("model.frame")
  mf <- eval(mf, parent.frame())
  Y <- model.response(mf, "numeric"); Y = matrix(as.numeric(Y),length(Y),1)
  mt <- terms(formula, data = data)
  mtX <- terms(formula, data = data, rhs = 1)
  X <- model.matrix(mtX, mf)

  mtZ <- delete.response(terms(formula, data = data, rhs = 2))
  Z <- model.matrix(mtZ, mf)

  if("(Intercept)" %in% colnames(X)) {
  	intercept=TRUE
  	X = X[,!(colnames(X) %in% "(Intercept)"),drop=FALSE]
  	Z = Z[,!(colnames(Z) %in% "(Intercept)"),drop=FALSE]
  	if(dim(Z)[2] < 1) stop("There aren't any instruments!")
  } else{
  	intercept=FALSE
  }

  # Parse X and Z into D, X, and Z
  whichD = !(colnames(X) %in% colnames(Z))
  D = X[,whichD,drop=FALSE]
  if(dim(D)[2] != 1) {
  	stop("There must be exacty one endogenous variable! Please specify the formula correctly!")
  }
  unname(Z);unname(D); unname(Y)
  if(sum(!whichD) == 0) {
  	ivmodel(Y=Y,D=D,Z=Z,intercept=intercept,
  	                beta0=beta0,alpha=alpha,k=k,
  	                heteroSE=heteroSE,clusterID=clusterID,
  	                deltarange=deltarange, na.action=na.action)
  } else {
  	unname(X)
  	X = X[,!whichD,drop=FALSE]
  	whichZ = !(colnames(Z) %in% colnames(X))
    Z = Z[,whichZ,drop=FALSE]
  	ivmodel(Y=Y,D=D,Z=Z,X=X,intercept=intercept,
  	                beta0=beta0,alpha=alpha,k=k,
  	                heteroSE=heteroSE,clusterID=clusterID,
  	                deltarange=deltarange, na.action=na.action)
 }
}


library(ggplot2)
theme_set(theme_bw(18))
setwd("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/25_sinking-marbles-priordv-15_replication/results/")

source("rscripts/helpers.r")
#load("data/priors.RData")
load("data/r.RData")
r = read.table("data/sinking_marbles.csv", sep=",", header=T)
r$trial = r$slide_number_in_experiment - 2
r$workerid = r$workerid + 120
r = r[,c("workerid", "rt", "effect", "cause","language","gender.1","age","gender","other_gender","quantifier", "object_level", "response", "object","num_objects","trial","enjoyment","asses","comments")]
#row.names(priors) = paste(priors$effect, priors$object)
expectations = read.table("data/expectations.txt", quote="",sep="\t",header=T)
row.names(expectations) = paste(expectations$effect, expectations$object)
head(expectations)
nrow(expectations)

r$Half = as.factor(ifelse(r$trial < 16, 1, 2))
r$Quarter = as.factor(ifelse(r$trial < 8, 1, ifelse(r$trial < 16, 2, ifelse(r$trial < 24, 3, 4))))
summary(r)
r$Item = as.factor(paste(r$effect,r$object))
table(r$Item)
r$numresponse = as.numeric(as.character(r$response))
table(r$quantifier,r$numresponse)
r$ProportionResponse = r$numresponse/r$num_objects
r$PriorExpectation = expectations[paste(r$effect, r$object),]$expectation

save(r, file="data/r.RData")

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

ggplot(aes(x=gender.1), data=r) +
  geom_histogram()

ggplot(aes(x=rt), data=r) +
  geom_histogram() +
  scale_x_continuous(limits=c(0,20000))

ggplot(aes(x=age), data=r) +
  geom_histogram()

ggplot(aes(x=enjoyment), data=r) +
  geom_histogram()

ggplot(aes(x=asses), data=r) +
  geom_histogram()

ggplot(aes(x=quantifier), data=r) +
  geom_histogram()

head(r$comments)
unique(r$comments)


rm(list=ls())
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)

# set dataset

dataset <- "Streicher"
## AI
#h <- "AIdGLS"
#h1 <- "AIvSA"
#h2 <- "AIvSI"
#h3 <- "AIvAvg"
# SA
h <- "SAdGLS"
h1 <- "SAvSI"
h2 <- "SAvSI"
h3 <- "SAvAvg"
## SI
#h <- "SIdGLS"
#h1 <- "SIvAI"
#h2 <- "SIvSA"
#h3 <- "SIvAvg"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

GL <- function(df.g,xval.g,xlablab.g,tic.g,lines.g,limit.g,cc.g,title.g){
  GL_hist <- ggplot(data=df.g, aes(x=xval.g)) +
  geom_histogram(binwidth = limit.g*0.01, alpha=1, position="dodge", color=cc.g, fill=cc.g)+
  theme_classic() +
  theme(plot.title = element_text(hjust = 0.5, size=16),
        axis.text = element_text(size=10, color="black"),
        text = element_text(size=14),
        legend.title = element_text(size = 12),
        legend.text = element_text(size = 10)) +
  labs(y="Number of Loci",x=xlablab.g)  +
  ggtitle(title.g) +
  coord_cartesian(ylim=ymax, xlim = tic.g) +
  scale_x_continuous(breaks = c(0,tic.g)) +
  scale_y_continuous(breaks = ymax) +
  # geom_vline(xintercept=lines.g,color=c("black"), linetype="dashed", size=0.5) +
  geom_vline(xintercept=c(0),color=c("black"), linetype="dashed", size=0.2)
  return(GL_hist)
}

# Colors
color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "#C2DF23FF"

# you'll have to graph first, then reset this
maxloci <- 300
ymax <- seq(0,maxloci,50)

#Streicher 350,50
#Singhal 1200,100
#quartz()

# Set title and input data
title.1 <- paste(dataset," - ",h1,sep="")
title.2 <- paste(dataset," - ",h2,sep="")
title.3 <- paste(dataset," - ",h3,sep="")
cc.1 <- color_SI
df.1 <- mLGL
## AI
#xval.1 <- mLGL$AIvSA
#xval.2 <- mLGL$AIvSI
#xval.3 <- mLGL$AIvAvg
## SA
#xval.1 <- mLGL$AIvSA*(-1) # reversing values
#xval.2 <- mLGL$SAvSI
#xval.3 <- mLGL$SAvAvg
## SI
#xval.1 <- mLGL$AIvSI*(-1) # reversing values
#xval.2 <- mLGL$SAvSI*(-1) # reversing
#xval.3 <- mLGL$SIvAvg

xlablab.1 <- 'dGLS values'

# Get max min for graph to set x axis values
limit.1 <- 5 + round(max(abs(min(xval.1)),abs(max(xval.1))),-1)
limit.2 <- 5 + round(max(abs(min(xval.2)),abs(max(xval.2))),-1)
limit.3 <- 5 + round(max(abs(min(xval.3)),abs(max(xval.3))),-1)
max(c(limit.1,limit.2,limit.3))
limit.1 <- 25
tic.1 <- seq(-limit.1,limit.1,5)
lines.1 <- c(0.5,-0.5)

#quartz()
GL.1 <- GL(df.1,xval.1,xlablab.1,tic.1,lines.1,limit.1,cc.1,title.1)
GL.2 <- GL(df.1,xval.2,xlablab.1,tic.1,lines.1,limit.1,cc.1,title.2)
GL.3 <- GL(df.1,xval.3,xlablab.1,tic.1,lines.1,limit.1,cc.1,title.3)

G.all <- ggarrange(GL.1,GL.2,GL.3, ncol=1, nrow=3, align="v")
quartz()
G.all

#ggsave(paste(dataset,"_histo.pdf",sep=""), plot=graph_combined,width = 9, height = 7, units = "in", device = 'pdf',bg = "transparent")
# For tox add hypoth you mentioned at the beginning
ggsave(paste(dataset,"_histo_",h,".pdf",sep=""), plot=G.all,width = 9, height = 7, units = "in", device = 'pdf',bg = "transparent")

# Remove variables im gonna duplicate for BF
rm(h, df.1,xval.1,xval.2,xval.3,xlablab.1,limit.1,limit.2,limit.3,tic.1,lines.1)

# Set title and input data
df.1 <- mLBF
## AI
#h <- "AIBF"
#xval.1 <- mLGL$AIvSA
#xval.2 <- mLGL$AIvSI
#xval.3 <- mLGL$AIvAvg
## SA
#h <- "SABF"
#xval.1 <- mLGL$AIvSA*(-1) # reversing values
#xval.2 <- mLGL$SAvSI
#xval.3 <- mLGL$SAvAvg
## SI
#h <- "SIBF"
#xval.1 <- mLGL$AIvSI*(-1) # reversing values
#xval.2 <- mLGL$SAvSI*(-1) # reversing
#xval.3 <- mLGL$SIvAvg

xlablab.1 <- '2ln(BF) values'

# Get max min for graph to set x axis values
limit.1 <- 5 + round(max(abs(min(xval.1)),abs(max(xval.1))),-1)
limit.2 <- 5 + round(max(abs(min(xval.2)),abs(max(xval.2))),-1)
limit.3 <- 5 + round(max(abs(min(xval.3)),abs(max(xval.3))),-1)
max(c(limit.1,limit.2,limit.3))
limit.1 <- 25
tic.1 <- seq(-limit.1,limit.1,5)
lines.1 <- c(10,10)

#quartz()
BF.1 <- GL(df.1,xval.1,xlablab.1,tic.1,lines.1,limit.1,cc.1,title.1)
BF.2 <- GL(df.1,xval.2,xlablab.1,tic.1,lines.1,limit.1,cc.1,title.2)
BF.3 <- GL(df.1,xval.3,xlablab.1,tic.1,lines.1,limit.1,cc.1,title.3)

B.all <- ggarrange(BF.1,BF.2,BF.3, ncol=1, nrow=3, align="v")
quartz()
B.all

#ggsave(paste(dataset,"_histo.pdf",sep=""), plot=graph_combined,width = 9, height = 7, units = "in", device = 'pdf',bg = "transparent")
# For tox add hypoth you mentioned at the beginning
ggsave(paste(dataset,"_histo_",h,".pdf",sep=""), plot=G.all,width = 9, height = 7, units = "in", device = 'pdf',bg = "transparent")


#' kmh2ms
#'
#' Conversion from kilometers per hour to meters per second.
#'
#' @param kmh numeric  Speed kilometer per hour.
#' @return meters per second
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  kmh2ms
#'
#' @export
#'
#'
#'
#'

kmh2ms=function(kmh) {
                         ct$assign("kmh", as.array(kmh))
                         ct$eval("var res=[]; for(var i=0, len=kmh.length; i < len; i++){ res[i]=kmh2ms(kmh[i])};")
                          res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


# resp_times.r
# Get the times at every response for whole data frame

resp_times <- function(df,n_trials){

  df <- df %>% filter(cum_trial <= n_trials,
                      cum_dt <= 180)

  df$bins <- df$cum_dt %>%
    get_bins(., 0, 180, 1)

  df <- df %>%
  {
    var     <- .
    event   <- var %>% `[[`("evento")
    boolean <- ifelse(event == 1 | event == 11,1,0) %>% as.logical()
    var     <- var[boolean, ]
    var
  }

 df %>% select(sujeto,evento,sesion,cde,bins,cum_trial)

}


library(sf)
library(watershed)
library(raster)
options(mc.cores = 4)
dem = raster("data/dem_lg.tif")
stream = delineate(dem, threshold = 8e7, reach_len = 7000)
Tp = pixel_topology(stream)
neretva = vectorise_stream(stream$stream, Tp)
st_write(neretva, "output/neretva_sm.gpkg", append = FALSE)


library(base)
library(modules)
library(rstudioapi)
library(stats)
library(tidyverse)
library(utils)

base::setwd(base::dirname(rstudioapi::getActiveDocumentContext()$path))
start <- base::Sys.time()

base::set.seed(0xACDC)

do_pca <- function(data) {
  matrix <- base::as.matrix(data)

  pca <- stats::prcomp(matrix, scale. = TRUE)

  percent <- pca$sdev ^ 2 / base::sum(pca$sdev ^ 2) * 100

  graphics::barplot(percent,
                    main = 'Scree Plot',
                    xlab = 'Principal Component',
                    ylab = 'Percent Variation')
}

data <- modules::use('data')$get_data$get_all_data()

data$url <- NULL
data$status <- NULL

to_remove <- base::c()

for (i in 1:base::ncol(data)) {
  if (base::length(base::unique(data[, i])) == 1) {
    to_remove <- base::append(to_remove, i)
  }
}

data[, to_remove] <- NULL

do_pca(data)

clean_data <- modules::use('data')$get_data$get_data()

clean_data$url <- NULL
clean_data$status <- NULL

do_pca(clean_data)

base::print(base::Sys.time() - start)
base::rm(i, to_remove, start)


#!/usr/local/bin/env Rscript --vanilla
args <- commandArgs(TRUE)
if (!is.null(args[1])) {
    df <- read.csv(args[1], sep = "\t", row.names = 1, check.names=F)
    if (max(df, na.rm = TRUE) < 50) {
        df <- 2^df
    }
} else {
    stop("No expression matrix provided!")
}

library(matrixStats)
library(xCell)

BiocParallel::register(BiocParallel::SerialParam())

if (length(args) > 1) {
    ref <- read.csv(args[2], sep = "\t", row.names = 1, check.names=F) ### Need to change later
    ref <- as.data.frame(ref[intersect(rownames(ref), rownames(df)),])
    cellTypeNames <- colnames(ref)
    marker <- list()
    taggedNames <- c()
    for (i in seq(dim(ref)[2])) {
        s = cellTypeNames[i]
        tempMarkers <- rownames(ref[ref[,s] > quantile(ref[,s], prob=0.75),])
        markers <- c()
        if (length(args) > 2) {
            if (tolower(args[3]) == "pairwise") {
                tempTb = 2 * ref[,cellTypeNames[cellTypeNames != s]] - ref[,s]
                markers <- tempMarkers[tempMarkers %in% rownames(ref[rowSums(tempTb < 0) == (length(cellTypeNames) - 1), ])]
            } else {
                markers <- tempMarkers[tempMarkers %in% rownames(ref)[ref[,s] > 2 * rowMedians(as.matrix(ref))]]
            }
        } else {
            markers <- tempMarkers[tempMarkers %in% rownames(ref)[ref[,s] > 2 * rowMedians(as.matrix(ref))]]
        }
        if (length(markers) == 0) {
            # tempMarkers <- rownames(ref[ref[,s] > quantile(ref[,s], prob=0.5),])
            deOverMedians <- (ref[tempMarkers,s] - rowMedians(as.matrix(ref[tempMarkers,])))/rowMedians(as.matrix(ref[tempMarkers,]))
            markers <- tempMarkers[deOverMedians > quantile(deOverMedians, prob=0.9)]
        }
        marker[[i]] <- markers
        taggedNames <- c(taggedNames, paste0(colnames(ref)[i], "%", cellTypeNames[i], toString(i), "%", cellTypeNames[i], toString(i), ".txt"))
    }

    names(marker) <- taggedNames#paste0(colnames(ref), "%tag0%tag1")

    spill <- list()
    spill[["K"]] <- matrix(1/length(cellTypeNames), nrow = length(cellTypeNames), ncol = length(cellTypeNames), dimnames = list(cellTypeNames, cellTypeNames))
    spill[["fv"]] <- as.data.frame(matrix(1, nrow = length(cellTypeNames), ncol = 3, dimnames = list(cellTypeNames, c("V1", "V2", "V3"))))
    tryCatch(
        expr = {
            xc <- xCellAnalysis(df, file.name = "deconvoluted.tsv", signatures = marker, genes = rownames(df), cell.types.use = cellTypeNames, spill = spill, scale = FALSE, parallel.sz = 1)
            # dec <- read.csv("deconvoluted.tsv", sep = "\t", row.names = 1, check.names=F)
            # colnames(dec) <- colnames(df)
            # rownames(dec) <- colnames(ref)
            # write.table(dec, file = "deconvoluted.tsv", quote = FALSE, col.names = NA, sep = "\t")
        },
        error = function(e){
            # (Optional)
            # Do this if an error is caught...
            print(e)
            X <- read.csv(args[2], sep = "\t", row.names = 1,check.names=F)
            Y <- read.csv(args[1], sep = "\t",check.names=F)
            mcp <- matrix(0, ncol = length(colnames(Y)) - 1, nrow = length(colnames(X)), dimnames = list(colnames(X), colnames(Y)[2:length(colnames(Y))]))
            write.table(mcp, file="deconvoluted.tsv", quote = FALSE, col.names = NA, sep = "\t")
        }
    )
} else {
    xc <- xCellAnalysis(df, file.name = "deconvoluted.tsv")
    # dec <- read.csv("deconvoluted.tsv", sep = "\t", row.names = 1, check.names=F)
    # colnames(dec) <- colnames(df)
    # write.table(dec, file = "deconvoluted.tsv", quote = FALSE, col.names = NA, sep = "\t")
}

#write.table(xc, file = "deconvoluted-pvalue.tsv", quote = FALSE, col.names = NA, sep = "\t")


# RShiny code for basic data visualization of NH Streams bug and nuts data
# Code adapted by Ben Block from Diane Allen
# Written 12/13/2021
#
# Call libraries ####
library(dplyr)
library(ggplot2)
library(shiny)
library(tidyr)
library(scales)
library(leaflet)
library(quantreg)

# import data ####
df_nuts<-read.csv("Data/nutrients_wide01102022.csv")
df_strs_respon <-read.csv("Data/NH_Strs_Resp_Data_20220218.csv")

# duplicate nutrient data for distinct groups
df_ref <- df_nuts %>%
  filter(DistCat_Tt == "Ref") %>%
  mutate(Group = "Ref_Samps")

df_above_thresh <- df_nuts %>%
  filter(BugThreshGroup == "Above_Threshold") %>%
  mutate(Group = "Above_Threshold")

df_nuts$Group <- "All_Samps"

df_nuts_updated <- rbind(df_nuts, df_ref, df_above_thresh)

df_nuts_updated$Group <- factor(df_nuts_updated$Group,
                                levels = c("All_Samps","Ref_Samps", "Above_Threshold"))

# duplicate stressor response data for distinct groups

# df_ref_respon <- df_strs_respon %>%
#   filter(DistCat_Tt == "Ref") %>%
#   mutate(Group = "Ref_Samps")
#
# df_strs_respon$Group <- "All_Samps"
#
# df_strs_respon_updated <- rbind(df_strs_respon, df_ref_respon)
#
# df_strs_respon_updated$Group <- as.factor(df_strs_respon_updated$Group)

# Create app

# ui ####

ui <- fluidPage(
  tabsetPanel(
    ## Macroinvert tab ####
    tabPanel("Macroinvertebrates and Nutrients"
      , sidebarLayout(
        sidebarPanel(
          helpText("The information presented here represents",
                   "macroinvertebrate and nutrient data paired by site and year.",
                   "Note: IBI (and component metric) scores and nutrient data are annual medians.")
          ,selectInput(inputId = "Nut_Choice1"
                      ,label = "Nutrient Parameter:"
                      ,choices = c("Med_NOx_mgL"
                                   ,"Med_TP_mgL"
                                   ,"Med_TKN_mgL"
                                   ,"Med_NO3_mgL"
                                   ,"Med_TN_mgL"
                                   ,"Med_NO2_mgL"
                                   ,"Med_Chla_uncorr"
                                   ,"Med_NH3_mgL"
                                   ,"Med_PO4_mgL")) # selectInput

          ,selectInput(inputId = "Bug_Choice1"
                       ,label = "Macroinvertebrate Parameter:"
                       ,choices = c("Med_IBI_Score"
                                    ,"Med_TotTaxSc"
                                    ,"Med_PlecTaxSc"
                                    ,"Med_ChirPctSc"
                                    ,"Med_NonInsPctSc"
                                    ,"Med_ClingPctSc"
                                    ,"Med_IntolPctSc"
                                    ,"Med_TolerTaxSc")) # selectInput

        ) # sidebarPanel
        , mainPanel(
          plotOutput(outputId = "S_R_Plot")
          , h5("Solid line = 90th quantile regression; dashed line = linear regression")
          , br()
          , h4("Summary statistics for all samples:")
          , verbatimTextOutput("stats1")
          , h4("Summary statistics for Ref samples:")
          , verbatimTextOutput("stats2")
          , h4("Summary statistics for linear model of all samples:")
          , verbatimTextOutput("lm")
        ) # mainPanel
      ) # sidebarLayout
    ) # tabPanel
    ## Nutrient tab ####
    , tabPanel("Nutrient Distributions",
               fluidRow(
                 column(width=4, offset = 1,
                        # Input: parameter
                        selectInput(inputId = "Nut_Choice2",
                                    label = "Nutrient Parameter",
                                    choices = c("NOx_mgL"
                                                ,"TP_mgL"
                                                ,"TKN_mgL"
                                                ,"NO3_mgL"
                                                ,"TN_mgL"
                                                ,"NO2_mgL"
                                                ,"Chla_Uncorr"
                                                ,"Chla_corr"
                                                ,"NH3_mgL"
                                                ,"PO4_mgL"
                                                ,"TDN_mgL"
                                                ,"NH4_ugL")) # selectInput
                        ) # column
                 )
               , fluidRow(
                 column(width=4
                        , helpText("The information presented here represents",
                                   "nutrient data sampling locations. Note: not all data",
                                   "are shown in the map because some sites had",
                                   "missing lat/long info.")
                        ,leafletOutput(outputId = "Map")
                        ,height=800
                        )# column
                 , column(width=4
                          ,plotOutput(outputId = "cdf")
                          ,tableOutput(outputId = "QuantTable")
                          ) # column
                 , column(width=3
                          ,plotOutput(outputId = "boxplot")
                          ) # column
               ) # fluidRow
    ) # tabPanel
  ) # tabsetPanel
) # fluidPage

# server ####

server <- function(input, output, session){

  ## Stressor Response tab ####

  myData <- reactive({
    df_strs_respon %>%
      select(input$Nut_Choice1, input$Bug_Choice1, DistCat_Tt) %>%
      filter(complete.cases(.))
  }) # reactive

  ### stressor response plot ####
  output$S_R_Plot <- renderPlot({

    # filter data
    plot_data <- myData()
    plot_data$DistCat_Tt <- as.factor(plot_data$DistCat_Tt)

    # get number of observations
    myCount <- nrow(plot_data)
    myRefCount <- sum(plot_data$DistCat_Tt == "Ref")

    # create color scale
    pal <- c("Ref" = "#0570b0"
             ,"Non-Ref" = "#969696"
             ,"Not_Eval" = "#cccccc")

  # create plot
    ggplot(data = plot_data
           , aes(x = log10(.data[[input$Nut_Choice1]])
                 , y = (.data[[input$Bug_Choice1]])))+
      geom_smooth(method='lm', formula= y~x, color = "Red", linetype = "dashed"
                  , size = 2, na.rm = TRUE)+
      geom_quantile(quantiles = 0.90, formula= y~x, color = "light blue"
                    , linetype = "solid", size = 1, na.rm = TRUE)+
      geom_point(aes(color = DistCat_Tt))+
      labs(title = paste0(input$Nut_Choice1," vs ", input$Bug_Choice1, "; n = "
                          , myCount, "; n Ref = ", myRefCount)
           , y = paste0(input$Bug_Choice1)
           , x = paste0("Log10(",input$Nut_Choice1,")")
           , color = "Ref Status")+
      scale_color_manual(values = pal)+
      theme(text = element_text(size = 14),
            axis.text = element_text(color = "black", size = 14),
            axis.text.x = element_text(angle = 0, hjust = 0.5),
            panel.background = element_rect(fill = "white"),
            panel.grid.major.y = element_blank(),
            panel.grid.major.x = element_blank(),
            panel.grid.minor = element_blank(),
            panel.border = element_blank(),
            axis.line = element_line(color = "black"),
            legend.position = "right",
            legend.text=element_text(size = 14))

  }) # renderPlot

  ### Stats ####
  output$stats1 <- renderPrint({
    stat1_data <- myData()
    stat1_data <- stat1_data %>%
      select(input$Nut_Choice1, input$Bug_Choice1)

    summary(stat1_data)
  }) # renderPrint

  output$stats2 <- renderPrint({
    stat2_data <- myData()
    stat2_data <- stat2_data %>%
      filter(DistCat_Tt == "Ref") %>%
      select(input$Nut_Choice1, input$Bug_Choice1)

    summary(stat2_data)

  }) # renderPrint

  ### LM summary ####

  # build linear model
  Linear_Model <- reactive({
    lm_data <- myData()
    lm_data <- lm_data %>%
      rename(Nut_Parameter = input$Nut_Choice1
             , Bug_Parameter = input$Bug_Choice1)

    lm(Bug_Parameter ~ Nut_Parameter, data = lm_data)
  }) # reactive

  output$lm <- renderPrint({
    summary(Linear_Model())
  })

  ## Nutrient tab ####

  myNutData <- reactive({
    df_nuts_updated %>%
      select(input$Nut_Choice2, DistCat_Tt, Group) %>%
      filter(complete.cases(.))
  }) # reactive

  myMapData <- reactive({
    df_nuts %>%
      select(StationID, Latitude, Longitude, input$Nut_Choice2) %>%
      filter(complete.cases(.))
  }) # reactive

  # create color scale
  nutpal <- c("Ref_Samps" = "#0570b0"
              ,"All_Samps" = "#969696"
              ,"Above_Threshold" = "#04b571")

  ### Map ####

  output$Map <- renderLeaflet({

    df_4Map <- myMapData()

    df_4Map <- df_4Map %>%
      select(StationID, Latitude, Longitude) %>%
      distinct(.keep_all = TRUE)

    leaflet() %>%
      addTiles() %>%
      addProviderTiles(providers$Esri.WorldStreetMap, group="Esri WSM") %>%
      addProviderTiles("CartoDB.Positron", group="Positron") %>%
      addProviderTiles(providers$Stamen.TonerLite, group="Toner Lite") %>%
      addCircleMarkers(data = df_4Map, lat = ~Latitude, lng = ~Longitude
                       , group = "NH WQ Sites"
                       , popup = paste("StationID:", df_4Map$StationID)
                       , color = "black", fillColor = "orange"
                       , fillOpacity = 0.5, radius = 1, stroke = TRUE
      ) %>%
      addLayersControl(overlayGroups = c("NH WQ Sites"),
                       baseGroups = c("Esri WSM", "Positron", "Toner Lite"),
                       options = layersControlOptions(collapsed = TRUE))%>%
      addMiniMap(toggleDisplay = TRUE, tiles = providers$Esri.WorldStreetMap)
  }) ##renderLeaflet~END

  ### cdf plot ####
  output$cdf <- renderPlot({

    # filter data
    cdf_data <- myNutData()

    # get number of observations
    myCDFCount <- sum(cdf_data$Group == "All_Samps")
    myCDFRefCount <- sum(cdf_data$Group == "Ref_Samps")
    myCDFThreshCount <- sum(cdf_data$Group == "Above_Threshold")

    # create plot

    ggplot(data = cdf_data
           , aes(x = log10(.data[[input$Nut_Choice2]]), color = Group))+
      stat_ecdf(geom = "point", pad = FALSE)+
      # stat_ecdf(geom = "point", pad = FALSE, color = "orange")+
      labs(title = paste0(input$Nut_Choice2,"; n = "
                          , myCDFCount,"; n Ref = ", myCDFRefCount
                          , "; \nn Above Threshold = ", myCDFThreshCount)
           , y = "Cumulative Percent"
           , x = paste0("Log10(",input$Nut_Choice2,")"))+
      scale_color_manual(values = nutpal)+
      theme(text = element_text(size = 14),
            axis.text = element_text(color = "black", size = 14),
            axis.text.x = element_text(angle = 0, hjust = 0.5),
            panel.background = element_rect(fill = "white"),
            panel.grid.major.y = element_blank(),
            panel.grid.major.x = element_blank(),
            panel.grid.minor = element_blank(),
            panel.border = element_blank(),
            axis.line = element_line(color = "black"),
            legend.position = "top",
            legend.text=element_text(size = 14))

  }) # renderPlot

  ### boxplot ####

  output$boxplot <- renderPlot({

    # format data
    box_data <- myNutData()
    box_data$Parameter <- input$Nut_Choice2

    # get number of observations
    myBoxCount <- nrow(box_data)

    # get number of observations
    myBoxCount <- sum(box_data$Group == "All_Samps")
    myBoxRefCount <- sum(box_data$Group == "Ref_Samps")
    myBoxThreshCount <- sum(box_data$Group == "Above_Threshold")

    # create plot

    ggplot(data = box_data
           , aes(x = Parameter
                 , y = log10(.data[[input$Nut_Choice2]])
                 , fill = Group))+
      geom_boxplot()+
      labs(title = paste0(input$Nut_Choice2,"; n = "
                          , myBoxCount,"; n Ref = ", myBoxRefCount
                          , "; \nn Above Threshold = ", myBoxThreshCount)
           , y = paste0("Log10(",input$Nut_Choice2,")")
           , x = input$Nut_Choice2)+
      scale_fill_manual(values = nutpal)+
      theme(text = element_text(size = 14),
            axis.text = element_text(color = "black", size = 14),
            axis.text.x = element_text(angle = 0, hjust = 0.5),
            panel.background = element_rect(fill = "white"),
            panel.grid.major.y = element_blank(),
            panel.grid.major.x = element_blank(),
            panel.grid.minor = element_blank(),
            panel.border = element_blank(),
            axis.line = element_line(color = "black"),
            legend.position = "top",
            legend.text=element_text(size = 14))

  }) # renderPlot

  ### Quantile table ####
  output$QuantTable <- renderTable({

    # format data
    Table_Data <- myNutData()
    Table_Data <- Table_Data %>%
      rename(Parameter = input$Nut_Choice2)

    Table_Data %>%
      group_by(Group) %>%
      summarize(N = n()
                , min = min(Parameter)
                , `10%` = quantile(Parameter, 0.10)
                , `25%` = quantile(Parameter, 0.25)
                , `50%` = quantile(Parameter, 0.50)
                , `75%` = quantile(Parameter, 0.75)
                , `90%` = quantile(Parameter, 0.90)
                , max = max(Parameter))

  }) # renderTable

} # End of server

shinyApp(ui, server)


EvaluationStats<-function(out,thresh,train,train.pred,opt.methods=opt.methods){
    response<-out$dat$ma$ma.test[,1]

     if(out$input$model.source.file=="rf.r") {pred<-tweak.p(as.vector(predict(out$mods$final.mod,newdata=out$dat$ma$ma.test[,-1],type="prob")[,2]))
      modelname="Random Forest"
     }

    if(out$input$model.source.file=="mars.r") {pred<-mars.predict(out$mods$final.mod,out$dat$ma$ma.test)$prediction[,1]
         modelname="MARS"
    }

    if(out$input$model.source.file=="glm.r")  {pred=glm.predict(out$mods$final.mod,out$dat$ma$ma.test)
        modelname="GLM"
    }

    if(out$input$model.source.file=="brt.r") {pred=predict.gbm(out$mods$final.mod,out$dat$ma$ma.test,out$mods$final.mod$target.trees,type="response")
       modelname="BRT"
      }

    auc.output<-make.auc.plot.jpg(out$dat$ma$ma.test,pred=pred,plotname=paste(out$dat$bname,"_auc_plot.jpg",sep=""),
          modelname=modelname,test.split=TRUE,thresh=thresh,train=train,train.pred,opt.methods=opt.methods,weight=out$dat$ma$test.weights,out=out)

                out$mods$auc.output<-auc.output

}


#' Generate Movreg holiday regression matrix
#'
#' Generates a matrix with holiday regressors as defined within the BLS weekly adjustment program Movereg
#'
#' @param hol_n Numeric scalar; number of weights for this particular holiday
#' @param hol_index Numeric scalar; position of holiday within the weight vector
#' @param hol_wt Numeric vector; weight vector for holiday effect
#' @param hol_type Character scalar; Type of holiday (\code{'newyear'} for New Years Day, \code{'mlk'} for MLK Observance, \code{'president'} for President's Day, \code{'easter'} for Easter, \code{'memorial'} for Memorial Day, \code{'july4'} for Independence Day, \code{'labor'} for Labor Day, \code{'columbus'} for Columbus Day, \code{'veteran'} for Veterans Day, \code{'thanks'} for Thanksgiving).
#' @param this_week Numeric vector; Week of the year for each observation.
#' @param this_year Numeric vector; Year of each observation.
#' @return Generate matrix of holiday regressors as defined within the BLS weekly adjustment program Movereg
#' @examples
#' ic_easter  <-
#'   gen_movereg_holiday(hol_n = 8,
#'                       hol_index = 8,
#'                       hol_wt = c(1, 0, 0, 0, 0, 0, 0, 0),
#'                       hol_type = 'easter',
#'                       this_week = ic_week,
#'                       this_year = ic_year)
#' ic_labor  <-
#'   gen_movereg_holiday(hol_n = 2,
#'                       hol_index = 2,
#'                       hol_wt = c(0, 1),
#'                       hol_type = 'labor',
#'                       this_week = ic_week,
#'                       this_year = ic_year)
#' ic_thanksgiving <-
#'   gen_movereg_holiday(hol_n = 1,
#'                       hol_index = 1,
#'                       hol_wt = array(1, dim=1),
#'                       hol_type = 'thanksgiving',
#'                       this_week = ic_week,
#'                       this_year = ic_year)
#' ic_holiday_matrix_reduced <- cbind(ic_easter, ic_labor, ic_thanksgiving)
#' colnames(ic_holiday_matrix_reduced) <- c('easter', 'labor', 'thanksgiving')
#' @import stats
#' @export
gen_movereg_holiday <- function(hol_n, hol_index, hol_wt, hol_type, this_week, this_year) {
    # Author: Brian C. Monsell (OEUS), Version 2.10, 3/23/2021

    # Set first and last week of the series
    first_week <- this_week[1]
    last_week <- this_week[length(this_week)]

    # Set first and last year of the series
    first_year <- min(this_year)
    last_year <- max(this_year)

    # Initialize \code{this_week_range}
    this_week_range <- NULL

    # Generate holiday dates for all the holiday starts General procedure is to set a week range,
    # adjust the first and last year the holiday is defined for, generate the year sequence, set the
    # holiday dates based on the year sequence
    if (hol_type == "newyear") {
        this_week_range <- 1:2
        if (first_week > 1) {
            first_year <- first_year + 1
        }
        if (last_week < 2) {
            last_year <- last_year - 1
        }
        this_year_seq <- seq(first_year, last_year)
        this_hol_dates <- as.Date(timeDate::NewYearsDay(this_year_seq))
    }
    if (hol_type == "mlk") {
        this_week_range <- 2:4
        if (first_week > 2) {
            first_year <- first_year + 1
        }
        if (last_week < 4) {
            last_year <- last_year - 1
        }
        this_year_seq <- seq(first_year, last_year)
        this_hol_dates <- as.Date(timeDate::USMLKingsBirthday(this_year_seq))
    }
    if (hol_type == "president") {
        this_week_range <- 7:9
        if (first_week > 7) {
            first_year <- first_year + 1
        }
        if (last_week < 9) {
            last_year <- last_year - 1
        }
        this_year_seq <- seq(first_year, last_year)
        this_hol_dates <- as.Date(timeDate::USPresidentsDay(this_year_seq))
    }
    if (hol_type == "easter") {
        this_week_range <- 12:18
        if (first_week > 12) {
            first_year <- first_year + 1
        }
        if (last_week < 18) {
            last_year <- last_year - 1
        }
        this_year_seq <- seq(first_year, last_year)
        this_hol_dates <- as.Date(timeDate::Easter(this_year_seq))
    }
    if (hol_type == "memorial") {
        this_week_range <- 22:23
        if (first_week > 22) {
            first_year <- first_year + 1
        }
        if (last_week < 25) {
            last_year <- last_year - 1
        }
        this_year_seq <- seq(first_year, last_year)
        this_hol_dates <- as.Date(timeDate::USMemorialDay(this_year_seq))
    }
    if (hol_type == "july4") {
        this_week_range <- 25:29
        if (first_week > 25) {
            first_year <- first_year + 1
        }
        if (last_week < 29) {
            last_year <- last_year - 1
        }
        this_year_seq <- seq(first_year, last_year)
        this_hol_dates <- as.Date(timeDate::USIndependenceDay(this_year_seq))
    }
    if (hol_type == "labor") {
        this_week_range <- 35:37
        if (first_week > 35) {
            first_year <- first_year + 1
        }
        if (last_week < 37) {
            last_year <- last_year - 1
        }
        this_year_seq <- seq(first_year, last_year)
        this_hol_dates <- as.Date(timeDate::USLaborDay(this_year_seq))
    }
    if (hol_type == "columbus") {
        this_week_range <- 41:42
        if (first_week > 41) {
            first_year <- first_year + 1
        }
        if (last_week < 42) {
            last_year <- last_year - 1
        }
        this_year_seq <- seq(first_year, last_year)
        this_hol_dates <- as.Date(timeDate::USColumbusDay(this_year_seq))
    }
    if (hol_type == "veteran") {
        this_week_range <- 44:46
        if (first_week > 44) {
            first_year <- first_year + 1
        }
        if (last_week < 46) {
            last_year <- last_year - 1
        }
        this_year_seq <- seq(first_year, last_year)
        this_hol_dates <- as.Date(timeDate::USVeteransDay(this_year_seq))
    }
    if (hol_type == "thanksgiving") {
        this_week_range <- 46:48
        if (first_week > 46) {
            first_year <- first_year + 1
        }
        if (last_week < 48) {
            last_year <- last_year - 1
        }
        this_year_seq <- seq(first_year, last_year)
        this_hol_dates <- as.Date(timeDate::USThanksgivingDay(this_year_seq))
    }

    # if week range not set, generate error message as holiday type not defined
    if (is.null(this_week_range)) {
        stop("ERROR: Holiday type not found. Choices limited to newyears, mlk, president, easter, memorial, july4, labor, columbus, veteran, and thanksgiving.")
    }

    # if initialize holiday regressor, index vector
    this_hol_reg <- array(0, dim = length(this_week))
    this_index <- seq(1, length(this_week))

    # generate regressor for each year
    for (i in 1:length(this_year_seq)) {
        # Set date of start of holiday window
        this_day_start <- this_hol_dates[i] - hol_index + 1
        # initialize index for week range variable
        j <- 0
        # Go through range of weeks till the week the holiday window starts
        repeat {
            j <- j + 1
            this_filter <- (this_year == this_year_seq[i]) & (this_week == this_week_range[j])
            first_week_index <- this_index[this_filter]
            this_week_date <- as.Date(tis::ti(this_week)[first_week_index])
            this_date_diff <- as.numeric(this_week_date - this_day_start)
            if (this_date_diff > -1) {
                break
            }
        }
        # Set position of end of holiday window for this week
        k1 <- min(this_date_diff + 1, hol_n)
        # process weight vector to generate holiday regressor for this observation
        for (k in 1:k1) {
            this_hol_reg[first_week_index] <- this_hol_reg[first_week_index] + hol_wt[k]
        }
        # determine if holiday window continues into the next week
        if (hol_n > k1) {
            # update index
            first_week_index <- first_week_index + 1
            # process weight vector to generate holiday regressor for this observation
            for (k in seq(k1 + 1, hol_n)) {
                this_hol_reg[first_week_index] <- this_hol_reg[first_week_index] + hol_wt[k]
            }
        }
    }

    # return holiday regressor
    return(this_hol_reg)

}


#' dmrff.cohort
#'
#' Identify differentially methylated regions
#' within an individual dataset with a `pre` object.
#'
#' @param object Object generated by \code{\link{dmrff.pre}} for the dataset.
#' @param p.cutoff Unadjusted p-value cutoff for membership in a candidate DMR
#' (Default: 0.05).
#' @param maxgap Maximum distance between consecutive features (Default: 500bp).
#' @param verbose If \code{TRUE} (default), then output status messages.
#' @return A data frame listing all candidate regions and their summary statistics.
#'
#' @examples
#' pre <- dmrff.pre(est, se, p, meth, ...)
#' dmrs <- dmrff.cohort(pre)
#' dmrs[which(dmrs$p.adjust < 0.05 & dmrs$n > 1), ]
#'
#' @export
dmrff.cohort <- function(object, maxgap=500, p.cutoff=0.05, verbose=T) {
    if (!is.list(object)
        && all(c("estimate","se","chr","pos","sites","rho") %in% names(object)))
        stop("'object' was not created by dmrff.pre()")

    if (!("sd" %in% names(object))) ## if pre from older version of dmrff
        object$sd <- rep(1,length(object$se))

    idx <- order(object$chr, object$pos)
    sorted <- identical(idx, 1:length(idx))
    if (!sorted) { ## support for a previous version of dmrff that did not sort
        object$sites <- object$sites[idx]
        object$chr <- object$chr[idx]
        object$pos <- object$pos[idx]
        object$estimate <- as.numeric(object$estimate[idx])
        object$se <- as.numeric(object$se[idx])
        object$sd <- as.numeric(object$sd[idx])
    }
    ## scale summary stats as if methylation was standarized
    object$estimate <- object$estimate/object$sd
    object$se <- object$se/object$sd
    object$p.value <- 2*pnorm(abs(object$estimate/object$se), lower.tail=F)

    candidates <- dmrff.candidates(estimate=object$estimate,
                                   p.value=object$p.value,
                                   chr=object$chr,
                                   pos=object$pos,
                                   maxgap=maxgap,
                                   p.cutoff=p.cutoff,
                                   verbose=verbose)
    if (nrow(candidates) == 0) {
        return(NULL)
    }

    stats <- shrink.candidates(candidates$start.idx, candidates$end.idx,
                               function(start.idx,end.idx) {
                                   idx <- start.idx:end.idx
                                   if (length(idx) > ncol(object$rho)) return(0)
                                   ivwfe.getz(object$estimate[idx], object$se[idx],
                                              rho=extract.rho(object$rho[idx,,drop=F]))
                               })

    full <- do.call(rbind, parallel::mclapply(1:nrow(stats), function(i) {
        idx <- stats$start.idx[i]:stats$end.idx[i]
        if (length(idx) > ncol(object$rho)) return(c(B=0,S=1))
        ivwfe.stats(object$estimate[idx], object$se[idx],
                    rho=extract.rho(object$rho[idx,,drop=F]))
    }))

    stats$estimate <- stats$B <- full[,"B"]
    stats$se <- stats$S <- full[,"S"]

    collate.stats(stats, object$chr, object$pos, simple=!sorted)
}

extract.rho <- function(pre) {
    n <- nrow(pre)
    rho <- diag(x=1.05, n)
    if (n > 1)
        for (i in 1:(n-1)) {
            vals <- pre[i,1:(n-i)]
            rho[i,(i+1):n] <- vals
            rho[(i+1):n,i] <- vals
        }
    rho
}


# R version 3.3.2 (2016-10-31)
library(robustbase) #colmedians
library(stringr) #str_match
library(randomForest)
library(R.matlab) #readMat

train <- readRDS("landscape_features/processed/artificial.RDS")
test <- readRDS("landscape_features/processed/coco.RDS")

NUMBER_OF_ALGORITHMS = 1
TRIALS_PER_ALGORITHM = 2
NUMBER_OF_FOLDS = 10
NUMBER_OF_COLUMNS = NUMBER_OF_ALGORITHMS * TRIALS_PER_ALGORITHM
results_matrix = matrix(nrow=NUMBER_OF_FOLDS, ncol = NUMBER_OF_COLUMNS)
full_results <- list()
matrix_index <- 1
all_results <- list()
for (fold in 1:10){
  print(matrix_index)

  columns <- intersect(colnames(train), columns)
  columns <- c(columns, "class")
  columns <- setdiff(columns, "class.1")

  trainCols <- train[columns]
  train_data <- c()
  train_data$all <- train
  train_data$Cols <- trainCols

  #define models here
  rf_functional = train_ml(function(x){randomForest(class ~ ., data=x, ntree=1000)}, train_data)
  rf_results = test_ml(rf_functional, test, test, "rf", train_data)

  resultsRow <- c(rf_results)
  results_matrix[matrix_index, ] <- resultsRow$accuracy
  full_results[[matrix_index]] <- rf_results
  matrix_index <- matrix_index + 1

}

final_results <- colMeans(results_matrix) #accuracy
other_results <- calculate_accuracy_values(full_results) #f1, precision, and recall


source("http://www.bioconductor.org/biocLite.R")
#biocLite("affy")
#biocLite("limma")
#biocLite("hgu95acdf")

library("affy")
library("limma")
#library("hgu95acdf")

setwd("~/work/abe516/project1")
cwd = getwd()
raw = ReadAffy(celfile.path = "data")
probeNames(raw)[1:20]
geneNames(raw)[1:10]
#image(raw[,1])
hist(raw)
#boxplot(raw, col=c(2,2,3,3,4,4,5,5))
#par(mfrow=c(2,4))
#MAplot(raw, plot.method="smoothScatter")

# raw.bg=bg.correct(raw, "rma")
# raw.norm=normalize(raw.bg, "quantiles")
# hist(raw.norm, main = " raw data after RMA  BG & quantile normalization ")
# par(mfrow=c(2,4))
# MAplot(raw.norm, plot.method= "smoothScatter")
# raw.pm=pmcorrect.pmonly(raw.norm)
# eset <- computeExprSet(raw.norm, "pmonly","medianpolish")

eset <- expresso(raw,
                 bgcorrect.method = "rma",
                 normalize.method = "quantiles",
                 pmcorrect.method = "pmonly",
                 summary.method   = "medianpolish")
groups = c("C", "Bs", "Efs", "Efm")
fl <- factor(c(rep('0', 2), rep('1', 3), rep('2', 3), rep('3', 3), rep('0', 2)),
             labels=groups)
design <- model.matrix(~ 0 + fl)
colnames(design) = groups

fit <- lmFit(eset, design)

contrast.matrix <- makeContrasts(Efm-C, Bs-C, Efs-Bs, Efm-Efs, levels = design)

fit1 <- contrasts.fit(fit, contrast.matrix)
fit2 <- eBayes(fit1)

topTable(fit2, n = 10, adjust = "fdr")
topTable(fit2, coef = 1, n = 10, adjust = "fdr")
topTable(fit2, coef = 2, n = 10, adjust = "fdr")

modt = topTable(fit2,
                coef    = 1,
                sort.by = "t",
                adjust  = "fdr",
                number  = 10)[,c(1,3)]

logodds = topTable(fit2,
                   coef    = 1,
                   sort.by = "B",
                   adjust  = "fdr",
                   number  = 10)[,c(1,6)]

logFC = topTable(fit2,
                 coef    = 1,
                 sort.by = "logFC",
                 adjust  = "fdr",
                 number  = 10)[,c(1,3)]

results  = decideTests(fit2, adjust = "fdr", p = 0.05)
results2 = decideTests(fit2, adjust = "fdr", p = 0.005)

summary(results)
summary(results2)
p.value <-fit2$F.p.value

# i <- grep("AFFX", geneNames(raw))
# summary(p.value[i])

results <- classifyTestsF(fit2, p.value = 0.000001)
head(results)
summary(results)
vennDiagram(results)

table(efm.c=results[,1], bs.c=results[,2])

png(filename = file.path(cwd, "venn.png"), width = 400, height = 800)
par(mfrow = c(3, 1))
vennDiagram(results, main = "Diff Exp Genes")
vennDiagram(results, main = "Down", include = "down")
vennDiagram(results, main = "Up", include = "up")
dev.off()

png(filename = file.path(cwd, "volcano2.png"), width = 800, height = 800)
par(mfrow = c(2,2))
volcanoplot(fit2,
            coef=1,
            main="E_faecium-Control",
            names=row.names(fit2$coefficients),
            highlight=10)

volcanoplot(fit2,
            coef=2,
            main="B_subtilis-Control",
            names=row.names(fit2$coefficients),
            highlight=10)

volcanoplot(fit2,
            coef=3,
            main="E_faecium-B_subtilis",
            names=row.names(fit2$coefficients),
            highlight=10)

volcanoplot(fit2,
            coef=3,
            main="E_faecium-E_faecalis",
            names=row.names(fit2$coefficients),
            highlight=10)
dev.off()

# brain.up <- results[results[,1]==1, 1]
# brain.down <- results[results[,1]== -1,1 ]
# write.csv(data.frame(brain.up),file="myresults_brain_up.csv")
# write.csv(data.frame(brain.down),file="myresults_brain_down.csv")
#
# par(mfrow=c(1,2))
# volcanoplot(fit2,coef=1, main="brain",
#             names=row.names(fit2$coefficients), highlight=10)
# volcanoplot(fit2,coef=2, main="liver",
#             names=row.names(fit2$coefficients), highlight=10)


SELECT
	imp.dma as dma,
	imp.zip_code as zipcode,
	imp.region as region_name,
	imp.country as country_name,
	COUNT(DISTINCT(imp.mm_uuid)) as geo_uu,
	COUNT(DISTINCT(CASE WHEN evt.pixel_id=$pixel_id_1$ THEN evt.mm_uuid END)) as $pixel_name_1$,
	COUNT(DISTINCT(CASE WHEN evt.pixel_id=$pixel_id_2$ THEN evt.mm_uuid END)) as $pixel_name_2$,
	COUNT(DISTINCT(CASE WHEN evt.pixel_id=$pixel_id_3$ THEN evt.mm_uuid END)) as $pixel_name_3$,
	COUNT(DISTINCT(CASE WHEN evt.pixel_id=$pixel_id_4$ THEN evt.mm_uuid END)) as $pixel_name_4$
FROM
	(
		SELECT DISTINCT
			dma,
			zip_code,
			region,
			country,
			mm_uuid
		FROM
			mm_impressions_$ORG_ID$
		WHERE
			impression_date>="$start_date$"
		AND
			impression_date<="$end_date$"
		AND
			lower(country) LIKE "%united states%"
	) as imp
LEFT OUTER JOIN
	(
		SELECT DISTINCT
			pixel_id,
			mm_uuid
		FROM
			mm_attributed_events_$ORG_ID$
		WHERE
			event_date>="$start_date$"
		AND
			event_date<="$end_date$"
		AND
			pixel_id IN ($pixel_id_1$, $pixel_id_2$, $pixel_id_3$, $pixel_id_4$)
		AND
			event_type IN ($event_type_conversion$)
		AND
			lower(country) LIKE "%united states%"
	) as evt
ON
	imp.mm_uuid=evt.mm_uuid
GROUP BY
	imp.dma,
	imp.zip_code,
	imp.region,
	imp.country;


#' Generate signal extraction components
#'
#' Generates components from the decomposition of the fractional airline model R routines, partioning regression effects to different components as in \code{X-13ARIMA-SEATS}
#'
#' @param this_est A list object generated by the estimation procedure of the fractional airline model
#' @param this_decomp A list object generated by the decomposition procedure of the fractional airline model
#' @param this_xtype Character vector; Type of regressor used for including regression effects into components (\code{'hol'} for holiday, \code{'ao'} for point outliers, \code{'ls'} for level change outliers).
#' @param this_x Character vector; regression. Default: use the regression matrix in \code{this_est$model$X}.
#' @param this_log Logical scalar; set to TRUE if the log transformation is used in the decomposition, FALSE otherwise. Default: TRUE
#' @param this_stde Logical scalar; component standard error included in \code{this_decomp}. Default: FALSE.
#' @param tc2trend Logical scalar; TC outliers included in trend component if TRUE. Default: FALSE, TC outliers included in irregular.
#' @param remove_user Logical scalar; remove user-defined regression factors from seasonally adjusted series if TRUE. Default: FALSE, user defined regression factors included in seasonally adjusted series.
#' @return List of components from the fractional airline decomposition, partioning regression effects to different components as in \code{X-13ARIMA-SEATS}
#' @examples
#' ic_est <-
#'    rjd3highfreq::fractionalAirlineEstimation(ic_obs, periods=c(365.25/7),
#'                                       x=ic_default_matrix)
#' ic_decomp <-
#'    rjd3highfreq::fractionalAirlineDecomposition(ic_est$model$linearized,
#'                                          365.25/7, stde = TRUE)
#' ic_xtype <- c(rep('hol', 13), rep('ao', 40))
#' ic_comp <-
#'    gen_air_components(ic_est, ic_decomp,
#'                       this_xtype = ic_xtype,
#'                       this_log = FALSE,
#'                       this_stde = TRUE)
#' ic_comp_tis <- lapply(ic_comp, function(x)
#'    try(tis::tis(x, start = ic_start, tif = 'wsaturday')))
#' @import stats
#' @export
gen_air_components <- function(this_est, this_decomp, this_xtype, this_x = NULL,
                               this_log = TRUE, this_stde = FALSE, tc2trend = FALSE,
                               remove_user = FALSE) {
    # Author: Brian C. Monsell (OEUS), Version 4.0, 2/2/2022
    # set variables for the regression matrix and coefficient estimates
    if (is.null(this_x)) {
      this_x <- this_est$model$X
    }
    this_b <- this_est$model$b

    # generate filters for each type of regressors
    filter_hol <- this_xtype == "hol"
    filter_ao <- this_xtype == "ao"
    filter_ls <- this_xtype == "ls"
    filter_tc <- this_xtype == "tc"
    filter_user <- this_xtype == "user"

    n_hol <- sum(filter_hol)
    n_ao <- sum(filter_ao)
    n_ls <- sum(filter_ls)
    n_tc <- sum(filter_tc)
    n_user <- sum(filter_user)

    # generate default factor based on log vs no log
    this_y <- this_est$model$y
    this_length <- length(this_est$model$y)
    if (length(this_decomp$decomposition$y) > this_length) {
        this_y <-
            c(this_est$model$y,
              this_decomp$decomposition$y[(this_length+1):length(this_decomp$decomposition$y)])
        this_length <- length(this_y)
    }

    if (this_log) {
        this_default <- rep(1, length.out = this_length)
    } else {
        this_default <- rep(0, length.out = this_length)
    }

    # generate holiday factors
    if (n_hol > 0) {
        this_hol <- as.vector(this_x[, filter_hol] %*% matrix(this_b[filter_hol], ncol = 1))
        if (this_log) {
            this_hol <- exp(this_hol)
        }
    } else {
        this_hol <- this_default
    }

    # generate ao factors
    if (n_ao > 0) {
        this_ao <-
           as.vector(this_x[, filter_ao] %*% matrix(this_b[filter_ao], ncol = 1))
        if (this_log) {
            this_ao <- exp(this_ao)
        }
    } else {
        this_ao <- this_default
    }

    # generate ls factors
    if (n_ls > 0) {
        this_ls <-
           as.vector(this_x[, filter_ls] %*% matrix(this_b[filter_ls], ncol = 1))
        if (this_log) {
            this_ls <- exp(this_ls)
        }
    } else {
        this_ls <- this_default
    }

    # generate tc factors
    if (n_tc > 0) {
        this_tc <-
           as.vector(this_x[, filter_tc] %*% matrix(this_b[filter_tc], ncol = 1))
        if (this_log) {
            this_tc <- exp(this_tc)
        }
    } else {
        this_tc <- this_default
    }

    this_outlier <- this_default
    if (this_log) {
      if (n_ao > 0) { this_outlier <- this_outlier * this_ao }
      if (n_ls > 0) { this_outlier <- this_outlier * this_ls }
      if (n_tc > 0) { this_outlier <- this_outlier * this_tc }
    } else {
      if (n_ao > 0) { this_outlier <- this_outlier + this_ao }
      if (n_ls > 0) { this_outlier <- this_outlier + this_ls }
      if (n_tc > 0) { this_outlier <- this_outlier + this_tc }
    }

    # generate user factors
    if (n_user > 0) {
        this_user <-
           as.vector(this_x[, filter_user] %*% matrix(this_b[filter_user], ncol = 1))
        if (this_log) {
            this_user <- exp(this_user)
        }
    } else {
        this_user <- this_default
    }

    # generate trend component
    this_trend <- this_decomp$decomposition$t
    if (this_log) {
        this_trend <- exp(this_trend) * this_ls
    } else {
        this_trend <- this_trend + this_ls
    }

    # generate irregular component
    this_irr <- this_decomp$decomposition$i
    if (this_log) {
        this_irr <- exp(this_irr) * this_ao
    } else {
        this_irr <- this_irr + this_ao
    }

    # assign tc outliers to a component based on \code{tc2trend}
    if (tc2trend) {
      if (this_log) {
        this_trend <- exp(this_trend) * this_tc
      } else {
        this_trend <- this_trend + this_tc
      }
    } else {
      if (this_log) {
        this_irr <- exp(this_irr) * this_tc
      } else {
        this_irr <- this_irr + this_tc
      }
    }

    # generate seasonally adjusted series
    this_sa <- this_decomp$decomposition$sa
    if (this_log) {
        this_sa <- exp(this_sa) * this_ao * this_ls * this_tc
        if (remove_user) this_sa <- this_sa / this_user
    } else {
        this_sa <- this_sa + this_ao + this_ls + this_tc
        if (remove_user) this_sa <- this_sa - this_user
    }

    # generate seasonal and combinded factor component
    this_seasonal <- this_decomp$decomposition$s
    if (this_log) {
        this_seasonal <- exp(this_seasonal)
        this_combfac <- this_seasonal * this_hol
    } else {
        this_combfac <- this_seasonal + this_hol
    }

    # generate a list of components to return
    if (this_stde) {
        this_return <- list(y = this_est$model$y, trend = this_trend, seasonal = this_seasonal, irr = this_irr,
            adjfac = this_combfac, sa = this_sa, holiday = this_hol, ao = this_ao, ls = this_ls, tc = this_tc, outlier = this_outlier,
            user = this_user, trend_stde = this_decomp$decomposition$t.stde, seasonal_stde = this_decomp$decomposition$s.stde,
            irr_stde = this_decomp$decomposition$i.stde)
    } else {
        this_return <- list(y = this_est$model$y, trend = this_trend, seasonal = this_seasonal, irr = this_irr,
            adjfac = this_combfac, sa = this_sa, holiday = this_hol, ao = this_ao, ls = this_ls, tc = this_tc, outlier = this_outlier,
            user = this_user)
    }

    # return list of components
    return(this_return)

}


runDSS <- function() {

	options(warn = -1)

	cat("\n\n ================================================================")
	cat("\n ** Loading the required statistical software packages in R ..... \n \n")

	## load the library
	library(MSstats)

	## save sessionInfo as .txt file
	session <- sessionInfo()
	sink("sessionInfo.txt")
	print(session)
	sink()

	## Input data
	arguments <- commandArgs(trailingOnly=TRUE);
	# arguments--> C:\Users\Ijae\AppData\Local\Temp\MSstats_Design_Sample_Size_MSstats_Input.csv 1 2 1 1 TRUE 0.05 1.25 1.75

	## test argument
	#cat("arguments--> ")
	#cat(arguments)
	#cat("\n")

	## put argument
	#arguments <- c("address", "TRUE", "1", "1", "0.80", "0.05", "1.25", "1.75")

	cat("\n\n =======================================")
	cat("\n ** Reading the data for MSstats..... \n")

	raw <- read.csv(arguments[1])

	## remove the rows for iRT peptides
	#raw <- raw[is.na(raw$StandardType) | raw$StandardType != "iRT", ]

	## get standard protein name from StandardType column
	standardpepname <- ""
	if (sum(unique(raw$StandardType) %in% "Normalization") != 0) {
		standardpepname <- as.character(unique(raw[raw$StandardType == "Normalization", "PeptideModifiedSequence"]))
	}

	## change column name 'Area' as Intensity
	#colnames(raw)[colnames(raw) == "Area"] <- "Intensity"
	#raw$Intensity <- as.character(raw$Intensity)
	#raw$Intensity <- as.numeric(raw$Intensity)

	## change column name 'FileName' as Run
	#colnames(raw)[colnames(raw) == "FileName"] <- "Run"

	## check result grid missing or not
	countna <- apply(raw, 2, function(x) sum(is.na(x) | x == ""))
	naname <- names(countna[countna != 0])
	naname <- naname[-which(naname %in% c("StandardType", "Intensity", "Truncated"))]

	if (length(naname) !=0 ) {
		stop(message(paste("Some ", paste(naname,collapse=", "), " have no value. Please check \"Result Grid\" in View.", sep="")))
	}

	## -----------------------------------------------
	## formatting
	cat("\n\n =======================================")
	cat("\n ** Formatting for MSstats..... \n")

	## check result grid missing or not
	info <- unique(raw[, c('Condition', 'BioReplicate')])

	if(any(is.na(info))){
	  stop(message("Some of Condition and/or BioReplicate have no value. Please check \"Result Grid\" in View. \n"))
	}

	raw <- SkylinetoMSstatsFormat(raw, filter_with_Qvalue = FALSE)
	## need to be updated for Qvalue filtering for DIA

	## -----------------------------------------------
	## Function: dataProcess
	## pre-processing data: quality control of MS runs
	## -----------------------------------------------

	cat("\n\n =======================================")
	cat("\n ** Data Processing for analysis..... \n")

	optionnormalize <- arguments[2]

	## first check name of global standard
	#if(optionnormalize==3 & is.null(standardpepname)){
	#	stop(message("Please assign the global standards peptides for normalization using standard proteins."))
	#}

	## input is character??
	if (optionnormalize == 0) {
		inputnormalize <- FALSE
	}
	if (optionnormalize == 1) {
		inputnormalize <- "equalizeMedians"
	}
	if (optionnormalize == 2) {
		inputnormalize <- "quantile"
	}
	if (optionnormalize == 3) {
		inputnormalize <- "globalStandards"
	}
	if (optionnormalize != 0 & optionnormalize != 1 & optionnormalize != 2 & optionnormalize != 3){
		inputnormalize <- FALSE
	}

	inputmissingpeaks <- arguments[8]

	## feature selection input

	optionfeatureselection <- arguments[9]

	if (optionfeatureselection == "TRUE") {
		input_feature_selection <- "highQuality"
	} else {
		input_feature_selection <- "all"
	}

	## Nick, here for new option for 'allow...'
	## remove proteins with interference cbox

	inputremoveproteins <- arguments

	## censoring algorithm for only label-free
	if( is.element('heavy', unique(raw$IsotopeLabelType)) ){
	  maxQuantile <- NULL
	} else {
	  maxQuantile <- 0.999
	}

	quantData <- try(dataProcess(raw, normalization=inputnormalize, nameStandards=standardpepname,  fillIncompleteRows=(inputmissingpeaks=="TRUE"), featureSubset=input_feature_selection, remove_proteins_with_interference=(inputremoveproteins=="TRUE"), summaryMethod = "TMP", censoredInt="0", maxQuantileforCensored = maxQuantile))

	if (class(quantData) != "try-error") {

		allfiles <- list.files()
		num <- 0
		filenaming <- "dataProcessedData"
		finalfile <- "dataProcessedData.csv"

		while (is.element(finalfile, allfiles)) {
			num <- num + 1
			finalfile <- paste(paste(filenaming, num, sep="-"), ".csv", sep="")
		}

		write.csv(quantData$ProcessedData, file=finalfile)
		cat("\n Saved dataProcessedData.csv \n")
	} else {
		stop(message("\n Error : Can't process the data. \n"))
	}

	## --------------------------------------------------------------------
	## Function: groupComparison
	## generate testing results of protein inferences across concentrations
	## --------------------------------------------------------------------

	## any comparison is fine in order to get variance component.

	alllevel <- levels(quantData$ProcessedData$GROUP_ORIGINAL)

	comparison <- matrix(rep(0, times=length(alllevel)), nrow=1)
	comparison[1] <- 1
	comparison[2] <- (-1)
	row.names(comparison) <- c("Disease-Healthy")

	## then testing with inputs from users
	cat("\n\n ============================")
	cat("\n ** Getting variance components... \n \n")

	## here is the issues : labeled, and interference need to be binary, not character
	resultComparison <- try(groupComparison(contrast.matrix=comparison, data=quantData))

	if (class(resultComparison) == "try-error") {
		cat("\n Error : Can't get variance components. \n")
	}

	## ---------------------------------------------------------------------------
	## Function: designSampleSize
	## calulate number of biological replicates per group for your next experiment
	## ---------------------------------------------------------------------------

	cat("\n\n =======================================")
	cat("\n ** Calculating sample size..... \n")

	## input for options
	## num of sample?
	## cat("\n Number of Biological Replicates :  ")
	inputnsample <- arguments[3]
	if (inputnsample == "TRUE") {
		inputnsample <- TRUE
	}
	if (inputnsample != "TRUE") {
		inputnsample <- as.numeric(inputnsample)
	}
	if (inputnsample == "") {
		inputnsample <- TRUE
	}

	## num of peptide?
	## cat("\n Number of Peptides per protein :  ")

	## power?
	## cat("\n power : ")
	inputpower <- arguments[4]
	if (inputpower == "TRUE") {
		inputpower <- TRUE
	}
	if (inputpower != "TRUE") {
		inputpower <- as.numeric(inputpower)
	}
	if (inputpower == "") {
		inputpower <- TRUE
	}

	## FDR?
	## cat("\n FDR : (Default is 0.05)")
	inputfdr <- arguments[5]
	if (inputfdr == "TRUE") {
		inputfdr <- 0.05
	}
	inputfdr <- as.numeric(inputfdr)

	## desiredFC?
	## cat("\n lower desired Fold Change : (Default is 1.25) ")
	inputlower <- arguments[6]
	if (inputlower == "TRUE") {
		inputlower <- 1.25
	}
	inputlower <- as.numeric(inputlower)

	#cat("\n upper desired Fold Change : (Default is 1.75)")
	inputupper <- arguments[7]
	if (inputupper == "TRUE") {
		inputupper <- 1.75
	}
	inputupper <- as.numeric(inputupper)

	## if t-test, can't sample size calculation
	countnull <- 0

	for (k in 1:length(resultComparison$fittedmodel)) {
		if (is.null(resultComparison$fittedmodel[[k]])) {
			countnull <- countnull + 1
		}
	}

	if(countnull == length(resultComparison$fittedmodel)){
		stop(message("\n Can't calculate sample size with log sum method. \n"))
	}

	result.sample <- try(designSampleSize(data=resultComparison$fittedmodel, numSample=inputnsample, desiredFC=c(inputlower, inputupper), FDR=inputfdr, power=inputpower))
	#result.sample <- designSampleSize(data=quantData,numSample=TRUE,desiredFC=c(1.25,1.75),FDR=0.05,power=0.8)

	if (class(result.sample) != "try-error") {

		allfiles <- list.files()
		num <- 0
		filenaming <- "SampleSizeCalculation"
		finalfile <- "SampleSizeCalculation.csv"

		while (is.element(finalfile, allfiles)) {
			num <- num + 1
			finalfile <- paste(paste(filenaming, num, sep="-"), ".csv", sep="")
		}

		write.csv(result.sample, file=finalfile)
		cat("\n Saved the Sample Size Calculation. \n")
	} else {
		stop(message("\n Error : Can't analyze. \n"))
	}

	## -----------------------------------------
	## Function: designSampleSizePlots
	## visualization for sample size calculation
	## -----------------------------------------

	if (class(result.sample) != "try-error") {

		allfiles <- list.files()
		num <- 0
		filenaming <- "SampleSizePlot"
		finalfile <- "SampleSizePlot.pdf"

		while(is.element(finalfile, allfiles)){
			num <- num + 1
			finalfile <- paste(paste(filenaming, num, sep="-"), ".pdf", sep="")
		}

		pdf(finalfile)
		designSampleSizePlots(data=result.sample)
		dev.off()
		cat("\n Saved SampleSizePlot.pdf \n \n")
	}
}

temp <- try(runDSS())

if (class(temp) != "try-error") {
	cat("\n Finished.")
} else {
	cat("\n Can't finish analysis.")
}


choose.transition.matrix = function(tm, region, threshold.to.delete=5, use.global.average=T) {

    eps = 1e-2
    trim = 0

      tm[ !is.finite(tm) ] = NA
      tm[ tm > threshold.to.delete ] = NA  # large estimates in transfer function is not believable
      tm[ tm < eps ] = NA  # very small estimates in transfer function are temporarily not trusted

      xm = tm[,,,region]

      # region specific values
      XMm = apply(xm, c(1,2), function(b) {  mean( b, na.rm=T)  } )
      XMmn = apply(xm, c(1,2), function(b) { length( b[is.finite(b)] ) } )
      XMmsd = apply(xm, c(1,2), function(b) {  sd (b, na.rm=T) } )

      XM = XMm
      XMsd = XMmsd

      # shelf-wide averages
      XMg = apply(tm, c(1,2), function(b) { mean( b, na.rm=T) } )
      XMng = apply(tm, c(1,2), function(b) { length( b[is.finite(b)] ) } )
      XMsdg = apply(tm, c(1,2), function(b) { sd( as.vector(b), na.rm=T)  } )

      if (use.global.average)  {
        XM = XMg
        XM[ !is.finite( XM ) ] = 0
        XMsd = XMsdg
        XMsd[ !is.finite( XMsd ) ] = 0
      } else {
        iii = which( !is.finite( XM )| (XM <= eps) )
        XM[ iii ] = XMg [iii]  # try using shelf-wide means when no recent data exists
        XM[ !is.finite( XM ) ] = 0

        jjj = which( !is.finite( XMsd )| (XM < eps) )
        XMsd[ iii ] = XMsdg [iii]  # try using shelf-wide se when no recent data exists
        XMsd[ !is.finite( XMsd ) ] = 0
       }

  return (list( XM=XM, XMsd=XMsd) )

  }


library(docopt)

doc <- "Usage:
test.r --bamFile <FILE> --outputDir <DIR> --windowSize <SIZE>
runMedips.r --bamFile=FILE --outputDir=DIR --windowSize=SIZE
--bamFile FILE       Aligned, sorted, filtered reads (bam) [default: ]
--outputDir DIR      Path to output folder [default: ]
--windowSize SIZE    Size of genomic windows (bp) [default: ]
--help               show this help text"
opt <- docopt(doc)

if (!file.exists(opt$bamFile)){
  stop(paste0("ERROR: bam file not found ",opt$bamFile), call.=FALSE)
}
if (!file.exists(opt$outputDir)){
  dir.create(opt$outputDir)
}

library(MEDIPS)
library(BSgenome.Hsapiens.UCSC.hg38)

BSgenome="BSgenome.Hsapiens.UCSC.hg38"
uniq=0 ####WARNING: default settings normalize the data, must be set to 0 to disable this transformation
extend=0 #relevant for single-end: https://support.bioconductor.org/p/81098/
shift=0
ws=as.numeric(opt$windowSize)
paired=TRUE

# Disables the scientific notation to avoid powers in genomic coordinates (i.e. 1e+10)
options(scipen = 999)

chr.select=paste0("chr",c(1:22,"X","Y"))

message("MEDIPS: ws:",ws)
MeDIPset = MEDIPS.createSet(file = opt$bamFile,BSgenome = BSgenome, extend = extend, shift = shift, paired=paired, uniq = uniq, window_size = ws,chr.select=chr.select)

fname<-unlist(strsplit(basename(opt$bamFile),split="\\."))[1]
if(!dir.exists(opt$outputDir)){dir.create(opt$outputDir)}

pos.start<-c()
pos.end<-c()
pos.chr<-c()
for(i in 1:length(chr.select)){
  no.window<-ceiling(MeDIPset@chr_lengths[i]/ws)
  pos.chr<-c(pos.chr,rep(chr.select[i],no.window))
  pos.start<-c(pos.start,seq(from=1,to=((no.window-1)*ws)+1,by=ws))
  pos.end<-c(pos.end,seq(from=ws,to=no.window*ws,by=ws))
}
pos.chr<-data.frame(pos.chr)
pos.start<-data.frame(pos.start)
pos.end<-data.frame(pos.end)
genome.counts<-data.frame(MeDIPset@genome_count)

df.counts<-cbind(pos.chr,pos.start,pos.end,genome.counts)
file.counts<-paste0(opt$outputDir,"/MEDIPS_hg38_",fname,"_ws",ws,"_count.txt")
write.table(df.counts,file.counts,row.names=F,quote=F,col.names=F)
system(paste0("gzip -f ",file.counts))

file.rms<-paste0(opt$outputDir,"/MEDIPS_hg38_",fname,"_ws",ws,"_rms.txt")
#coupling set: maps CG densities across the genome
CS=MEDIPS.couplingVector(pattern="CG", refObj=MeDIPset)
df.rms<-NULL
tryCatch({
  #####MEDIPS.set(MeDIP=true,...) performs CpG density normalization (rms: relative methylation score)
  MEDIPSset.meth=MEDIPS.meth(MSet1 = MeDIPset, CSet = CS,MeDIP=TRUE)
  MEDIPS.rms<-MEDIPSset.meth[,paste0(gsub("-",".",basename(opt$bamFile)),".rms")]
  df.rms<-MEDIPSset.meth[,c('chr','start','stop',paste0(gsub("-",".",basename(opt$bamFile)),".rms"))]
},error=function(e){
  message("Error: MEDIPS CpG density normalization failed due to small number of reads")
})
if(is.null(df.rms)){df.rms<-("#Error: MEDIPS CpG density normalization failed due to small number of reads")}
write.table(df.rms,file.rms,row.names=F,quote=F,col.names=F)
system(paste0("gzip -f ",file.rms))

#CpG enrichment: this function of MEDIPS is brokent, depends on obsolete code
#Performance can be improved, it currently generates its own MEDIPS.set (previously done!)
#er <- MEDIPS.CpGenrich(file=opt$bamFile, BSgenome=BSgenome, extend=extend, shift=shift, uniq=uniq, chr.select=chr.select, paired=paired)
#df.er<-data.frame(matrix(unlist(er), nrow=length(1)))
#colnames(df.er)<-names(er)
#df.er<-cbind(sample=fname,df.er)
#file.er<-paste0(opt$outputDir,"/MEDIPS_hg38_",fname,"_CpGenrich.txt")
#write.table(df.er,file.er,row.names=F,quote=F,col.names=F)