#!/usr/bin/env Rscript
#
# Extract means and HPD intervals for PGE, PVE, and n_gamma
#

library(coda)
library(data.table)

argv = commandArgs(trailingOnly=TRUE)

thin = as.numeric(argv[2])
input_prefix = argv[1]
infiles = list.files(dirname(input_prefix),
                     pattern=paste0('^', basename(input_prefix)),
                     full.names=TRUE)
infiles = infiles[grepl('.hyp.txt', infiles)]

make_vec = function() numeric(length(infiles))
stats = data.frame('run'=make_vec(),
                   'pve_95_l'=make_vec(),
                   'pve_95_h'=make_vec(),
                   'pve_mean'=make_vec(),
                   'pge_95_l'=make_vec(),
                   'pge_95_h'=make_vec(),
                   'pge_mean'=make_vec(),
                   'ng_95_l'=make_vec(),
                   'ng_95_h'=make_vec(),
                   'ng_mean'=make_vec(),
                   'lmm_pve'=make_vec())
for(f in infiles) {
    run_number = as.numeric(gsub('\\.hyp\\.tx.+', '',
                                 gsub(input_prefix, '', f)))
    if(grepl('\\.gz$', f)) {
        x = fread(paste('zcat', f))
    } else {
        x = fread(f)
    }

    mcmc_data = as.mcmc(x, start=1, end=thin*nrow(x),
                        thin=thin)
    hpd_95 = HPDinterval(mcmc_data, 0.95)
    means = colMeans(x)

    stats[run_number+1, 'pve_95_l'] = hpd_95['pve', 'lower']
    stats[run_number+1, 'pve_95_h'] = hpd_95['pve', 'upper']
    stats[run_number+1, 'pge_95_l'] = hpd_95['pge', 'lower']
    stats[run_number+1, 'pge_95_h'] = hpd_95['pge', 'upper']
    stats[run_number+1, 'ng_95_l'] = hpd_95['n_gamma', 'lower']
    stats[run_number+1, 'ng_95_h'] = hpd_95['n_gamma', 'upper']
    stats[run_number+1, 'pve_mean'] = means['pve']
    stats[run_number+1, 'pge_mean'] = means['pge']
    stats[run_number+1, 'ng_mean'] = means['n_gamma']
    stats[run_number+1, 'run'] = run_number

    log_file = gsub('\\.hyp\\.tx.+', '.log.txt', f)
    l = scan(log_file, what='character', sep='\n', quiet=TRUE)
    stats[run_number+1, 'lmm_pve'] =
        as.numeric(gsub('.+= ', '', l[grepl('pve', l)][1]))

    cat('Done with', run_number, '\n', file=stderr())
}

stats = stats[order(stats[, 'run']), ]

write.table(stats, file=stdout(), sep='\t', col.names=TRUE,
            row.names=FALSE, quote=FALSE)


#!/usr/bin/Rscript

## icdiff.r -- Calculate information content difference for
## fastphase-formatted genotype file

## Author: David Eccles (gringer), 2008 <programming@gringer.org>

usage <- function(){
  cat("usage: ./icdiff.r","<input file> <output file>\n");
  cat("\nOther Options:\n");
  cat("-help               : Only display this help message\n");
  cat("-hapmap3            : Hapmap phase 3 formatted Files\n");
  cat("\n");
}

infile.name <- FALSE;
outfile.name <- FALSE;
hapmap3 <- FALSE;

argLoc <- 1;
while(!is.na(commandArgs(TRUE)[argLoc])){
  if(file.exists(commandArgs(TRUE)[argLoc])){ # file existence check
    if(infile.name == FALSE){
      infile.name <- commandArgs(TRUE)[argLoc];
    } else {
      cat("Error: More than one existing [input] file specified\n");
      usage();
      quit(save = "no", status=1);
    }
  } else {
    if(commandArgs(TRUE)[argLoc] == "-help"){
      usage();
      quit(save = "no", status=0);
    } else if(commandArgs(TRUE)[argLoc] == "-hapmap3"){
      hapmap3 <- TRUE;
    } else {
      outfile.name <- commandArgs(TRUE)[argLoc];
    }
  }
  argLoc <- argLoc + 1;
}

if((infile.name == FALSE) || (outfile.name == FALSE)){
  cat("Error: No valid input/output file name given\n\n");
  usage();
  quit(save = "no", status=1);
}

## max(table(apply(head(gt.df,33), 2, paste, collapse = ""))) == 1;

## # show heatmap of first 33 genotypes (at start of chromosome 21)
## heatmap(t(head(gt.df,33)), scale = "none", Colv = NA);

## dist.ind <- as.matrix(dist(t(gt.df), method = "manhattan"))
## diag(dist.ind) <- NA;

## ## because of recombination, bits of one parent will be scattered
## ## through each chromosome, so the differences will even out over
## ## large stretches of the chromosome, so differences between each
## ## homologous chromosome and chromosomes from other people will
## ## balance out.
## heatmap(as.matrix(dist.ind), col = topo.colors(100), symm = TRUE)

## information content of some split with counts A1,A2,An:
## let P(An) = An / Sum(A1..An)
## Ic = Sum(-P(An) * log(An,2))
## [Russell, pages 659-660]

## What I want is the difference between the maximum split and the
## actual split. Sum that, and it should give an indication of the
## prevalence of particular haplotypes over others (i.e. extended
## haplotype homozygosity).

## Need to make sure it continues for at least log(n) iterations,
## because until then, we don't know if a haplotype is more prevalent
## than expected in the random case.

## this spreads out in both directions, averaging one choosing to go
## left first and one choosing to go right first

icDiffSum <- function(genotype.matrix, location, constrain = TRUE){
  if(is.null(dim(genotype.matrix))){
    dim(genotype.matrix) <- c(length(genotype.matrix),1);
  }
  ic.target <- log(dim(genotype.matrix)[1],2);
  num.haplotypes <- dim(genotype.matrix)[1];
  ic.diffs.left <- NULL;
  lengths.left <- NULL;
  ic.diffs.right <- NULL;
  lengths.right <- NULL;
  for(leftBias in c(TRUE, FALSE)){
    goLeft <- leftBias;
    diffpos <- 1;
    ic.value <- 0;
    loc.left <- location;
    loc.right <- location;
    while(ic.value < ic.target){
      if(constrain){
        ## constrain information content to maximum possible with
        ## given number of haplotypes
        ic.max <- min(((loc.right - loc.left) + 1), ic.target);
      } else {
        ic.max <- (loc.right - loc.left) + 1;
      }
      ## warning: null genotypes appear as genotype "NA"
      if(loc.right != loc.left){
        prob.hap <- table(apply(genotype.matrix[,loc.left:loc.right],
                                1, paste, collapse = "")) / num.haplotypes;
      } else {
        prob.hap <- table(genotype.matrix[,loc.left]) / num.haplotypes;
      }
      ic.value <- sum(-prob.hap * log(prob.hap,2));
      ##print(paste(leftBias, " -> ", ic.value));
      if(leftBias == TRUE){
        ic.diffs.left[diffpos] <- (ic.max - ic.value) / ic.max;
        lengths.left[diffpos] <- (loc.right-loc.left) + 1;
      } else {
        ic.diffs.right[diffpos] <- (ic.max - ic.value) / ic.max;
        lengths.right[diffpos] <- (loc.right-loc.left) + 1;
      }
      diffpos <- diffpos + 1;
      ## Extra logic to make sure it doesn't duplicate results by
      ## hanging in the same place for two iterations. These two
      ## 'goLeft' cases could be combined, but it makes the code less
      ## clear.
      if(goLeft){
        goLeft <- !goLeft; # i.e. goLeft <- FALSE
        if(loc.left > 1){
          loc.left <- max(1,loc.left - 1);
        } else {
          loc.right <- min(dim(genotype.matrix)[2],loc.right + 1);
        }
      } else {
        goLeft <- !goLeft; # i.e. goLeft <- TRUE
        if(loc.right < dim(genotype.matrix)[2]){
          loc.right <- min(dim(genotype.matrix)[2],loc.right + 1);
        } else {
          loc.left <- max(1,loc.left - 1);
        }
      }
      if((loc.left == 1) && (loc.right == dim(genotype.matrix)[2])){
        ## if the entire chromosome is covered, do no more
        ic.value <- ic.target;
      }
    }
  }
  ## print(rbind(round(lengths.left,5),round(ic.diffs.left,5)));
  ## print(rbind(round(lengths.right,5),round(ic.diffs.right,5)));
  return((sum(ic.diffs.left) + sum(ic.diffs.right))/2);
}

oldicDiffSum <- function(genotype.matrix){
  ic.diffs <- NULL;
  ic.diff <- 1;
  ic.value <- 0;
  x <- 1;
  if(is.null(dim(genotype.matrix))){
    dim(genotype.matrix) <- c(1,length(genotype.matrix));
  }
  ic.target <- log(dim(genotype.matrix)[2],2);
  while((ic.value < ic.target) && (x <= dim(genotype.matrix)[1])){
    ic.max <- min(x,ic.target);
    counts.hap <- table(apply(head(genotype.matrix,x), 2, paste, collapse = ""));
    prob.hap <- counts.hap / sum(counts.hap);
    ic.value <- sum(-prob.hap * log(prob.hap,2));
    ic.diff <- ((ic.max - ic.value) / ic.max);
    ic.diffs <- c(ic.diffs,ic.diff);
    x <- x+1;
  }
  return(sum(ic.diffs));
}

gtval <- function(x){
  if((is.matrix(x)) || (is.data.frame(x))){
    apply(x,2,function(data){
      as.numeric(sub("A|T",1,sub("G|C",2,data)));
    });
  } else if(is.vector(x)) {
    as.numeric(sub("A|T",1,sub("G|C",2,x)));
  } else {
    if((x = "A") || (x = "T")){
      1;
    } else if((x = "C") || (x = "G")){
      2;
    } else {
      0;
    }
  }
}

## ## The following test suggests that this algorithm is tractable and
## ## shouldn't need further optimisations:

## ## 1) It is linear in complexity for number of markers [O(n)]

## system.time(for(x in 1:10){oldicDiffSum(gt.df[-(1:x),])})
## ##   user  system elapsed
## ##  2.120   0.028   2.267
## system.time(for(x in 1:100){oldicDiffSum(gt.df[-(1:x),])})
## ##   user  system elapsed
## ## 17.393   0.240  17.688

## ## 2) Estimated runtime for chromosome 21 is less than half an
## ##    hour (actually, 16 minutes, 5435 markers)

## ## > (5435/100 * 17.393) / 60
## ## [1] 15.75516

## ## [Estimated runtime for chromosome 1 is about 1.5 hours, 23062
## ## markers]

cat("Retrieving data for chromosome ...");
inFile <- gzfile(infile.name);
open(inFile);
lineRead <- "";
if(!hapmap3){
  while(lineRead != "BEGINGENOTYPES"){ # read until genotype start
    lineRead <- paste(scan(inFile, nlines = 1,
                           what = character(0),
                           quiet = TRUE)[1:2], collapse = "");
  }
  lineRead <- "";
  person.id <- "";
  gt.df <- NULL;
  while(lineRead != "END GENOTYPES"){ # read until genotype end
    lineRead <- readLines(inFile, n = 1, warn = FALSE);
    if(substr(lineRead,3,4) == "id"){
      person.id <- substr(lineRead,6,nchar(lineRead));
      hap.1 <- scan(inFile, nlines = 1, quiet = TRUE);
      hap.2 <- scan(inFile, nlines = 1, quiet = TRUE);
      new.df <- cbind(hap.1, hap.2);
      colnames(new.df) <- paste(person.id,c(1,2), sep = ".");
      gt.df <- cbind(gt.df,new.df);
    }
  }
  colnames(gt.df) <- sub("0+([0-9][0-9]\\.)","\\1",
                         colnames(gt.df), perl=TRUE);
  gt.df <- t(gt.df);
} else { # if hapmap3-formatted input (but no header)
  gt.df <- read.table(inFile, row.names = 1, header = FALSE);
  gt.df <- gt.df[,-1];
  marker.names <- rownames(gt.df);
  gt.df <- data.frame(t(gt.df));
}
close(inFile);
cat("done\n");
cat("Calculating distance matrix to eliminate identical chromosomes...");
if(hapmap3){
  dist.ind <- as.matrix(dist(gtval(gt.df), method = "manhattan"));
} else {
  dist.ind <- as.matrix(dist(gt.df), method = "manhattan");
}
remove.columns <- NULL;
for(haplotype in 1:(dim(gt.df)[1])){
  ## if fewer than 20 differences, treat as the same chromosome
  ## this allows for some genotyping error
  if(length(which(which(dist.ind[haplotype,] < 20) > haplotype) > 0)){
    remove.columns <- c(remove.columns, (which(dist.ind[haplotype,] < 20))
                        [which(dist.ind[haplotype,] < 20) > haplotype]);
  }
}
if(length(remove.columns) > 0){
  gt.df <- gt.df[,-remove.columns];
}
cat("done (",length(unique(remove.columns))," columns removed)\n",sep="");
outFile <- file(outfile.name);
open(outFile, open = "w");
for(marker in 1:(dim(gt.df)[2])){
  cat(colnames(gt.df)[marker]," ",icDiffSum(gt.df, marker),
      "\n", file = outFile, sep = "");
}
close(outFile);


pdf_file<-"pdf/networks_chord_diagram.pdf"
cairo_pdf(bg="grey98", pdf_file, width=8,height=8)
par(omi=c(0.25,0.25,0.5,0.25), mai=c(0,0,0,0), family="Lato Light")

library(circlize)
library(RColorBrewer)
library(readr)
library(sqldf)

# Import data and prepare chart

df0 <- read_csv("myData/2010 GIM data.csv")
df1 <- read_csv("myData/2010 GIM data lookup.csv")

bulas <- read_csv("data/bulas.csv")
kreise<-sqldf("select min(kreis_destatis/1000) bula, hk_id from df1 group by hk_id")

df_bula<-sqldf("select a.bula bula_destination, b.* from kreise a, df0 b where a.hk_id = b.destination_hk")
df_bula<-sqldf("select a.bula bula_origin, b.* from kreise a, df_bula b where a.hk_id = b.origin_hk")
df_bula<-sqldf("select bula_origin, bula_destination, sum(t_total) t_total from df_bula group by bula_origin, bula_destination")
df_bula<-sqldf("select a.bula bula_origin_name, b.bula_destination, b.t_total from bulas a, df_bula b where a.nr = b.bula_origin")
df_bula<-sqldf("select b.bula_origin_name, a.bula bula_destination_name, b.t_total/1000 t_total from bulas a, df_bula b where a.nr = b.bula_destination")
df_bula<-df_bula[df_bula$t_total>15, ]
df_bula<-df_bula[df_bula$bula_origin!=df_bula$bula_destination, ]

circos.clear()
circos.par(start.degree = 90, gap.degree = 4, track.margin = c(-0.1, 0.1), points.overflow.warning = FALSE)
par(mar = rep(0, 4))

# Create chart

chordDiagram(x = df_bula, grid.col = brewer.pal(length(unique(df_bula$bula_origin)), "Spectral"), transparency = 0.25,
             directional = 1,
             direction.type = c("arrows", "diffHeight"), diffHeight  = -0.04,
             annotationTrack = c("grid", "name", "axis"), annotationTrackHeight = c(0.05, 0.1),
             link.arr.type = "big.arrow", link.sort = TRUE, link.largest.ontop = TRUE)

# Titling

mtext("Migration between states 2010", adj=0, cex=2, family="Lato Black", col="grey40", outer=T)
mtext("all migrations over 15,000 persons, without internal migration, data in thousands", line=-1.25, adj=0, cex=0.9, family="Lato Bold", col="grey40", outer=T)
mtext("Source: www.nikolasander.net/news/diy", side=1, line=-1, adj=1, cex=0.9, font=3, outer=T)

circos.clear()
dev.off()


# Master Thesis Project - Extreme Value Theory
# Illustrating the sequence of maxima with a real
# world example : the evolution of the prices of
# shares of 5 companies listed on CAC40.
# Killian Martin--Horgassan
# 19-02-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("/Users/kimartin/Desktop/R_files_pdm/Tache2/InputCAC40_illustration.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache2/ExtractMaxima.r")

# Loading the data into variables
BNP <- read.csv("BNP_Paribas.csv", header = FALSE)
Carrefour <- read.csv("Carrefour.csv", header = FALSE)
LVMH <- read.csv("LVMH.csv", header = FALSE)
Sanofi <- read.csv("Sanofi.csv", header = FALSE)
Total <- read.csv("Total.csv", header = FALSE)
Weekly_BNP <- read.csv("WeeklyBNP.csv", header = FALSE)
Weekly_Carrefour <- read.csv("WeeklyCarrefour.csv", header = FALSE)
Weekly_LVMH <- read.csv("WeeklyLVMH.csv", header = FALSE)
Weekly_Sanofi <- read.csv("WeeklySanofi.csv", header = FALSE)
Weekly_Total <- read.csv("WeeklyTotal.csv", header = FALSE)

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume

# The user may choose which option between Open -> Close
CHOICE <- as.numeric(InputCAC40_illustration())

# Building the vectors of successive maxima
# rev is used as the original data is newest -> oldest
BNP_max <- ExtractMaxima(rev(BNP[[CHOICE]]))
Carrefour_max <- ExtractMaxima(rev(Carrefour[[CHOICE]]))
LVMH_max <- ExtractMaxima(rev(LVMH[[CHOICE]]))
Sanofi_max <- ExtractMaxima(rev(Sanofi[[CHOICE]]))
Total_max <- ExtractMaxima(rev(Total[[CHOICE]]))
Weekly_BNP_max <- ExtractMaxima(Weekly_BNP[[CHOICE]])
Weekly_Carrefour_max <- ExtractMaxima(Weekly_Carrefour[[CHOICE]])
Weekly_LVMH_max <- ExtractMaxima(Weekly_LVMH[[CHOICE]])
Weekly_Sanofi_max <- ExtractMaxima(Weekly_Sanofi[[CHOICE]])
Weekly_Total_max <- ExtractMaxima(Weekly_Total[[CHOICE]])

# Plotting the successive maxima

# BNP monthly - weekly ; Jan 2001 - Jan 2015
quartz()
par(mfrow = c(1,2))
plot(BNP_max, pch = 1, col = "black")
plot(Weekly_BNP_max, pch = 1, col = "black")

# Carrefour monthly - weekly ; Jan 2001 - Jan 2015
quartz()
par(mfrow = c(1,2))
plot(Carrefour_max, pch = 1, col = "blue")
plot(Weekly_Carrefour_max, pch = 1, col = "blue")

# LVMH monthly - weekly ; Jan 2001 - Jan 2015
quartz()
par(mfrow = c(1,2))
plot(LVMH_max, pch = 1, col = "red")
plot(Weekly_LVMH_max, pch = 1, col = "red")

# Sanofi monthly - weekly ; Jan 2001 - Jan 2015
quartz()
par(mfrow = c(1,2))
plot(Sanofi_max, pch = 1, col = "green")
plot(Weekly_Sanofi_max, pch = 1, col = "green")

# Carrefour monthly - weekly ; Jan 2001 - Jan 2015
quartz()
par(mfrow = c(1,2))
plot(Carrefour_max, pch = 1, col = "magenta")
plot(Weekly_Carrefour_max, pch = 1, col = "magenta")


require(speedglm)

make.data<-function(filename, chunksize,...){
	conn<-NULL
	function(reset=FALSE){
		if(reset){
			if(!is.null(conn)) close(conn)
			conn<<-file(filename,open="r")
		} else{
			rval<-read.table(conn, nrows=chunksize,...)
			if ((nrow(rval)==0)) {
				close(conn)
				conn<<-NULL
				rval<-NULL
			}
			return(rval)
		}
	}
}

fullfile<-"/net/bipolar/jedidiah/mutation/smaug-genetics/sandbox/full_sort.txt"
danames<-c("CHR", "BIN", "POS", "Sequence", "mut", "PC1", "PC2", "PC3", "PC4", "PC5", "PC6", "PC7", "PC8", "PC9", "PC10", "PC11", "PC12")
da<-make.data(fullfile,chunksize=1000000,col.names=danames)

log_mod<-bigglm(mut~factor(Sequence)+PC1+PC2+PC3+PC4+PC5+PC6+PC7+PC8+PC9+PC10+PC11+PC12, data=da, family=binomial(), maxit=25)
log_mod<-shglm(mut~factor(Sequence)+PC1+PC2+PC3+PC4+PC5+PC6+PC7+PC8+PC9+PC10+PC11+PC12, datafun=da, family=binomial(), fitted=T)

da2<-read.table("/net/bipolar/jedidiah/mutation/smaug-genetics/sandbox/full_sort.txt", header=F, stringsAsFactors=F, nrows=1000000)
names(da2)<-danames

da3<-da2[sample(nrow(da2), 20000),]

da3<-read.table("/net/bipolar/jedidiah/mutation/smaug-genetics/sandbox/full_sort.txt", header=F, stringsAsFactors=F, nrows=500000)
names(da3)<-danames

log_mod_null<-speedglm(mut~Sequence+PC1+PC2+PC3+PC4+PC5+PC6+PC7+PC8+PC9+PC10+PC11+PC12, data=da3, family=binomial(), fitted=T)
log_mod_null2<-glm(mut~Sequence+PC1+PC2+PC3+PC4+PC5+PC6+PC7+PC8+PC9+PC10+PC11+PC12, data=da3, family=binomial)

# log_mod_null$coefficients<-log_mod$coefficients
# log_mod_null2$coefficients<-log_mod$coefficients

# original fitted vals from speedglm
lmnp<-head(plogis(log_mod_null$linear.predictors))

# original fitted vals from glm
lmnp2<-head(log_mod_null2$fitted.values)

lmnc<-head(log_mod_null$coefficients)
lmnc2<-head(log_mod_null$coefficients)

# replace coefficients with full model (returns NAs for speedglm object)
log_mod_null$coefficients<-log_mod$coefficients
log_mod_null3<-log_mod_null2
log_mod_null3$coefficients<-log_mod$coefficients

# preds<-plogis(predict(log_mod_null3, da3))

chunksize<-1000000
numsites<-1146613132
numchunks<-ceil(numsites/chunksize)

fullfile2<-"/net/bipolar/jedidiah/mutation/smaug-genetics/sandbox/AT_CG_full.txt"

for(i in 1:numchunks){

	tmp<-read.table(fullfile2, header=F, stringsAsFactors=F, nrows=chunksize, skip=((i-1)*chunksize))
	names(tmp)<-danames

	preds<-plogis(predict(log_mod_null3, tmp))

	out<-cbind(tmp[,1:3], preds)

	outpath<-paste0("/net/bipolar/jedidiah/mutation/smaug-genetics/sandbox/", i, "_test_out.txt")

	write.table(out, outpath, col.names=F, row.names=F, quote=F, sep="\t")
}

# predicted vals from manual matrix method
# build matrix
m <- model.matrix(mut~factor(Sequence)+PC1+PC2+PC3+PC4+PC5+PC6+PC7+PC8+PC9+PC10+PC11+PC12, da3)[,]

# get predicted vals
p2 <- coef(log_mod) %*% t(m)

# convert to probabilities
p2 <- plogis(as.vector(p2))


#!/usr/bin/env Rscript

#===========================================================
# R script for analyzing the statistical significance of interactions
# this is an implementation of the paper Ay et. al. 2014 (FitHiC)
# incorporates spline fit for raw contact count
# also implements the bias calculation and the bias based filtering and spline fit procedure

#Author: Sourya Bhattacharyya
#Vijay-Ay lab, LJI
#===========================================================

library(splines)
library(fdrtool)
library(parallel)	# library for parallel processing

library(optparse)

# #===========================
# # parallel computation of binomial distribution on input vector
# parallel.BinomDistr <- function(inpvec) {
# 	idx <- inpvec[1]
# 	cc <- inpvec[2]
# 	tc <- inpvec[3]
# 	currprob <- inpvec[4]

# 	curr_dbinom <- dbinom(cc, size=tc, prob=currprob)
# 	curr_pbinom <- pbinom(cc, size=tc, prob=currprob, lower.tail=FALSE)
# 	return c(idx, curr_dbinom, (curr_dbinom + curr_pbinom))
# }

# #===========================

option_list = list(
  	make_option(c("--InpFile"), type="character", default=NULL, help="File with interactions + normalization features among individual genomic bins, preferably sorted with respect to interaction distance"),
  	make_option(c("--headerInp"), type="logical", action="store_true", default=FALSE, help="If TRUE, input interaction file has the header. Default FALSE."),
	make_option(c("--OutFile"), type="character", default=NULL, help="Output file name storing interactions + probability, P value and Q value"),
	make_option(c("--P2P"), type="integer", action="store", default=0, help="Can be 0 or 1. If 1, spline fit is modeled using only peak to peak interactions. Default 0."),
  	make_option(c("--EqLenBin"), type="logical", action="store_true", default=FALSE, help="If TRUE, Equal length bins are used. Default FALSE, means that equal occupancy bins are used. Users need not alter this parameter"),
  	make_option(c("--BiasCorr"), type="integer", action="store", default=0, help="If 0, raw contact count is used. Else, bias corrected contact count is used before applying FitHiC. Default 0."),
	make_option(c("--BiasLowThr"), type="numeric", default=0.2, help="Lower threshold of bias. Default 0.2"),
	make_option(c("--BiasHighThr"), type="numeric", default=5, help="Higher threshold of bias. Default 5"),
  	make_option(c("--nbins"), type="integer", action="store", default=200, help="Number of bins employed for FitHiC.", metavar="nbins"),
  	make_option(c("--Draw"), type="logical", action="store_true", default=FALSE, help="If TRUE, spline fit of FitHiC is plotted. Default FALSE."),
  	make_option(c("--cccol"), type="integer", action="store", default=7, help="Column number of the file storing the contact count"),
  	make_option(c("--TimeFile"), type="character", default=NULL, help="If specified, denotes the file which will contain time profiling information"),
  	make_option(c("--BiasFilt"), type="integer", action="store", default=0, help="If 1, interactions are filtered according to BiasLowThr and BiasHighThr, before processing. Default 0"),
	make_option(c("--ProbBias"), type="integer", action="store", default=0, help="If 1, probability values are multiplied with the bias values. Default 0.")
);

opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser);

nbins <- as.integer(opt$nbins) # number of bins used in FitHiC
if (is.null(opt$TimeFile)) {
	timeprof <- 0
} else {
	timeprof <- 1
}

# peak to peak background usage option
Peak2PeakBackg <- as.integer(opt$P2P)
cat(sprintf("\n Peak to peak background usage for spline fit: %s ", Peak2PeakBackg))

# number of processors within the system
ncore <- detectCores()
cat(sprintf("\n Number of cores in the system: %s ", ncore))

# directory containing the input interaction file
inpdir <- dirname(opt$InpFile)

# directory to contain the spline fitted output interaction file
OutIntDir <- dirname(opt$OutFile)

# this directory will store the spline graph according to the model
outdir <- paste0(OutIntDir,'/Results')
system(paste('mkdir -p', outdir))

# this file stores the spline fitted model
if (opt$EqLenBin) {
	plotfile <- paste0(outdir,'/','EqLenBin_SplinePass1.pdf')
} else {
	plotfile <- paste0(outdir,'/','EqOccBin_SplinePass1.pdf')
}

if (timeprof == 1) {
	starttime <- Sys.time()
}

# load the interaction data matrix
# Note: the data has a header information
interaction.data <- read.table(opt$InpFile, header=opt$headerInp)
if (opt$headerInp == FALSE) {
	colnames(interaction.data) <- c("chr1", "s1", "e1", "chr2", "s2", "e2", "cc", "d1", "isPeak1", "Bias1", "mapp1", "gc1", "cut1", "d2", "isPeak2", "Bias2", "mapp2", "gc2", "cut2")
}

if (timeprof == 1) {
	endtime <- Sys.time()
	fp <- file(opt$TimeFile, open="a")
	outstr <- paste('\n Time to load the interaction data file in the R structure: ', (endtime - starttime))
	write(outstr, file=fp, append=T)
	close(fp)
}

cat(sprintf("\n Number of unfiltered interactions: %s ", nrow(interaction.data)))

# return if the number of interaction is 0
if (nrow(interaction.data) == 0) {
	cat(sprintf("\n No of interactions : 0 - exit !!!"))
	return()
}

if (ncol(interaction.data) < opt$cccol) {
	cat(sprintf("\n There is no contact count column or the formatting of the input file has problems - exit !!!"))
	return()
}

# vector of initial (prior) probabilities for contact counts
Prob_Val <- c()

# probability of the observed contact count for a single locus pair, from the spline fit
Spline_Binom_Prob_CC <- c()

# P-value of the observed contact count for a single locus pair
# binomial distribution + spline based estimation
Spline_Binom_P_Val_CC <- c()

# for each bin, count the no of distinct locus pairs
no_distinct_loci <- c()

# for each bin, no of observed contacts
NumContact <- c()

# for each bin, stores the average contact count per locus pair
avg_contact <- c()

# prior contact probability for a specific locus pair falling within a bin
prior_contact_prob <- c()

# average interaction distance for all locus pairs falling within a bin
avg_int_dist <- c()

#======================================================
# if normalization using bias values is enabled
# then discard the interactions where either loci has bias values outside specified thresholds
if ((opt$BiasCorr == 1) & (opt$BiasFilt == 1)) {

	# specifying the columns in the interaction data
	# where the bias information is provided
	bias1.col <- 10
	bias2.col <- 16

	if (ncol(interaction.data) >= bias2.col) {
		interaction.data <- interaction.data[which((interaction.data[,bias1.col] >= opt$BiasLowThr) & (interaction.data[,bias1.col] <= opt$BiasHighThr) & (interaction.data[,bias2.col] >= opt$BiasLowThr) & (interaction.data[,bias2.col] <= opt$BiasHighThr)), ]
		cat(sprintf("\n Bias specific filtering is enabled - Number of interactions where both loci satisfy bias criterion: %s ", nrow(interaction.data)))
	}
}

#======================================================
# absolute genomic distance for an interaction instance
gene.dist <- abs(interaction.data[,2] - interaction.data[,5])

# no of interactions pairs
numPairs <- length(gene.dist)
cat(sprintf("\n *** Total number of interactions: %s ", numPairs))

# total number of contacts for all the interactions
TotContact <- sum(interaction.data[,opt$cccol])

if (timeprof == 1) {
	starttime <- Sys.time()
}

#======================================================
# add - sourya
# we form the training data out of the total number of interactions
# if --P2P is enabled, training data consists of only peak to peak interactions
# else training data consists of the complete interaction set
if ((Peak2PeakBackg == 1) & (ncol(interaction.data) >= 15)) {
	TrainingData <- interaction.data[which((interaction.data[,9] == 1) & (interaction.data[,15] == 1)), ]
	# append the interaction distance as the last column of the training data
	TrainingData <- cbind(TrainingData, abs(TrainingData[,2] - TrainingData[,5]))
	# now sort the data with respect to increasing interaction distance
	TrainingData <- TrainingData[order( TrainingData[,ncol(TrainingData)] ), ]
	# remove the last column
	TrainingData <- TrainingData[,1:(ncol(TrainingData)-1)]
} else {
	TrainingData <- interaction.data
}

numTrainingPairs <- nrow(TrainingData)
if (numTrainingPairs == 0) {
	cat(sprintf("\n No training data for FitHiC spline fit - error - return !!! "))
	return()
}

cat(sprintf("\n *** Total number of training interactions: %s ", numTrainingPairs))

# interaction distance vector for the training data only
Trainingdata_GeneDist <- abs(TrainingData[,2] - TrainingData[,5])

# contact count sum for the training data
TotTrainingDataContact <- sum(TrainingData[,opt$cccol])

#=====================================================
# divide the genomic distance into b quantiles (number of bins)

# Note: for equal length bins (opt$EqLenBin is TRUE), each bin would have equal no of entries (pairs of loci)
# from the training data
# on the other hand, for equal occupancy bins (opt$EqLenBin is FALSE), each bin would have equal no of contact count
# from the training data
# In both cases, however, corresponding bin intervals will be variable

# error condition - sourya
# if the number of interactions is less than the argument 'nbins'
# then re-adjust the values of nbins and then assign the
# no of entries in each of the bins

if (opt$EqLenBin) {
	# no of entries (occupancies) for each bin
	# each bin have same no of locus pairs
	if (numTrainingPairs < nbins) {
		nbins <- numTrainingPairs
		nentry <- 1
	} else {
		nentry <- floor(numTrainingPairs / nbins)
	}
} else {
	# no of contacts for each bin
	# each bin have same no of contacts
	if (TotTrainingDataContact < nbins) {
		nbins <- numTrainingPairs
	}
	ncontactbin <- floor(TotTrainingDataContact / nbins)
}

#==============================================

if (opt$EqLenBin) {
	# equal length bin case (equal locus entries)
	for (bin_idx in (1:nbins)) {
		si <- (bin_idx - 1) * nentry + 1
		if (bin_idx < nbins) {
			ei <- si + nentry - 1
		} else {
			ei <- numTrainingPairs	# last read
		}
		no_distinct_loci[bin_idx] <- (ei-si+1)
		NumContact[bin_idx] <- sum(TrainingData[si:ei,opt$cccol])
		avg_contact[bin_idx] <- NumContact[bin_idx] / no_distinct_loci[bin_idx]
		prior_contact_prob[bin_idx] <- (avg_contact[bin_idx] / TotTrainingDataContact)
		avg_int_dist[bin_idx] <- mean(Trainingdata_GeneDist[si:ei])
	}
} else {
	# equal occupancy (contact count) bin - preferred

	# keeps track of total no of contact counts for a particular bin
	cumContactCount <- 0
	nelem <- 0
	ei <- 0
	bin_idx <- 0

	# keeps track of the no of different genomic distance values encountered within this bin
	# and also the no of elements (locus pairs) having that particular genomic distance
	ValGeneDist <- c()
	nelemSameGeneDist <- c()

	while (ei < numTrainingPairs) {
		si <- ei + 1
		curr_gene_dist <- abs(TrainingData[si,2] - TrainingData[si,5])
		idx_list <- which(Trainingdata_GeneDist == curr_gene_dist)
		nelem <- nelem + length(idx_list)
		ei <- ei + length(idx_list)
		cumContactCount <- cumContactCount + sum(TrainingData[si:ei, opt$cccol])

		ValGeneDist <- c(ValGeneDist, curr_gene_dist)
		nelemSameGeneDist <- c(nelemSameGeneDist, length(idx_list))

		if (cumContactCount >= ncontactbin) {
			# current cumulative contact exceeds the expected average contact per bin
			# and also, all the contacts with this specified genomic distance is covered
			# so, we fix this bin
			bin_idx <- bin_idx + 1
			no_distinct_loci[bin_idx] <- nelem
			NumContact[bin_idx] <- cumContactCount
			avg_contact[bin_idx] <- cumContactCount / nelem
			prior_contact_prob[bin_idx] <- (avg_contact[bin_idx] / TotTrainingDataContact)

			avg_int_dist[bin_idx] <- 0
			for (j in (1:length(ValGeneDist))) {
				avg_int_dist[bin_idx] <- avg_int_dist[bin_idx] + ((nelemSameGeneDist[j] * 1.0) / nelem) * ValGeneDist[j]
			}

			# reset the couners
			cumContactCount <- 0
		 	ValGeneDist <- c()
		 	nelemSameGeneDist <- c()
		 	nelem <- 0
		}
	}
	# now dump the data in a text file
	OutBinfile <- paste0(OutIntDir, '/', 'Bin_Info.log')
	write.table(cbind(avg_int_dist, no_distinct_loci, NumContact, avg_contact, prior_contact_prob), OutBinfile, row.names = FALSE, col.names = c("AvgDist","NumLoci","NumContact","AvgContact","PriorProb"), sep = "\t", quote=FALSE, append=FALSE)
}

cat(sprintf("\n after printing the bin log file"))

#=====================================
# now prepare a spline fit where x axis is the 'avg_int_dist'
# and y axis is the 'prior_contact_prob'
#=====================================

# # the first spline works according to the specified degree of freedom (16 - for testing)
# fit <- smooth.spline(avg_int_dist, prior_contact_prob, df=16)

# if (timeprof == 1) {
# 	endtime <- Sys.time()
# 	fp <- file(opt$TimeFile, open="a")
# 	outstr <- paste('\n Time for spline (df=16): ', (endtime - starttime))
# 	write(outstr, file=fp, append=T)
# 	close(fp)
# 	starttime <- Sys.time()
# }

# the spline works according to the cross validation principle
fit2 <- smooth.spline(avg_int_dist, prior_contact_prob, cv=TRUE)

if (timeprof == 1) {
	endtime <- Sys.time()
	fp <- file(opt$TimeFile, open="a")
	outstr <- paste('\n Time for spline (CV): ', (endtime - starttime))
	write(outstr, file=fp, append=T)
	close(fp)
	starttime <- Sys.time()
}

# # perform anti-tonic regression on the first spline
# fit.mr <- monoreg(fit$x, fit$y, type="antitonic")

# if (timeprof == 1) {
# 	endtime <- Sys.time()
# 	fp <- file(opt$TimeFile, open="a")
# 	outstr <- paste('\n Time for antitonic regression on spline (df = 16): ', (endtime - starttime))
# 	write(outstr, file=fp, append=T)
# 	close(fp)
# 	starttime <- Sys.time()
# }

# perform anti-tonic regression on the second spline
# antitonic = monotonic decreasing (as the probability decreases with increasing distance)
fit2.mr <- monoreg(fit2$x, fit2$y, type="antitonic")

if (timeprof == 1) {
	endtime <- Sys.time()
	fp <- file(opt$TimeFile, open="a")
	outstr <- paste('\n Time for antitonic regression on spline (CV): ', (endtime - starttime))
	write(outstr, file=fp, append=T)
	close(fp)
}

# # plot the data, if plotting is enabled via the parameter opt$Draw
# if (opt$Draw) {
# 	pdf(plotfile, width=14, height=10)
# 	plot(avg_int_dist, prior_contact_prob, cex=0.5, col="darkgrey", xlab="Average interaction distance", ylab="Prior contact probability")
# 	title("Smooth spline - antitonic regression - pass 1")
# 	lines(fit.mr, col="red", lwd=2)
# 	lines(fit2.mr, col="blue", lwd=2)
# 	legend("topright",legend=c("16 DF", paste(as.integer(fit2$df), "df (cv)")), col=c("red", "blue"), lty=1, lwd=2, cex=0.8)
# 	dev.off()
# }

#=========================
# now use this fitted spline
# to get predicted probability values for all distance values of the interactions
# in the unit of bin size employed in the current file)
binsize <- abs(interaction.data[1,2] - interaction.data[1,5])
TestDistVal <- seq(min(gene.dist), max(gene.dist), binsize)

# probability obtained from the spline
pp.fit2 <- predict(fit2, TestDistVal)

# use this computed probability and the input distance to fit a spline again
fit2_new <- smooth.spline(pp.fit2$x, pp.fit2$y, cv=TRUE)

# perform antitonic regression on this spline
fit2_new.mr <- monoreg(fit2_new$x, fit2_new$y, type="antitonic")

# plot the fitted spline and the smoothing regression
if (opt$Draw) {
	plotfile1 <- paste0(outdir,'/','EqOccBin_SplinePass1.pdf')
	pdf(plotfile1, width=10, height=8)
	plot(avg_int_dist, prior_contact_prob, cex=0.5, col="black", xlab="Average interaction distance", ylab="Prior contact probability", xlim=c(0, max(gene.dist)))
	lines(fit2$x, fit2$y, col="yellow", lwd=0.5)
	lines(fit2.mr$x, fit2.mr$yf, col="blue", lwd=0.5)
	lines(fit2_new$x, fit2_new$y, col="green", lwd=0.5)
	lines(fit2_new.mr$x, fit2_new.mr$yf, col="red", lwd=0.5)
	legend("topright",legend=c(paste("spline (fit2) - ", as.integer(fit2$df), "df (cv)"), "MR on spline (fit2.mr)", paste("5 Kb uniform spline (fit2_new) - ", as.integer(fit2_new$df), "df (cv)"), "MR on 5 Kb uniform spline (fit2_new.mr)"), col=c("yellow", "blue", "green", "red"), lty=1, lwd=1, cex=0.8)
	title("Smooth spline - antitonic regression - pass 1")
	dev.off()
}

# plot the fitted spline and the smoothing regression
# in log scale
if (opt$Draw) {
	plotfile1 <- paste0(outdir,'/','EqOccBin_SplinePass1_LOGScale.pdf')
	pdf(plotfile1, width=10, height=8)
	plot(avg_int_dist, log10(prior_contact_prob), cex=0.5, col="black", xlab="Average interaction distance", ylab="Prior contact probability (log)", xlim=c(0, max(gene.dist)))
	lines(fit2$x, log10(fit2$y), col="yellow", lwd=0.5)
	lines(fit2.mr$x, log10(fit2.mr$yf), col="blue", lwd=0.5)
	lines(fit2_new$x, log10(fit2_new$y), col="green", lwd=0.5)
	lines(fit2_new.mr$x, log10(fit2_new.mr$yf), col="red", lwd=0.5)
	legend("topright",legend=c(paste("spline (fit2) - ", as.integer(fit2$df), "df (cv)"), "MR on spline (fit2.mr)", paste("5 Kb uniform spline (fit2_new) - ", as.integer(fit2_new$df), "df (cv)"), "MR on 5 Kb uniform spline (fit2_new.mr)"), col=c("yellow", "blue", "green", "red"), lty=1, lwd=1, cex=0.8)
	title("Smooth spline - antitonic regression - pass 1 - log scale")
	dev.off()
}

# create a data frame to write the old spline and old MR regression results
old_sample.df <- cbind.data.frame(fit2$x, fit2$y, fit2.mr$x, fit2.mr$yf)
colnames(old_sample.df) <- c('fit2$x', 'fit2$y', 'fit2.mr$x', 'fit2.mr$yf')
write.table(old_sample.df, paste0(outdir,'/EqOccBin_OldSpline_Regression.txt'), row.names = FALSE, col.names = TRUE, sep = "\t", quote=FALSE, append=FALSE)

# create a data frame to write the old spline and old MR regression results
new_sample.df <- cbind.data.frame(fit2_new$x, fit2_new$y, fit2_new.mr$x, fit2_new.mr$yf)
colnames(new_sample.df) <- c('fit2_new$x', 'fit2_new$y', 'fit2_new.mr$x', 'fit2_new.mr$yf')
write.table(new_sample.df, paste0(outdir,'/EqOccBin_NewSpline_Regression.txt'), row.names = FALSE, col.names = TRUE, sep = "\t", quote=FALSE, append=FALSE)

#--------------------------------------------
# Paper: Ferhat Ay, 2014
# the probability is computed with respect to the spline plot
# which is then substituted to the binomial distribution, for P-value estimation

if (is.unsorted(gene.dist) == TRUE) {

	cat(sprintf("\n **** The interaction file is unsorted --- check ****"))

	# here the genomic distance is unsorted
	# so we employ the predict function and probability distribution computation
	# for the complete array

	# get the spline interpolation prediction from the already modeled smoothing spline object (CV spline)
	# with respect to the input genomic distance vector
	# the returned value is a component of 2 fields: (x,y)
	# where x is the input data and y is the predicted data

	# input will be the genomic distance
	# output is the corresponding contact probability

	# note: the probability was computed with respect to 'numPairs' placed as the denominator
	# accordingly we modify the binomial distribution equation

	# predict from the new spline fit - sourya
	# pp <- predict(fit2, gene.dist)
	pp <- predict(fit2_new, gene.dist)

	for (k in (1:numPairs)) {
		# probability for this particular interaction is in the y field
		p <- pp$y[k]
		if (opt$BiasCorr == 0) {
			# model binomial distribution with this probability
			Spline_Binom_Prob_CC[k] <- dbinom(interaction.data[k, opt$cccol], size=TotContact, prob=p)
			# compute the p value with respect to the modified distribution
			Spline_Binom_P_Val_CC[k] <- pbinom(interaction.data[k, opt$cccol], size=TotContact, prob=p, lower.tail=FALSE) + Spline_Binom_Prob_CC[k]
			# store the prior probability
			Prob_Val[k] <- p
		} else {
			# model binomial distribution with the product of probability, and the bias values of two segments
			if (opt$ProbBias == 1) {
				curr_prob <- p * interaction.data[k, bias1.col] * interaction.data[k, bias2.col]
			} else {
				curr_prob <- p
			}
			Spline_Binom_Prob_CC[k] <- dbinom(interaction.data[k, opt$cccol], size=TotContact, prob=curr_prob)
			# compute the p value with respect to the modified distribution
			Spline_Binom_P_Val_CC[k] <- pbinom(interaction.data[k, opt$cccol], size=TotContact, prob=curr_prob, lower.tail=FALSE) + Spline_Binom_Prob_CC[k]
			# store the prior probability
			Prob_Val[k] <- p
		}
	}
} else {

	if (timeprof == 1) {
		starttime <- Sys.time()
	}

	# here the genomic distance is sorted
	# so we selectively apply the predict function to only the distinct elements of the list
	uniq.idx <- order(gene.dist)[!duplicated(gene.dist)]

	if (timeprof == 1) {
		endtime <- Sys.time()
		fp <- file(opt$TimeFile, open="a")
		outstr <- paste('\n Time to find unique indices in genomic distance: ', (endtime - starttime))
		write(outstr, file=fp, append=T)
		close(fp)
	}

	if (timeprof == 1) {
		starttime <- Sys.time()
	}

	for (k in (1:length(uniq.idx))) {
		# all the locations from si to ei will have the same probability
		# since the gene distance value is the same
		si <- uniq.idx[k]
		if (k < length(uniq.idx)) {
			ei <- uniq.idx[k+1] - 1
		} else {
			ei <- numPairs	# last read
		}
		# compute the probability according to the genomic distance (of the start location - single element)
		# this probability value will be used for all the values within the interval (si to ei)

		# predict from the new spline fit - sourya
		# pp <- predict(fit2, gene.dist[si])
		pp <- predict(fit2_new, gene.dist[si])
		p <- pp$y

		#==========================
		# compute the probability distribution for the current interval
		#==========================
		if (opt$BiasCorr == 0) {
			curr_dbinom <- dbinom(interaction.data[si:ei, opt$cccol], size=TotContact, prob=p)
			curr_pbinom <- pbinom(interaction.data[si:ei, opt$cccol], size=TotContact, prob=p, lower.tail=FALSE)
			# append the distribution to the final vector
		 	Spline_Binom_Prob_CC <- c(Spline_Binom_Prob_CC, curr_dbinom)
		 	Spline_Binom_P_Val_CC <- c(Spline_Binom_P_Val_CC, (curr_dbinom + curr_pbinom))
		 	# store the prior probability as well
		 	Prob_Val[si:ei] <- p
		} else {
			# bias based probability correction

			# comment - sourya
			# for (idx in (si:ei)) {
			# 	# model binomial distribution with the product of probability, and the bias values of two segments
			# 	curr_prob <- p * interaction.data[idx, (opt$cccol + 1)] * interaction.data[idx, (opt$cccol + 3)]
			# 	curr_dbinom <- dbinom(interaction.data[idx, opt$cccol], size=TotContact, prob=curr_prob)
			# 	curr_pbinom <- pbinom(interaction.data[idx, opt$cccol], size=TotContact, prob=curr_prob, lower.tail=FALSE)
			# 	# append the distribution to the final vector
			#  	Spline_Binom_Prob_CC[idx] <- curr_dbinom
			#  	Spline_Binom_P_Val_CC[idx] <- (curr_dbinom + curr_pbinom)
			#  	# store the prior probability as well
		 		# Prob_Val[idx] <- curr_prob
			# }

			# add - sourya

			# cat(sprintf("\n *** Before executing Parallel from si: %s to ei: %s ", si, ei))

			# now apply this matrix on the parallel version of binomial distribution computation
			# the second argument 1 means that individual rows of matrix is processed
			# in the parallel computation
			result_binomdistr <- as.data.frame(parallel:::mclapply( si:ei , mc.cores = ncore , function(idx){
				cc <- interaction.data[idx, opt$cccol]
				if (opt$ProbBias == 1) {
					pr <- p * interaction.data[idx, bias1.col] * interaction.data[idx, bias2.col]
				} else {
					pr <- p
				}
				db <- dbinom(cc, size=TotContact, prob=pr)
				pb <- pbinom(cc, size=TotContact, prob=pr, lower.tail=FALSE)
				return(c(idx,pr,db,(db+pb)))
				} ))

			# cat(sprintf("\n *** rows: %s   columns: %s ", nrow(result_binomdistr), ncol(result_binomdistr)))

			# copy the results
			# columns : si to ei
			# rows: 4
			# for (i in (1:ncol(result_binomdistr))) {
			# 	idx <- result_binomdistr[1,i]
			# 	Prob_Val[idx] <- result_binomdistr[2,i]
			# 	Spline_Binom_Prob_CC[idx] <- result_binomdistr[3,i]
			# 	Spline_Binom_P_Val_CC[idx] <- result_binomdistr[4,i]
			# }
			Prob_Val[si:ei] <- as.double(result_binomdistr[2,1:ncol(result_binomdistr)])
			Spline_Binom_Prob_CC[si:ei] <- as.double(result_binomdistr[3,1:ncol(result_binomdistr)])
			Spline_Binom_P_Val_CC[si:ei] <- as.double(result_binomdistr[4,1:ncol(result_binomdistr)])

			# end add - Sourya
		}
	}

	if (timeprof == 1) {
		endtime <- Sys.time()
		fp <- file(opt$TimeFile, open="a")
		outstr <- paste('\n Time for Spline based distribution compute (p value) (sorted interaction file): ', (endtime - starttime))
		write(outstr, file=fp, append=T)
		close(fp)
	}
}

if (timeprof == 1) {
	starttime <- Sys.time()
}

# from the generated P values, obtain the Q value using BH correction
Spline_Binom_QVal <- p.adjust(Spline_Binom_P_Val_CC, method = "BH")

if (timeprof == 1) {
	endtime <- Sys.time()
	fp <- file(opt$TimeFile, open="a")
	outstr <- paste('\n Time to compute Q value (from P value) in spline: ', (endtime - starttime))
	write(outstr, file=fp, append=T)
	close(fp)
}

if (timeprof == 1) {
	starttime <- Sys.time()
}

# accumulate all results - also add header information
FinalData <- cbind(interaction.data, Prob_Val, Spline_Binom_Prob_CC, Spline_Binom_P_Val_CC, Spline_Binom_QVal)
colnames(FinalData) <- c(colnames(interaction.data), "p", "dbinom", "P-Value", "Q-Value")

#===================================
# add - sourya - debug
# scan through individual genomic distance
# and plot the number of contacts / interactions for each distance
qval_thr <- 0.01
uniq_gene_dist <- sort(unique(gene.dist))

# distance specific contact count and no of interactions
unfilt_cc_dist <- c()
filt_cc_dist <- c()
unfilt_p2p_cc_dist <- c()
filt_p2p_cc_dist <- c()
unfilt_int_dist <- c()
filt_int_dist <- c()
unfilt_p2p_int_dist <- c()
filt_p2p_int_dist <- c()

for (i in 1:length(uniq_gene_dist)) {
	curr_dist <- uniq_gene_dist[i]
	curr_dist_unfilt_int_idx <- which(abs(FinalData[,2] - FinalData[,5]) == curr_dist)
	curr_dist_filt_int_idx <- which((abs(FinalData[,2] - FinalData[,5]) == curr_dist) & (FinalData[,ncol(FinalData)] < qval_thr))

	if (ncol(interaction.data) >= 15) {
		curr_dist_unfilt_p2p_idx <- which((abs(FinalData[,2] - FinalData[,5]) == curr_dist) & (FinalData[,9] == 1) & (FinalData[,15] == 1))
		curr_dist_filt_p2p_idx <- which((abs(FinalData[,2] - FinalData[,5]) == curr_dist) & (FinalData[,9] == 1) & (FinalData[,15] == 1) & (FinalData[,ncol(FinalData)] < qval_thr))
	}

	unfilt_int_dist <- c(unfilt_int_dist, length(curr_dist_unfilt_int_idx))
	unfilt_cc_dist <- c(unfilt_cc_dist, sum(FinalData[curr_dist_unfilt_int_idx, 7]))
	filt_int_dist <- c(filt_int_dist, length(curr_dist_filt_int_idx))
	filt_cc_dist <- c(filt_cc_dist, sum(FinalData[curr_dist_filt_int_idx, 7]))

	if (ncol(interaction.data) >= 15) {
		unfilt_p2p_int_dist <- c(unfilt_p2p_int_dist, length(curr_dist_unfilt_p2p_idx))
		unfilt_p2p_cc_dist <- c(unfilt_p2p_cc_dist, sum(FinalData[curr_dist_unfilt_p2p_idx, 7]))
		filt_p2p_int_dist <- c(filt_p2p_int_dist, length(curr_dist_filt_p2p_idx))
		filt_p2p_cc_dist <- c(filt_p2p_cc_dist, sum(FinalData[curr_dist_filt_p2p_idx, 7]))
	}
}

x <- sum(unfilt_cc_dist)
unfilt_cc_dist_frac <- unfilt_cc_dist / (x * 1.0)

x <- sum(filt_cc_dist)
filt_cc_dist_frac <- filt_cc_dist / (x * 1.0)

x <- sum(unfilt_int_dist)
unfilt_int_dist_frac <- unfilt_int_dist / (x * 1.0)

x <- sum(filt_int_dist)
filt_int_dist_frac <- filt_int_dist / (x * 1.0)

if (ncol(interaction.data) >= 15) {

	x <- sum(unfilt_p2p_cc_dist)
	unfilt_p2p_cc_dist_frac <- unfilt_p2p_cc_dist / (x * 1.0)

	x <- sum(filt_p2p_cc_dist)
	filt_p2p_cc_dist_frac <- filt_p2p_cc_dist / (x * 1.0)

	x <- sum(unfilt_p2p_int_dist)
	unfilt_p2p_int_dist_frac <- unfilt_p2p_int_dist / (x * 1.0)

	x <- sum(filt_p2p_int_dist)
	filt_p2p_int_dist_frac <- filt_p2p_int_dist / (x * 1.0)

	out.df <- cbind.data.frame(uniq_gene_dist, unfilt_int_dist, unfilt_int_dist_frac, unfilt_cc_dist, unfilt_cc_dist_frac, unfilt_p2p_int_dist, unfilt_p2p_int_dist_frac, unfilt_p2p_cc_dist, unfilt_p2p_cc_dist_frac, filt_int_dist, filt_int_dist_frac, filt_cc_dist, filt_cc_dist_frac, filt_p2p_int_dist, filt_p2p_int_dist_frac, filt_p2p_cc_dist, filt_p2p_cc_dist_frac)

	colnamevec <- c("dist", "U-Num", "%U-Num", "U-CC", "%U-CC", "U-P2P-Num", "%U-P2P-Num", "U-P2P-CC", "%U-P2P-CC", "F-Num", "%F-Num", "F-CC", "%F-CC", "F-P2P-Num", "%F-P2P-Num", "F-P2P-CC", "%F-P2P-CC")
} else {
	out.df <- cbind.data.frame(uniq_gene_dist, unfilt_int_dist, unfilt_int_dist_frac, unfilt_cc_dist, unfilt_cc_dist_frac, filt_int_dist, filt_int_dist_frac, filt_cc_dist, filt_cc_dist_frac)
	colnamevec <- c("dist", "U-Num", "%U-Num", "U-CC", "%U-CC", "F-Num", "%F-Num", "F-CC", "%F-CC")
}

colnames(out.df) <- colnamevec
write.table(out.df, paste0(outdir, '/Count_Summary.txt'), row.names = FALSE, col.names = TRUE, sep = "\t", quote=FALSE, append=FALSE)

colorvec <- c("black", "yellow", "blue", "green", "red", "brown", "magenta", "cyan")

plotfile1 <- paste0(outdir,'/Count_Summary.pdf')
pdf(plotfile1, width=10, height=8)
plot(out.df[,1], out.df[,3], cex=0.5, col=colorvec[1], type="l", xlab="Distance", ylab="Percentage")
lines(out.df[,1], out.df[,5], col=colorvec[2], lwd=0.5)
lines(out.df[,1], out.df[,7], col=colorvec[3], lwd=0.5)
lines(out.df[,1], out.df[,9], col=colorvec[4], lwd=0.5)

if (ncol(interaction.data) >= 15) {
	lines(out.df[,1], out.df[,11], col=colorvec[5], lwd=0.5)
	lines(out.df[,1], out.df[,13], col=colorvec[6], lwd=0.5)
	lines(out.df[,1], out.df[,15], col=colorvec[7], lwd=0.5)
	lines(out.df[,1], out.df[,17], col=colorvec[8], lwd=0.5)
}

if (ncol(interaction.data) >= 15) {
	legendvec <- c(colnamevec[3], colnamevec[5], colnamevec[7], colnamevec[9], colnamevec[11], colnamevec[13], colnamevec[15], colnamevec[17])
} else {
	legendvec <- c(colnamevec[3], colnamevec[5], colnamevec[7], colnamevec[9])
}

legend("topright",legend=legendvec, col=colorvec, lty=1, lwd=1, cex=0.8)
title("% of different quantities")
dev.off()
# end add - sourya - debug
#===================================

# append the Spline distribution probability and corresponding P value as separate columns
# and write in a separate text file
temp_outfile <- paste0(OutIntDir, '/', 'temp_out.bed')
write.table(FinalData, temp_outfile, row.names = FALSE, col.names = TRUE, sep = "\t", quote=FALSE, append=FALSE)

# now sort the file contents and write that in the final specified output file
system(paste('sort -k1,1 -k2,2n -k5,5n', paste0('-k',opt$cccol,',',opt$cccol,'nr'), temp_outfile, '>', opt$OutFile))
# delete the temporary output file
system(paste('rm', temp_outfile))

# # sort the data according to the chromosome name, start positions of both the interacting segments
# # and finally with the decreasing contact count
# FinalData <- FinalData[order( FinalData[,1], FinalData[,2], FinalData[,5], -FinalData[,opt$cccol] ), ]

# # write the data with the header information
# write.table(FinalData, opt$OutFile, row.names = FALSE, col.names = TRUE, sep = "\t", quote=FALSE, append=FALSE)

if (timeprof == 1) {
	endtime <- Sys.time()
	fp <- file(opt$TimeFile, open="a")
	outstr <- paste('\n Time to write the interaction data (with Q value) for spline based distribution: ', (endtime - starttime))
	write(outstr, file=fp, append=T)
	close(fp)
}


#################################################
#
# make_figure_3.r    16 FEB 2017
#
# Generates figure 3 in "Priority for the
# worse off and the Social Cost of Carbon". This
# code is meant to be sourced from make_figures.r
# and not necessarily run on its own.
#
#################################################

# Setup the plotting device
outfile <- paste(plotdir, "/figure3.pdf", sep="")
pdf(outfile, width=8, height=12)

# Set the plot range exponents
my.exp.lo <- -1
my.exp.hi <- 4
my.scc.range <- c(0,10000)
scc.legend.lab <- expression(paste("Social Cost of Carbon [2015 USD per ton ", CO[2], "]", sep=""))
scc.cols <- colorRampPalette(c(brewer.pal(8, "PuOr"), "black"), bias=0.45)(100)

# Loop over the regions
for(i in 1:length(norm.regions)) {

  # Define the vertical plotting area for this panel
  vert.area <- c(1-(i*0.22), 1-((i-1)*0.22))

  # Define the current run
  this.run <- norm.regions[i]

  # Subset the data frame for this region
  util.subset <- my.data[which(with(my.data, focusregion == this.run &
                                      eta <= 3.0 & eta >= 0.0 &
                                      rho >= 0.0 & rho <= 0.03 &
                                      gamma == 0 & c0 == 1)),]
  prior.subset <- my.data[which(with(my.data, focusregion == this.run &
                                       eta <= 3.0 & eta >= 0.0 &
                                       gamma <= 3.0 & gamma >= 0.0 &
                                       rho == 0 & c0 == 500)),]

  # Make the 3d plots
  if(i == 1) {
    par(fig=c(0,0.5, vert.area))
  }
  else {
    par(fig=c(0,0.5, vert.area), new=T)
  }
  make.3dcontour.rho.eta(util.subset, scc.cols = scc.cols,
                         scc.range=my.scc.range, exp.lo=my.exp.lo, exp.hi=my.exp.hi, make.cbar=F)
  put.fig.letter(letters[(2*i)-1], font=2, cex=1.2, offset=c(0.01, -0.05))

  par(fig=c(0.5,1, vert.area), new=T)
  make.3dcontour(prior.subset, scc.cols = scc.cols,
                 scc.range=my.scc.range, exp.lo=my.exp.lo, exp.hi=my.exp.hi, make.cbar=F)
  put.fig.letter(letters[2*i], font=2, cex=1.2, offset=c(0.01, -0.05))

}

# Plot a color bar across the bottom
par(fig=c(0,1,0,1), new=T)
image.plot(legend.only=T, horizontal=T, smallplot=c(0.1,0.9,0.08,0.1),
           zlim=c(my.exp.lo,my.exp.hi), breaks=seq(my.exp.lo,my.exp.hi,l=101), col=scc.cols, legend.line=2.2,
           axis.args = list(at=my.exp.lo:my.exp.hi, labels=parse(text=paste("10^", my.exp.lo:my.exp.hi, sep=""))),
           legend.lab=scc.legend.lab)

# Turn off the plotting device if necessary
dev.off()


##################################################################################################################
####  Purpose: Final Project - Classification - EDA
####  Group: Ravi P., Derek P., Aneesh K., Ninad K.
####  Date: 11/28/2018
####  Comment:
####    setwd("~/Stevens/Fall2018/CS513_Knowledge_Discovery/Final Project/Classification")
####
##################################################################################################################
rm(list = ls())

df_train <- read.csv("./data/train_new.csv")
df_test <- read.csv("./data/test_new.csv")

# install.packages("ggplot2")
# install.packages("ggthemes")

library(dplyr)
library(ggplot2)
library(ggthemes) # visualization

#Combine datasets
df <- rbind(df_train,df_test)

summary(df[,c(-1,-2)])

#Check Animal Type vs Outcome
ggplot(df, aes(x = AnimalType, fill = OutcomeType)) +
  geom_bar(position = 'fill', colour='black') +
  labs(y = "Proportion", x = "Animal Type", title = "Animal Type vs. Outcome")

#Check isMix vs Outcome for Cats and Dogs
ggplot(df, aes(x = IsMix, fill = OutcomeType)) +
  geom_bar(position = 'fill', colour='black') +
  facet_wrap(~AnimalType)+
  labs(y = "Proportion", x = "IsMix", title = "isMix ~ Cats & Dogs Outcome")

#Check Age vs Outcome
ggplot(df, aes(x = AgeinDays, fill = OutcomeType)) +
  geom_bar(position = 'fill', colour='black') +
  labs(y = "Proportion", x = "Age Range", title = "Age vs. Outcome")

#Check isNeutered vs Outcome
ggplot(df, aes(x = IsNeutered, fill = OutcomeType)) +
  geom_bar(position = 'fill', colour='black') +
  labs(y = "Proportion", x = "IsNeutered", title = "IsNeutered vs. Outcome")


#' Given one dataset, find the number of NA values in each column for that dataset
#'
#' @description Given one dataset, find the number of NA values in each column for that dataset. Outputs a sentence, a data frame, and two plots
#'
#' @param dataframe Enter a dataset
#'
#' @importFrom magrittr %>%
#' @importFrom purrr map_df
#' @importFrom reshape melt.list
#' @importFrom dplyr arrange desc rename mutate
#' @importFrom ggplot2 ggplot aes geom_col coord_flip theme_bw labs scale_y_continuous
#' @importFrom stats reorder
#' @export
#'
#' @examples
#' explain_NAs(math)
#' explain_NAs(math)[[2]] # gives only the second part, which is the data frame
#' explain_NAs(math)[[3]] # gives only the third part, which is the first plot

##################
# kjerman code
##################

explain_NAs <- function(dataframe) {

    # error check
    if (!is.data.frame(dataframe)) {
        stop("Not all inputs are data frames.")
        break
    }

    # Tells the user about what this does and the total number of rows
    a <- (paste0("Here are the NA values in each column of the given dataframe, you have ", nrow(dataframe), " total rows in your dataset"))

    # Creates a data frame of all columns in the data set, the count of their NA values, and the percentage of the total rows that that is
    b <- dataframe %>%
    map_df(function(x) sum(is.na(x))) %>%
    reshape::melt.list(.) %>%
    arrange(desc(value)) %>%
    rename(
    variable = L1,
    number_of_NA_values = value
    ) %>%
    mutate(percentage_of_total_dataset = round((number_of_NA_values / nrow(dataframe) * 100), digits = 2))

    # Visualizes this
    c <- b %>%
    ggplot(aes(reorder(variable, number_of_NA_values), number_of_NA_values)) +
    geom_col() +
    coord_flip() +
    theme_bw() +
    labs(
    title = "Number of NA Values for Each Column in Your Data Set",
    y = "Count of NA Values",
    x = "Columns in the Data Set"
    )

    d <- b %>%
    ggplot(aes(reorder(variable, percentage_of_total_dataset), percentage_of_total_dataset)) +
    geom_col() +
    coord_flip() +
    theme_bw() +
    labs(
    title = "Percentage of NA Values in Each Column of Your Data Set",
    y = "Percentage of NA Values in the Data Set",
    x = "Columns in the Data Set"
    ) +
    scale_y_continuous(labels = function(x) paste0(x, "%"))

    return(list(a, b, c, d))
}


library(fUnitRoots)
library(ggplot2)
library(Hmisc)
library(maptools)
library(RColorBrewer)
library(classInt)
library(Cairo)
library(yaml)
library(boot)
library(classInt)
library(plotrix)
library(car)
library(directlabels)
library(strucchange)
library(xtable)
library(tseries)
library(grDevices)
library(shape)
library(cluster)


suppressMessages(library(tidyverse))
suppressMessages(library(patchwork))

args <- commandArgs(trailingOnly=TRUE)

if (length(args) != 2)
    stop("Expected two arguments")

input_file <- args[1]
output_file <- args[2]

df <- read.csv(input_file) %>% filter(near(phi, 0.005))

df$strategy <- gsub("default", "Original", df$strategy)
df$strategy <- gsub("balanced", "Balanced", df$strategy)

plot <-
    ggplot(df, aes(x=factor(type), y=balance, fill=strategy)) +
    geom_bar(stat="summary", fun="mean", position="dodge") +
    labs(y="Balance",
         x="Graph name",
         fill="Strategy") +
    theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) +
    facet_grid(targetbalance ~ .)

ggsave(output_file, plot)


library(ggplot2)

# fake data

plot_I_intervals = function(expected_I, observed_I, bootstrap_samples, confidence, out_dir) {
  "
  Plots the daily expected number of new cases with confidence intervals.

  Parameters
  ----------
  expected_I : numeric vector
    Daily expected number of new cases.
  observed_I : numeric vector
    Daily observed number of new cases.
  bootstrap_samples : DataFrame
    Bootstrapped samples of the time series. Each row must be a time series
    of the same length as expected_I.
  confidence : numeric
    Confidence of the intervals to be drawn.
  "
  # extract confidence intervals
  lower = function(c) quantile(c, (1 - confidence) / 2)
  upper = function(c) quantile(c, confidence + ((1 - confidence) / 2))
  lower_bound = apply(bootstrap_samples, MARGIN=2, FUN=lower)
  upper_bound = apply(bootstrap_samples, MARGIN=2, FUN=upper)
  # plot
  df = data.frame(expected_I)
  colnames(df) = "I(t)"
  df["t"] = 1:nrow(df)
  df["observed_I"] = observed_I
  plot <- ggplot(df, aes(x=t, y=`I(t)`)) +
    geom_line() +
    geom_line(data=df, aes(x=t, y=observed_I), col="red") +
    geom_ribbon(aes(ymin=lower_bound, ymax=upper_bound), alpha=0.2, fill="blue")
    ggsave(filename = paste(out_dir, "I(t).png", sep="/"), plot = plot)
}


#!/usr/bin/r

library(inline)
library(rbenchmark)

serialCode <- '
   // assign to C++ vector
   std::vector<double> x = Rcpp::as<std::vector< double > >(xs);
   size_t n = x.size();
   for (size_t i=0; i<n; i++) {
       x[i] = ::log(x[i]);
   }
   return Rcpp::wrap(x);
'
funSerial <- cxxfunction(signature(xs="numeric"), body=serialCode, plugin="Rcpp")

serialStdAlgCode <- '
   std::vector<double> x = Rcpp::as<std::vector< double > >(xs);
   std::transform(x.begin(), x.end(), x.begin(), ::log);
   return Rcpp::wrap(x);
'
funSerialStdAlg <- cxxfunction(signature(xs="numeric"), body=serialStdAlgCode, plugin="Rcpp")

## same, but with Rcpp vector just to see if there is measurable difference
serialRcppCode <- '
   // assign to C++ vector
   Rcpp::NumericVector x = Rcpp::NumericVector(xs);
   size_t n = x.size();
   for (size_t i=0; i<n; i++) {
       x[i] = ::log(x[i]);
   }
   return x;
'
funSerialRcpp <- cxxfunction(signature(xs="numeric"), body=serialRcppCode, plugin="Rcpp")

serialStdAlgRcppCode <- '
   Rcpp::NumericVector x = Rcpp::NumericVector(xs);
   std::transform(x.begin(), x.end(), x.begin(), ::log);
   return x;
'
funSerialStdAlgRcpp <- cxxfunction(signature(xs="numeric"), body=serialStdAlgRcppCode, plugin="Rcpp")

serialImportTransRcppCode <- '
   Rcpp::NumericVector x(xs);
   return Rcpp::NumericVector::import_transform(x.begin(), x.end(), ::log);
'
funSerialImportTransRcpp <- cxxfunction(signature(xs="numeric"), body=serialImportTransRcppCode, plugin="Rcpp")

## now with a sugar expression with internalizes the loop
sugarRcppCode <- '
   // assign to C++ vector
   Rcpp::NumericVector x = log ( Rcpp::NumericVector(xs) );
   return x;
'
funSugarRcpp <- cxxfunction(signature(xs="numeric"), body=sugarRcppCode, plugin="Rcpp")

## lastly via OpenMP for parallel use
openMPCode <- '
   // assign to C++ vector
   std::vector<double> x = Rcpp::as<std::vector< double > >(xs);
   size_t n = x.size();
#pragma omp parallel for shared(x, n)
   for (size_t i=0; i<n; i++) {
       x[i] = ::log(x[i]);
   }
   return Rcpp::wrap(x);
'

## modify the plugin for Rcpp to support OpenMP
settings <- getPlugin("Rcpp")
settings$env$PKG_CXXFLAGS <- paste('-fopenmp', settings$env$PKG_CXXFLAGS)
settings$env$PKG_LIBS <- paste('-fopenmp -lgomp', settings$env$PKG_LIBS)

funOpenMP <- cxxfunction(signature(xs="numeric"), body=openMPCode, plugin="Rcpp", settings=settings)

z <- seq(1, 2e6)
res <- benchmark(funSerial(z), funSerialStdAlg(z),
                 funSerialRcpp(z), funSerialStdAlgRcpp(z),
                 funSerialImportTransRcpp(z),
                 funOpenMP(z), funSugarRcpp(z),
                 columns=c("test", "replications", "elapsed",
                           "relative", "user.self", "sys.self"),
                 order="relative",
                 replications=100)
print(res)


func_num=function(x){
  num<-c(0,1,2,3,4,5,6,7,8,9)
  datalist<-list(10)
  a<-as.numeric(unlist(strsplit(as.character(x),"")))
  return(num[which(is.na(match(num,a)))])
}

R Community/R functions Assignments/Assignment9.r


8 * .Machine$sizeof.long # e.g. 32


compareTime <- function(lstOuts,Slot,SD=F,Sum=NULL,startYear=NULL,legendPos="topright",...){

  lst     <- list(...)
  dat     <- lapply(lstOuts,function(x){return(x[[Slot]])})
  nms     <- names(dat); if(!is.null(Sum)){nms <- c(nms,paste(Sum[1],"+",Sum[2],sep=""))}

  nD      <- length(dat)
  if(is.null(startYear)){xrange <- range(unlist(lapply(dat,function(x){x[,1]})),na.rm=T)
  } else { xrange <- c(startYear,range(unlist(lapply(dat,function(x){x[,1]})),na.rm=T)[2])}
  yrange  <- range(pretty(range(unlist(lapply(dat,function(x){x[,4:5]})),na.rm=T)))

  dat     <- lapply(dat,function(x){idx <- which(x[,1] %in% xrange[1]:xrange[2]); return(x[idx,])})

  if(is.null(lst$ylim)==F) yrange <- lst$ylim
  if(is.null(lst$xlim)==F) xrange <- lst$xlim
  plot(x=dat[[1]][,1],y=dat[[1]][,2],type="l",lwd=2,xlab="Years",ylab=Slot,
       xlim=xrange,ylim=yrange)
  grid(); box()
  for(i in 1:nD)
    lines(x=dat[[i]][,1],y=dat[[i]][,2],col=i,lwd=2)
  if(!is.null(Sum)){
    idx1  <- which(nms==Sum[1])
    idx2  <- which(nms==Sum[2])
    datsum<- colSums(rbind(dat[[idx1]][,2],dat[[idx2]][,2]))
    lines(x=dat[[idx1]][,1],y=datsum,col=nD+1,lwd=2)
  }
  if(SD){
    for(i in 1:nD){
      iCol  <- col2rgb(i)
      iCol  <- rgb(iCol[1]/255,iCol[2]/255,iCol[3]/255,0.25)
      polygon(x=c(dat[[i]][,1],rev(dat[[i]][,1])),
              y=c(dat[[i]][,4],rev(dat[[i]][,5])),col=iCol,border=0)
    }
  }
  legend(legendPos,legend=c(nms),col=1:length(nms),lwd=2,lty=1,box.lty=0)
  box()

}

compareTimes <- function(lstOuts,Slots,SD=F,Sum=NULL,YrInd=NULL,Apply=mean,startYear=NULL,legendPos="topright",...){

  lst         <- list(...)
  nD          <- length(lstOuts)
  idxD        <- as.list(rep(numeric(1),nD))
  names(idxD) <- names(lstOuts)
  for(i in 1:nD)
    idxD[[i]] <- grep(Slots,names(lstOuts[[i]]))
  dat         <- as.list(rep(numeric(1),nD))
  names(dat)  <- names(lstOuts)
  for(i in 1:nD){
    for(j in idxD[[i]]){
      dat[[i]] <- cbind(dat[[i]],lstOuts[[i]][[j]])
    }
    dat[[i]] <- dat[[i]][,-1]
    if(length(idxD[[i]])>1) dat[[i]] <- apply(dat[[i]],1,Apply)
  }
  nms     <- names(dat); if(!is.null(Sum)){nms <- c(nms,paste(Sum[1],"+",Sum[2],sep=""))}

  if(is.null(YrInd)){
    xrange  <- range(unlist(lapply(dat,function(x){x[,1]})),na.rm=T)
    yrange  <- range(pretty(range(dat),na.rm=T))
  } else {
    xrange  <- range(YrInd,na.rm=T)
    yrange  <- range(pretty(range(dat),na.rm=T))
    for(i in 1:nD){
      if(length(YrInd) != length(dat[[i]])){
        dat[[i]] <- cbind(rev(rev(YrInd)[-1]),dat[[i]])
      } else {
          dat[[i]] <- cbind(YrInd,dat[[i]])
        }
    }
  }

  if(is.null(startYear)){xrange <- range(unlist(lapply(dat,function(x){x[,1]})),na.rm=T)
  } else { xrange <- c(startYear,range(unlist(lapply(dat,function(x){x[,1]})),na.rm=T)[2])}

  dat     <- lapply(dat,function(x){idx <- which(x[,1] %in% xrange[1]:xrange[2]); return(x[idx,])})

  if(is.null(lst$ylim)==F) yrange <- lst$ylim
  if(is.null(lst$xlim)==F) xrange <- lst$xlim

  plot(x=dat[[1]][,1],y=dat[[1]][,2],type="l",lwd=2,xlab="Years",ylab=Slots,
       xlim=xrange,ylim=yrange)
  grid(); box()
  for(i in 1:nD)
    lines(x=dat[[i]][,1],y=dat[[i]][,2],col=i,lwd=2)
  if(!is.null(Sum)){
    idx1  <- which(nms==Sum[1])
    idx2  <- which(nms==Sum[2])
    datsum<- colSums(rbind(dat[[idx1]][,2],dat[[idx2]][,2]))
    lines(x=dat[[idx1]][,1],y=datsum,col=nD+1,lwd=2)
  }
  if(SD){
    for(i in 1:nD){
      iCol  <- col2rgb(i)
      iCol  <- rgb(iCol[1]/255,iCol[2]/255,iCol[3]/255,0.25)
      polygon(x=c(dat[[i]][,1],rev(dat[[i]][,1])),
              y=c(dat[[i]][,4],rev(dat[[i]][,5])),col=iCol,border=0)
    }
  }
  legend(legendPos,legend=c(nms),col=1:length(nms),lwd=2,lty=1,box.lty=0)
  box()

}

compareMatrix <- function(lstOuts,Slot,SD=F,Sum=NULL,YrInd=NULL,Apply=mean,startYear=NULL,legendPos="topright",...){

  lst     <- list(...)

  dat     <- lapply(lstOuts,function(x){return(x[[Slot]])})
  nms     <- names(dat); if(!is.null(Sum)){nms <- c(nms,paste(Sum[1],"+",Sum[2],sep=""))}

  nD      <- length(dat)
  if(is.null(YrInd)){
    xrange  <- range(unlist(lapply(dat,function(x){x[,1]})),na.rm=T)
    yrange  <- range(pretty(range(unlist(lapply(dat,function(x){apply(x[,-1],1,Apply)})),na.rm=T)))
  } else {
    xrange  <- range(YrInd,na.rm=T)
    yrange  <- range(pretty(range(unlist(lapply(dat,function(x){apply(x,1,Apply)})),na.rm=T)))
    for(i in 1:nD){
      if(length(YrInd) != nrow(dat[[i]])){
        dat[[i]] <- cbind(rev(rev(YrInd)[-1]),dat[[i]])
      } else {
          dat[[i]] <- cbind(YrInd,dat[[i]])
        }
    }
  }
  for(i in 1:nD) dat[[i]] <- cbind(dat[[i]][,1],apply(dat[[i]][,-1],1,Apply))

  if(is.null(startYear)){xrange <- range(unlist(lapply(dat,function(x){x[,1]})),na.rm=T)
  } else { xrange <- c(startYear,range(unlist(lapply(dat,function(x){x[,1]})),na.rm=T)[2])}

  dat     <- lapply(dat,function(x){idx <- which(x[,1] %in% xrange[1]:xrange[2]); return(x[idx,])})

  if(is.null(lst$ylim)==F) yrange <- lst$ylim
  if(is.null(lst$xlim)==F) xrange <- lst$xlim
  plot(x=dat[[1]][,1],y=dat[[1]][,2],type="l",lwd=2,xlab="Years",ylab=Slot,
       xlim=xrange,ylim=yrange)
  grid(); box()
  for(i in 1:nD)
    lines(x=dat[[i]][,1],y=dat[[i]][,2],col=i,lwd=2)
  if(!is.null(Sum)){
    idx1  <- which(nms==Sum[1])
    idx2  <- which(nms==Sum[2])
    datsum<- colSums(rbind(dat[[idx1]][,2],dat[[idx2]][,2]))
    lines(x=dat[[idx1]][,1],y=datsum,col=nD+1,lwd=2)
  }
  if(SD){
    for(i in 1:nD){
      iCol  <- col2rgb(i)
      iCol  <- rgb(iCol[1]/255,iCol[2]/255,iCol[3]/255,0.25)
      polygon(x=c(dat[[i]][,1],rev(dat[[i]][,1])),
              y=c(dat[[i]][,4],rev(dat[[i]][,5])),col=iCol,border=0)
    }
  }
  legend(legendPos,legend=c(nms),col=1:length(nms),lwd=2,lty=1,box.lty=0)
  box()
}


# library(netdiffuseR)

#' Network Bootstrapping
#'
#' Implements the bootstrapping method described in Snijders and Borgatti (1999).
#' This function is essentially a wrapper of \code{\link[boot:boot]{boot}}.
#'
#' @templateVar undirected FALSE
#' @templateVar self TRUE
#' @templateVar valued FALSE
#' @template graph_template
#' @param statistic A function that returns a vector with the statistic(s) of interest.
#' The first argument must be the graph, and the second argument a vector of indices
#' (see details)
#' @param resample.args List. Arguments to be passed to \code{\link{resample_graph}}
#' @param R Number of reps
#' @param x A \code{diffnet_bootnet} class object.
#' @param ... Further arguments passed to the method (see details).
#' @param main Character scalar. Title of the histogram.
#' @param xlab Character scalar. x-axis label.
#' @param breaks Passed to \code{\link{hist}}.
#' @param annotated Logical scalar. When TRUE marks the observed data average and the simulated data average.
#' @details
#' Just like the \code{boot} function of the \pkg{boot} package, the \code{statistic}
#' that is passed must have as arguments the original data (the graph in this case),
#' and a vector of indicides. In each repetition, the graph that is passed is a
#' resampled version generated as described in Snijders and Borgatti (1999).
#'
#' When \code{self = FALSE}, for pairs of individuals that haven been drawn more than
#' once the algorithm, in particular, \code{resample_graph}, takes care of filling
#' these pseudo autolinks that are not in the diagonal of the network. By default
#' it is assumed that these pseudo-autolinks depend on whether the original graph
#' had any, hence, if the diagonal has any non-zero value the algorithm assumes that
#' \code{self = TRUE}, skiping the 'filling algorithm'. It is important to notice
#' that, in order to preserve the density of the original network, when
#' assigning an edge value to a pair of the form \eqn{(i,i)} (pseudo-autolinks),
#' such is done with probabilty proportional to the density of the network, in
#' other words, before choosing from the existing list of edge values, the
#' algorithm decides whether to set a zero value first.
#'
#' The vector of indices that is passed to \code{statistic}, an integer vector with range
#' 1 to \eqn{n}, corresponds to the drawn sample of nodes, so the user can, for
#' example, use it to get a subset of a \code{data.frame} that will be used with
#' the \code{graph}.
#'
#' @export
#' @family Functions for inference
#' @references Snijders, T. A. B., & Borgatti, S. P. (1999). Non-Parametric
#' Standard Errors and Tests for Network Statistics. Connections, 22(2), 1–10.
#' Retrieved from \url{https://www.stats.ox.ac.uk/~snijders/Snijders_Borgatti.pdf}
#' @return A list of class \code{diffnet_bootnet} containing the following:
#' \item{graph}{The graph passed to \code{bootnet}.}
#' \item{p.value}{The resulting p-value of the test (see details).}
#' \item{t0}{The observed value of the statistic.}
#' \item{mean_t}{The average value of the statistic applied to the simulated networks.}
#' \item{var_t}{A vector of length \code{length(t0)}. Bootstrap variances.}
#' \item{R}{Number of simulations.}
#' \item{statistic}{The function \code{statistic} passed to \code{bootnet}.}
#' \item{boot}{A \code{boot} class object as return from the call to \code{boot}.}
#' \item{resample.args}{The list \code{resample.args} passed to \code{bootnet}.}
#' @name bootnet
#' @examples
#' # Computing edgecount -------------------------------------------------------
#' set.seed(13)
#' g <- rgraph_ba(t=99)
#'
#' ans <- bootnet(g, function(w, ...) length(w@x), R=100)
#' ans
#'
#' # Generating
NULL

bootnet_fillselfR <- function(graph, index, E) {
  n <- nrow(graph)

  # Finding repeated ones
  reps  <- vector("list", n)
  for (i in 1:n) {
    reps[[index[i]]] <- c(reps[[index[i]]], i)
  }

  # Adding samples
  m    <- length(E)
  dens <- length(E)/(n*n)
  for (r in reps) {

    # If it wasn't drawn more than once
    if (length(r) < 2) next

    # Sampling edges
    for (j in 1:length(r)) {
      for (k in j:length(r)) {

        if (k == j) next

        # Add accordingly to density
        if (runif(1) <= dens) {
          graph[r[j],r[k]] <- E[floor(runif(1)*m) + 1]
        }

        if (runif(1) <= dens) {
          graph[r[k],r[j]] <- E[floor(runif(1)*m) + 1]
        }
      }

    }
  }

  return(graph)
}

#' @rdname bootnet
#' @param useR Logical scalar. When \code{TRUE}, autolinks are filled using an
#' \R based rutine. Otherwise it uses the \pkg{Rcpp} implementation (default).
#' This is intended for testing only.
#' @export
resample_graph <- function(graph, self=NULL, useR=FALSE,...) {
  # Checking undirected (if exists)
  checkingUndirected(graph)

  cls <- class(graph)
  out <- if ("dgCMatrix" %in% cls) {
    resample_graph.dgCMatrix(graph, self, useR, ...)
  } else if ("list" %in% cls) {
    resample_graph.list(graph, self, useR, ...)
  } else if ("matrix" %in% cls) {
    resample_graph.dgCMatrix(methods::as(graph, "dgCMatrix"), self, useR, ...)
  } else if ("diffnet" %in% cls) {
    resample_graph.list(graph$graph, self, useR, ...)
  } else if ("array" %in% cls) {
    resample_graph.array(graph, self, useR, ...)
  } else stopifnot_graph(graph)

  attr(out, "undirected") <- FALSE

  return(out)
}

resample_graph.dgCMatrix <- function(graph, self=NULL, useR=FALSE,
                                     index=NULL, ...) {

  # Checking if self or not
  if (!length(self))
    self <- sum(Matrix::diag(graph)) > 0

  # Storing edge values to be resampled
  E <- graph@x
  if (!length(E))
    stop("The graph is empty.")

  # Sample graph
  if (!length(index)) # Random sample (with replacement)
    index   <-sample(1L:nrow(graph), nnodes(graph), TRUE)

  graph_i <- graph[index,][,index]

  # Getting ids
  original_ids <- dimnames(graph_i)

  # Checking self-edges
  if (!self && useR) {
    graph_i <- bootnet_fillselfR(graph_i, index, E)
  } else if (!self & !useR) {
    graph_i <- bootnet_fillself(graph_i, index, E)
  }

  # Adding names
  attr(graph_i, "sample_indices") <- index
  dimnames(graph_i) <- original_ids

  return(graph_i)
}

resample_graph.list <- function(graph, self, useR, ...) {
  t   <- length(graph)
  out <- graph

  # Names
  tn <- names(graph)
  if (!length(tn)) tn <- 1:t
  names(out) <- tn

  # Generating the first resample (since its dynamic, the sample_indices
  # attribute must be outside)
  out[[1]] <- resample_graph.dgCMatrix(graph[[1]], self, useR, ...)
  attr(out, "sample_indices") <- attr(out[[1]], "sample_indices")

  # If a short list, then return its only element
  if (t == 1) return(out)

  # Repeating
  newids <- attr(out, "sample_indices")
  for (i in 2:t) {
    # Filling blanks and removing sample_indices
    out[[i]] <- resample_graph.dgCMatrix(out[[i]], self, useR, newids, ...)
    attr(out[[i]], "sample_indices") <- NULL
  }

  return(out)
}

resample_graph.array <-function(graph, self, useR, ...) {
  t   <- dim(graph)[3]
  out <- apply(graph, 3, methods::as, Class="dgCMatrix")

  # Checking time names
  tn <- dimnames(graph)[[3]]
  if (!length(tn)) tn <- 1:t
  names(out) <- tn

  return(resample_graph.list(out, self, useR, ...))
}

bootnet_pval <- function(meanobs, meansim) {
  n <- length(meanobs)
  ans <- vector("numeric",n)
  for (i in 1:n)
    ans[i] <- 2*min(mean(meansim[,i] < 0),
                    mean(meansim[,i] > 0))

  ans
}

#' @rdname bootnet
#' @export
bootnet <- function(
  graph,
  statistic,
  R,
  resample.args = list(self=FALSE),
  ...
) {

  # # Checking class
  # if (!inherits(graph, "diffnet"))
  #   stop("-graph- must be of class diffnet.")

  # Preparing the call to boot
  resample.args$graph <- graph
  statisticpll <- function(d, i, fn, resample.args, ...) {
    g <- do.call(resample_graph, resample.args)
    fn(g, attr(g, "sample_indices"),...)
  }

  # Calling boot
  boot_res <- boot::boot(1, statisticpll, R=R, fn=statistic, resample.args=resample.args,
                         ...)

  # The t0 must be applied with no rewiring!
  boot_res$t0 <- statistic(graph, 1:nnodes(graph), ...)

  # Calc pval
  # To be conservative, in a two tail test we use the min of the two
  # So, following davidson & mckinnon Confidence intrval section,
  # p(tau) = 2 * min[F(tau), 1-F(tau)]
  p.value <- bootnet_pval(boot_res$t0, boot_res$t)

  # Creating the object
  structure(list(
    graph       = graph,
    p.value     = p.value,
    t0          = boot_res$t0,
    mean_t      = colMeans(boot_res$t, na.rm = TRUE),
    var_t       = apply(boot_res$t, 2, var, na.rm=TRUE),
    R           = R,
    statistic   = statistic,
    boot        = boot_res,
    resample.args = resample.args
  ), class="diffnet_bootnet")

}
#
# #' @export
# #' @rdname bootnet
# boot <- bootgraph

#' @export
#' @param recursive Ignored
#' @rdname bootnet
c.diffnet_bootnet <- function(..., recursive=FALSE) {
  # Checking arguments names
  args <- list(...)
  nm <- lapply(args, names)
  if (!all(sapply(nm, function(x) identical(x, nm[[1]]))))
    stop("arguments are not all the same type of \"diffnet_bootnet\" object")

  # Checking

  # Checking graph dim
  res         <- args[[1]]
  res$boot    <- do.call(c, lapply(args, "[[", "boot"))
  # res$p.value <- with(res, 2*min(mean(boot$t < boot$t0),
  #                                mean(boot$t > boot$t0)))
  res$p.value <- bootnet_pval(res$boot$t0, res$boot$t)
  res$mean_t  <- colMeans(res$boot$t, na.rm=TRUE)
  res$var_t   <- apply(res$boot$t, 2, var, na.rm=TRUE)
  res$R       <- res$boot$R

  res
}

#' @export
#' @rdname bootnet
print.diffnet_bootnet <- function(x, ...) {

  # Neat column printing
  netcol <- function(obs, bias, sd, pval) {
    txt <- paste0(sprintf("%10.4f  %10.4f  %10.4f  %10.4f", obs, bias, sd, pval), collapse="\n")
    paste(
      sprintf("%10s  %10s  %10s  %10s", "original", "bias", "std. error", "p.val"),
      txt, sep = "\n"
    )
  }

  with(x,  {
    nsim <- ifelse(!is.na(R), R, 0)

    cat("\nNetwork Bootstrap (Snijders and Borgatti, 1999)\n",
        "# Num. of draws   : ", formatC(nsim, digits = 0, format = "f", big.mark = ","),"\n",
        "# nodes           : ", formatC(nnodes(x$graph), digits = 0, format = "f", big.mark = ","),"\n",
        "# of time periods : ", formatC(nslices(x$graph), digits = 0, format = "f", big.mark = ","),"\n",
        paste(rep("-",options()$width), collapse=""),"\n",
        netcol(t0, t0-apply(boot$t, 2, mean), sqrt(var_t), p.value),"\n",
        sep="")
  })
  invisible(x)
}

#' @export
#' @param b0 Character scalar. When \code{annotated=TRUE}, label for the value of \code{b0}.
#' @param b Character scalar. When \code{annotated=TRUE}, label for the value of \code{b}.
#' @param ask Logical scalar. When \code{TRUE}, asks the user to type \code{<Enter>} to
#' see each plot (as many as statistics where computed).
#' @rdname bootnet
hist.diffnet_bootnet <- function(
  x,
  main      = "Empirical Distribution of Statistic",
  xlab      = expression(Values~of~t),
  breaks    = 20,
  annotated = TRUE,
  b0        = expression(atop(plain("") %up% plain("")), t[0]),
  b         = expression(atop(plain("") %up% plain("")), t[]),
  ask       = TRUE,
  ...) {

  if (ask) {
    oldpar <- par(no.readonly = TRUE)
    on.exit(par(oldpar))
    par(ask=ask)
  }

  for (i in 1:ncol(x$boot$t)) {
    out <- hist(x$boot$t[,i],  breaks=breaks, plot=FALSE)
    ran <- range(out$mids)

    if (annotated) {
      mt <- mean(x$boot$t[,i], na.rm=TRUE)
      ran <- range(c(ran, mt, x$boot$t0[i]))
      hist(x$boot$t[,i], breaks=breaks, main=main, xlab=xlab, xlim = ran, ...)
    } else {
      hist(x$boot$t[,i], breaks=breaks, main=main, xlab=xlab, ...)
    }

    # Adding margin note
    if (annotated) {
      mtext(b0, side = 1, at=x$boot$t0[i])
      mtext(b, side = 1, at=mt)
    }
  }

  invisible(out)
}

#' @export
#' @param y Ignored.
#' @rdname bootnet
#' @details The `plot.diffnet_bootnet` method is a wrapper for the
#' `hist` method.
plot.diffnet_bootnet <- function(x, y, ...) {
  hist.diffnet_bootnet(x = x, ...)
}


#Bioactive molecular networking notebook v1.1 (Optimus)¶
#Website: https://github.com/DorresteinLaboratory/Bioactive_Molecular_Networks

#The bioactive molecular network workflow integrates MS/MS molecular networking and bioassay-guided fractionation into the concept of bioactive molecular networking. The workflow relies on open bioinformatic tools, such MZmine2 [http://mzmine.github.io/] or Optimus (using OpenMS) [https://github.com/MolecularCartography/Optimus], a Jupyter notebook, and the GNPS web-platform (http://gnps.ucsd.edu).

#The code is available as an R script.

#Citation:
#Bioactive molecular networking: Nothias, L.-F.; Nothias-Esposito, M.; da Silva, R.; Wang, M.; Protsyuk, I.; Zhang, Z.; Sarvepalli, A.; Leyssen, P.; Touboul, D.; Costa, J.; Paolini J., Alexandrov T., Litaudon M., Dorrestein, P. Bioactivity-Based Molecular Networking for the Discovery of Drug Leads in Natural Product Bioassay-Guided Fractionation. J. Nat. Prod. 2018.

#Manuscript:
#(Open access) https://pubs.acs.org/doi/10.1021/acs.jnatprod.7b00737

#Instructions to run the notebook
#-> This notebook is suitable for Optimus feature table.

#-> Make sure R is installed in your environment.

#-> Upload your files to the jupyter notebook folder.

#-> In cell 1, update the file name if needed (in red).

#-> Run all cells by clicking on: Cell / Run All Below.

#-> Get the output file table.

# Load and inspect the .CSV features table.
# Change the name in the code below if needed (.CSV file in red)
# NB: Make sure to add the value of bioactivity in the second columns
tab <- read.csv("features_quantification_matrix_edited_bioactivity_Optimus.csv", stringsAsFactor=FALSE, check.names=FALSE)
dim(tab)
tab[1:5,1:5]

# Take out blank rows in the table
if(any(is.na(tab[,2]))) tab <- tab[!is.na(tab[,2]),]

# Add 1 to all to help scaling feature intensities and Normalize the features by TIC
#
tab2 <- tab
tab2[,-c(1:2)] <- t(apply(tab2[,-c(1:2)], 1, function(x) (x+1)/sum((x+1))))

# Calculate the correlation coefficient between a single feature and the bioactivity.
# Scale should help correlation - https://www.ncbi.nlm.nih.gov/pmc/articles/PMC1534033/
cor.test(scale(tab2[,2])[,1], scale(tab2[,3])[,1])[c("estimate", "p.value")]

# How to do for all features
ct <- t(sapply(3:ncol(tab2), function(x) unlist(cor.test(scale(tab2[,2])[,1], scale(tab2[,x])[,1])[c("estimate", "p.value")])))

# Show the dimensions of the features_quantificaton_matrix.csv
dim(tab2)
dim(ct)

# Create an output table with correlation coefficient value and p-value for every features

ct <- rbind(c("cor"," p_value"), c(0,0), ct)

tab3 <- rbind(t(ct),  as.matrix(tab2))
rownames(tab3) <- NULL
tab3[1:5, 1:5]
write.csv(tab3, "features_quantification_matrix_edited_with_correlation.csv", row.names=FALSE)

# Tranpose the table for molecular networking mapping in Cytoscape
new = t(tab3)
colnames(new) = new[1,]
new = new[-1,]
new = cbind(0:(nrow(new)-1), rownames(new), new)
rownames(new) <- NULL
colnames(new)[1:2] <- c("shared name", "IDs")
new[1,1] <- ""
new[1:5,1:5]
write.csv(new, "features_quantification_matrix_transposed_with_correlation.csv", row.names=FALSE)

# Get the significant correlation coefficients for both cases (>0.05)
which(as.numeric(ct[-c(1,2),2])<0.05)

# Show the features ID with correlation coefficient
nm <- colnames(tab)
nm[-c(1:2)][as.numeric(ct[-c(1,2),2])<0.05]

# Display feature ID with correlation coefficient
which(as.numeric(ct[-c(1,2),2])<0.05)

# Table with significant correlation coefficients. Using Bonferroni method.
ct[-c(1,2),][which(p.adjust(as.numeric(ct[-c(1:2),2]), method = "bonferroni")<0.05),]

# Call the ID
which(p.adjust(as.numeric(ct[-c(1:2),2]), method = "bonferroni")<0.05)

# Features passing Bonferronii method
nm[-c(1:2)][which(p.adjust(as.numeric(ct[-c(1:2),2]), method = "bonferroni")<0.05)]

# Prepare the new table
new <- cbind(new[,1:5], c(0, p.adjust(as.numeric(ct[-c(1:2),2]), method = "bonferroni")), new[,-c(1:5)])
colnames(new)[6] <- "p_value_corrected"
new[,1:10]

# Write the final table with corrected p_value
write.csv(new, "features_quantification_matrix_transposed_with_significant_correlation_pvalue_corrected.csv", row.names=FALSE)


library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(dplyr)
library(tidyr)
library(EnvStats)
library(scales)
library(stringr)
library(abind)
library(optparse)
library(ggplot2)
library(ggrepel)
library(gtable)
library(zoo)

JOBID = "276183"

# code for scenarios runs only in full mode
if (FULL){
  source("Italy/code/utils/simulate-regional.r")
  len_forecast <- 8*7

  # Can make plots = TRUE if you want to see 3 panel plots for simulations and rt_plots
  simulate_scenarios(JOBID = JOBID,  StanModel, plots = TRUE, scenario_type = "decrease-com-current", len_forecast = len_forecast,
                     subdir='Italy',
                     simulate_code='Italy/code/stan-models/simulate.stan',
                     mobility_vars=c(1,2,3),
                     compliance_vars=c(4,5,6),
                     mobility_increase = 0,
                     compliance_decrease = 40
                     )
  simulate_scenarios(JOBID = JOBID,  StanModel, plots = TRUE, scenario_type = "decrease-com-current", len_forecast = len_forecast,
                     subdir='Italy',
                     simulate_code='Italy/code/stan-models/simulate.stan',
                     mobility_vars=c(1,2,3),
                     compliance_vars=c(4,5,6),
                     mobility_increase = 0,
                     compliance_decrease = 20
                     )
  simulate_scenarios(JOBID = JOBID,  StanModel, plots = TRUE, scenario_type = "constant-com", len_forecast = len_forecast,
                     subdir='Italy',
                     simulate_code='Italy/code/stan-models/simulate.stan',
                     mobility_vars=c(1,2,3),
                     compliance_vars=c(4,5,6),
                     mobility_increase = 0,
                     compliance_decrease = 0
                     )

  source("Italy/code/utils/make-table.r")
  # Prints attack rates to console
  scenario_type = "constant-com"
  mobility_increase = 0
  compliance_decrease = 0
  make_table_simulation(paste0('Italy/results/sim-', scenario_type, "-", StanModel, '-', len_forecast, '-', compliance_decrease, '-', JOBID, '-stanfit.Rdata'),
                        date_till_percentage = max(dates[[1]]) + len_forecast)

  source("Italy/code/plotting/make-scenario-plots-top7.r")

  make_scenario_comparison_plots_compliance(JOBID = JOBID, StanModel, len_forecast = len_forecast,
                                          last_date_data = max(dates[[1]]) + len_forecast, baseline = FALSE,
                                          compliance_decrease = 20,top=7)
  make_scenario_comparison_plots_compliance(JOBID = JOBID, StanModel, len_forecast = len_forecast,
                                          last_date_data = max(dates[[1]]) + len_forecast, baseline = FALSE,
                                          compliance_decrease = 40,top=7)
  make_scenario_comparison_plots_compliance(JOBID = JOBID, StanModel, len_forecast = len_forecast,
                                          last_date_data = max(dates[[1]]) + len_forecast, baseline = FALSE,
                                          compliance_decrease = 20,top=8)
  make_scenario_comparison_plots_compliance(JOBID = JOBID, StanModel, len_forecast = len_forecast,
                                          last_date_data = max(dates[[1]]) + len_forecast, baseline = FALSE,
                                          compliance_decrease = 40,top=8)
  make_scenario_comparison_plots_compliance(JOBID = JOBID, StanModel, len_forecast = len_forecast,
                                          last_date_data = max(dates[[1]]) + len_forecast, baseline = FALSE,
                                          compliance_decrease = 20,top=9)
  make_scenario_comparison_plots_compliance(JOBID = JOBID, StanModel, len_forecast = len_forecast,
                                          last_date_data = max(dates[[1]]) + len_forecast, baseline = FALSE,
                                          compliance_decrease = 40,top=9)
}


psa <- function(A, B) {

  string_to_vector <- function(x) {
      len <- nchar(x)
      return(substring(x, 1:len, 1:len))
  }

  move_cost <- function() {
      x <- pointer[1]
      y <- pointer[2]
      vertical_gap_penalty <- if (semi_global_mode && pointer[1] == (length(a))) 1 else -1
      vertical_move <- psa_array[x,y - 1] +  if (y > 0) vertical_gap_penalty else -Inf
      horizontal_gap_penalty <- if (semi_global_mode && y == (length(b))) 1 else -1
      horizontalMove <- psa_array[x - 1,y] + if (x > 0) horizontal_gap_penalty else -Inf
      if (x > 1 && y > 1 && a[x - 1] == b[y - 1]) {
        diagonalScore <- 1
        diagonalMove <- psa_array[x - 1,y - 1] + diagonalScore
      }  else {
        diagonalScore <- -Inf
        diagonalMove <- diagonalScore
      }
      moves_cost <- c(vertical_move, horizontalMove, diagonalMove)
      move_types <- rbind(c(0, -1),   # vertical
                          c(-1, 0),   # horizontal
                          c(-1, -1))  # diagonal
      return(c(max(moves_cost), move_types[which.max(moves_cost),]))
  }

    a <-  string_to_vector(A)
    b <- string_to_vector(B)
    a_len <- length(a)
    b_len <- length(b)
    semi_global_mode <-  min(a_len, b_len)/max(a_len, b_len) < 0.6

    psa_array <- array(0, dim=c(a_len+1, b_len+1))
    psa_array[1,] <- if (!semi_global_mode) 0:-b_len
    psa_array[,1] <- if (!semi_global_mode) 0:-a_len

    for (i in 1:a_len+1) {
        for (j in 1:b_len+1) {
            pointer <- c(i, j)
            psa_array[pointer[1], pointer[2]] <- move_cost()[1]
        }
    }

    pointer <- c(a_len+1,b_len+1)
    optimal_move_cost <- psa_array[pointer[1], pointer[2]]
    alignment_path <- c()
    while ((pointer[1] > 2) || (pointer[2] > 2)) {
        best_move <- move_cost()
        move <- best_move[2:3]
        alignment_path <- rbind(alignment_path, move)
        pointer <- pointer + move
    }
    return(tail(c(psa_array),1))
}

psa("ACACT", "ACT")
psa("ATGCTAAGCATA", "TACGATTCGTAT")
psa("ATGCTAAGCATA", "TTAGCTAAGCATA")


# R code
# Luis P. F. Garcia 2018
# Supervised learning classifiers

Adaboost <- function(tran, test) {
  model = AdaBoostM1(class ~ ., tran, control=Weka_control(W="J48"))
  .jcache(model$classifier)
  pred = predict(model, test[,-ncol(test)], type="prob")
  list(model=model, pred=pred)
}

ANN <- function(tran, test) {
  model = MLP(class ~ ., tran)
  .jcache(model$classifier)
  pred = predict(model, test[,-ncol(test)], type="prob")
  list(model=model, pred=pred)
}

C4.5 <- function(tran, test) {
  model = J48(class ~ ., tran)
  .jcache(model$classifier)
  pred = predict(model, test[,-ncol(test)], type="prob")
  list(model=model, pred=pred)
}

CART <- function(tran, test) {
  model = rpart(class ~ ., tran)
  pred = predict(model, test[,-ncol(test)], type="prob")
  list(model=model, pred=pred)
}

kNN <- function(tran, test, k=3) {
  model = kknn(class ~., tran, test[,-ncol(test)], k=k)
  list(model=model, pred=model$prob)
}

RF <- function(tran, test) {
  model = randomForest(class ~ ., tran)
  pred = predict(model, test[,-ncol(test)], type="prob")
  list(model=model, pred=pred)
}

SVM <- function(tran, test) {
  model = svm(class ~ ., tran, kernel="radial", probability=TRUE)
  pred = attr(predict(model, test, probability=TRUE), "probabilities")
  pred = pred[,levels(tran$class)]
  list(model=model, pred=pred)
}

XGBoost <- function(tran, test) {

  tran.y = as.numeric(tran$class) -1
  model = xgboost(as.matrix(tran[,-ncol(tran)]), label=tran.y, nrounds=50,
    num_class=max(tran.y) + 1, objective="multi:softprob", verbose=0)

  pred = predict(model, as.matrix(test[,-ncol(test)]), reshape=TRUE)
  colnames(pred) = levels(tran$class)
  list(model=model, pred=pred)
}

classifiers <- function(tran, test) {
  sapply(CLASSIFIERS, function(c) {
    pred = do.call(c, list(tran, test))
    performance(test$class, pred$pred)
  })
}


#!/usr/bin/Rscript
# Command line arguments for R are not fun... so to make this easy create the args
# by prepending them to this script directly before the R call:
# [bash]$ echo 'arg1 = "value";arg2="someValue"' |cat - script.r | R --no-save
# Variables dataFrame, inputDir, outputDir,  are required
args <- commandArgs(TRUE)

if (length(args) != 3) {
    print("Usage: DESeq.r <dataFrame> <inputDir> <outputDir> <outputFile>")
}

dataFrame <- args[1]
inputDir <- args[2]
outputDir <-args[3]
outputFile <-args[4]

#biocLite("DESeq2");
library(DESeq2);
df = read.delim(dataFrame, header = TRUE, sep = "\t");
ddsHTSeq <- DESeqDataSetFromHTSeqCount(sampleTable = df, directory =inputDir, design=~ condition);
ddsHTSeq$condition <-relevel(ddsHTSeq$condition, ref="reference");
ddsHTSeq <- estimateSizeFactors(ddsHTSeq);
ddsHTSeq <- tryCatch ({
    ddsHTSeq <- estimateDispersions(ddsHTSeq);
    return (ddsHTSeq);
    },
    error = function(e) {
        ddsHTSeq <- estimateDispersionsGeneEst(ddsHTSeq);
        dispersions(ddsHTSeq) <- mcols(ddsHTSeq)$dispGeneEst;
        return (ddsHTSeq);
    }
)
ddsHTSeq<- nbinomWaldTest(ddsHTSeq);
res<-results(ddsHTSeq);

#can I do something like this for deseq2 so we only need one df for each experiment
#res = nbinomTest( cds, condition2, condition1); #this bit needs sorting

#need to make this output relate to the display names etc
fullOutFile = paste(outputDir, outputFile, sep="/");
write.csv( res, file=fullOutFile);