#!/usr/bin/env Rscript

suppressPackageStartupMessages({
  if(!require(data.table)){ install.packages("data.table"); library(data.table) }
  if(!require(tidyverse)){ install.packages("tidyverse"); library(tidyverse) }
  if(!require(optparse)){ install.packages("optparse"); library(optparse) }
})
#########################################
##
## Script used to make sparse GRM file for fastGWA
## for the analyses in the REGENIE 2020 paper
## For more details, visit: https://rgcgithub.github.io/regenie/
##
#########################################

option_list = list(
  make_option("--step1File", type="character", default="",
    help="bed file prefix for step 1", metavar="string"),
  make_option("--prefix", type="character", default="",
    help="output files prefix", metavar="string"),
  make_option("--partition", type="integer", default=0,
    help="partition number for fastGWA GRM computation"),
  make_option("--npartitions", type="integer", default=250,
    help="number of partitions for fastGWA GRM computation")
  );
opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser);

total.partitions <- opt$npartitions
if( opt$partition > total.partitions) stop("Invalid argument")
print(opt)

########### Functions ############
fastGWA.computeGRM <- function(){

  fastGWA.call <- paste0("gcta64 ",
    "--bfile ", bed.file, " ",
    "--thread-num ", parallel::detectCores(), " ",
    "--out ", outprefix, " ",
    "--make-grm-part ", total.partitions, " ", opt$partition)
  print(fastGWA.call)

  tot.time <- system.time({
    system(fastGWA.call)
  })

  write( tot.time, paste0(outprefix, "_time_pt_", opt$partition), ncol = length(tot.time))
}

fastGWA.compute.sparseGRM <- function(){

  ## Combine the partitions
  system( paste0("cat ", outprefix,
      ".part_",total.partitions,"_*.grm.id > ",outprefix, ".grm.id") )
  system( paste0("cat ", outprefix,
      ".part_",total.partitions,"_*.grm.bin > ",outprefix, ".grm.bin") )
  system( paste0("cat ", outprefix,
      ".part_",total.partitions,"_*.grm.N.bin > ",outprefix, ".grm.N.bin") )

  # compute sparse GRM
  fastGWA.call <- paste0("gcta64 ",
    "--grm ", outprefix, " ",
    "--make-bK-sparse 0.05 ",
    "--out ", outprefix, "_sp ")
  system(fastGWA.call)

  if(file.exists( paste0(outprefix, "_sp.grm.id") )){ # in case of error so no need to redo
    system( paste0("rm ", outprefix,".part_",total.partitions,"_*.grm.*") )
  }
}

#################################
outprefix <- opt$prefix
bed.file <- opt$step1File

if( opt$partition > 0 ){ # run fastGWA GRM computation partitions

  fastGWA.computeGRM()

} else if(opt$partition == 0){ # finish fastGWA sparse GRM computation

  tot.time <- system.time({
    fastGWA.compute.sparseGRM()
  })
  write( tot.time, paste0(outprefix, "_time_compSparseGRM"), ncol = length(tot.time))

}


##explore_plink_pvalues.r
##2013-12-17 dmontaner@cipf.es
##2014-06-10 dmontaner@cipf.es
##explore p-value adjustment form plink in the association test results

##' See
##' http://pngu.mgh.harvard.edu/~purcell/plink/anal.shtml#cc
##' for details on the statistical analysis performed by PLINK.

datos <- read.table (file = "f060_res_plink.assoc.adjusted", header = TRUE, as.is = TRUE)
dim (datos)
datos[1:3,]
summary (datos)  ## Notice that there are no missing data.

colnames (datos)

##' Some plots
par (mfrow = c(2,3))
for (co in c ("BONF", "HOLM", "SIDAK_SS", "SIDAK_SD", "FDR_BH", "FDR_BY")) {
    print (co)
    plot (datos[,"UNADJ"], datos[,co], xlim = c(0,1), ylim = c(0,1), xlab = "unadjusted p-value", ylab = "adjusted p-value", main = co)
}


if(! exists("inputFile")){
  args <- commandArgs(TRUE)
  if(length(args) == 0){
    setwd("/scratch/jbrown_lab/shengq2/projects/20191101_chipseq_4074_mouse/macs1callpeak_homer_annotation/result/ILEUM_FXR/")
    inputFile<-"ILEUM_FXR_peaks.name.bed.annotation.stats"
    outputPrefix<-'ILEUM_FXR_peaks.name.bed.annotation.stats'
  }else{
    inputFile<-args[1]
    outputPrefix<-args[2]
  }
}

cat(inputFile, "\n")

options(bitmapType='cairo')
library(ggplot2)
library(ggpubr)

stats<-read.table(inputFile, sep="\t", header=T, stringsAsFactors=F)
detailAnnotationIndex = which(stats$Annotation == "Annotation")
stats<-stats[c(1:(detailAnnotationIndex - 1)),c(1:2)]
colnames(stats)<-c("Category", "PeakNumber")
stats$PeakNumber<-as.numeric(stats$PeakNumber)
stats<-stats[stats$PeakNumber > 0,]
stats<-stats[order(stats$PeakNumber, decreasing=T),]
stats$Category<-factor(stats$Category, levels=(stats$Category))
stats$Percentage<-stats$PeakNumber * 100 / sum(stats$PeakNumber)

write.csv(stats, file=paste0(outputPrefix, ".csv"), row.names=F, quote=F)

legend.font<-element_text(size=14)
pdf(file=paste0(outputPrefix, ".pdf"), width=6, height=5)
g<-ggplot(stats, aes(x="", y=PeakNumber, fill=Category)) + geom_col() + coord_polar(theta = "y", direction = -1) + theme_void() +
	theme(legend.title=legend.font, legend.text=legend.font, legend.margin=margin(c(0,20,0,0)))
print(g)
dev.off()


AGE_LENGTH<-function(adata=Age_w,ldata=Length_w,fyear=2012,type="S"){
  years<-sort(unique(adata$YEAR))
  z<-data.frame(matrix(ncol=4,nrow=1))
  names(z)<-c("YEAR","SEX","AGE","LENGTH" )
  for( i in 1:length(years)){
    x=find_AL(adata,ldata,years[i])
    y1=data.frame(YEAR=years[i],SEX=1,AGE=x$len1$age,LENGTH=x$len1$tl)
    y2=data.frame(YEAR=years[i],SEX=2,AGE=x$len2$age,LENGTH=x$len2$tl)
    z=rbind(z,y1,y2)
    }

  S_length_age<-subset(z,is.na(z$YEAR)==F)

  Total_AGE<-aggregate(list(FREQ=S_length_age$AGE),by=list(SEX=S_length_age$SEX,AGE=S_length_age$AGE,YEAR=S_length_age$YEAR),FUN=length)

  GRID<-expand.grid(SEX=c(1,2),YEAR=years,AGE=c(1:15))
  Total_AGE<-merge(GRID,Total_AGE, all=T)
  Total_AGE$FREQ[is.na(Total_AGE$FREQ)]=0
  Total<-aggregate(list(Total=S_length_age$AGE),by=list(YEAR=S_length_age$YEAR),FUN=length)
  Total_AGE<-merge(Total,Total_AGE, all=T)
  Total_AGE$PROB<-Total_AGE$FREQ/Total_AGE$Total
  Total_AGE<-subset(Total_AGE,select=-c(Total))
  Total_AGE<-Total_AGE[order(Total_AGE$YEAR,Total_AGE$SEX,Total_AGE$AGE),]

  if(type=="S"){
  S_WEIGHT<-SWEIGHT(data2=adata,TA=Total_AGE,fyear=fyear)
  Total_AGE<-merge(Total_AGE,S_WEIGHT[[1]])
  Total_AGE<-Total_AGE[order(Total_AGE$YEAR,Total_AGE$SEX,Total_AGE$AGE),]
  TOTAL_AGE<-list(Total_AGE=Total_AGE,S_WEIGHT=S_WEIGHT)

  }

  if(type=="F"){
  S_WEIGHT=FWEIGHT(data2=adata, sy=1978, fy=fyear)
  Total_AGE<-merge(Total_AGE,S_WEIGHT[[1]])
  Total_AGE<-Total_AGE[order(Total_AGE$YEAR,Total_AGE$SEX,Total_AGE$AGE),]
  TOTAL_AGE<-list(Total_AGE=Total_AGE,F_WEIGHT=S_WEIGHT)

  }
   TOTAL_AGE
 }


aries.samples <- read.csv(file.path(aries.dir, "samplesheet", "samplesheet.csv"), stringsAsFactors=F)
ewas.dat <- sapply(time.points, function(time) {
    ewas <- eval.ret(paste("ewas-handed", time, "full", sep="-"))
    ewas.dat <- as.data.frame(ewas$design)
    ewas.dat <- ewas.dat[,which(colnames(ewas.dat) != "(Intercept)")]
    ewas.dat <- ewas.dat[,grep("handed",colnames(ewas.dat),invert=T)]
    idx <- match(rownames(ewas.dat), aries.samples$Sample_Name)
    if (time %in% child.time.points) {
        ewas.dat$sexM <- NULL  ## will be contributed by PGS model data
        ewas.dat$id <- aries.samples$alnqlet[idx]
    }
    else {
        ewas.dat$id <- aries.samples$aln[idx]
    }
    ewas.dat
})


library(caret)
library(doMC)
library(mmadsenr)
library(futile.logger)
library(dplyr)
library(ggthemes)

# Train and tune random forest classifiers for each of  data sets coming out of the experiment
# "equifinality-4", for binary analysis.
#
# THIS EXPERIMENT AIMS AT DIFFERENTIATING VARIOUS BIASED MODELS FROM ONE ANOTHER

get_tassize_subset_ssize_tadur <- function(df, ssize, tadur) {
  df_tassize_subset <- dplyr::filter(df, sample_size == ssize, ta_duration == tadur)
  df_tassize_subset
}

############### Set up Execution Environment #############

log_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "biasedmodels-classification.log")
flog.appender(appender.file(log_file), name='cl')

clargs <- commandArgs(trailingOnly = TRUE)
if(length(clargs) == 0) {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-population-data.rda")
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-tasampled-data.rda")
} else {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-population-data.rda", args = clargs)
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-tasampled-data.rda", args = clargs)
}

load(pop_data_file)
load(ta_sampled_data_file)
flog.info("Loaded data file: %s", pop_data_file, name='cl')
flog.info("Loaded data file: %s", ta_sampled_data_file, name='cl')

flog.info("Beginning classification analysis of biased models from equifinality-4 data sets", name='cl')

# set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
num_cores <- get_parallel_cores_given_os(dev=TRUE)
flog.info("Number of cores used in analysis: %s", num_cores, name='cl')
registerDoMC(cores = num_cores)

# make this repeatable - comment this out or change it to get a fresh analysis result
seed_value <- 58132133
set.seed(seed_value)
flog.info("RNG seed to replicate this analysis: %s", seed_value, name='cl')

# Set up sampling of train and test data sets
training_set_fraction <- 0.8
test_set_fraction <- 1.0 - training_set_fraction

########### Training and Tuning Variables ##############

#
# Common training and tuning parameters for ctmixtures analysis
#

gbm_grid <- expand.grid(.interaction.depth = (1:6)*2,
                        .n.trees = (2:10)*50,
                        .shrinkage = 0.05)

training_control <- trainControl(method="repeatedcv",
                                 number=10, repeats=5)

############ Setup Results Variables ###############

experiment_names <- c("Pro/Anti Conformism - Census")

bias_results <- data.frame()
bias_results_roc <- NULL
bias_results_model <- NULL
bias_results_cm <- NULL

###### Population Data:  conformist dominant versus anticonformist dominant ######

flog.info("Starting analysis of mixconfdom vs. mixanticonfdom with pop census data", name='cl')

# Row index for results data frame -- bump this by one for each analysis block
i <- 1
exp_name <- experiment_names[i]

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes

eq4_pop_biased <- dplyr::filter(eq4_pop_df, model_class_label != 'allneutral')
eq4_pop_biased_df <- dplyr::filter(eq4_pop_biased, model_class_label != 'mixconfequal')
eq4_pop_biased_df$model_class_label = factor(eq4_pop_biased_df$model_class_label, levels = c("mixconfdom", "mixantidom"))

# Two labels are left:  mixconfdom and mixantidom

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "innovation_rate")

## Train Model ##

bias_dominance_model <- train_gbm_classifier(eq4_pop_biased_df, training_set_fraction, "model_class_label",
                                             gbm_grid, training_control, exclude_columns, verbose=FALSE)
bias_results_model[["bias_dominance_model"]] <- bias_dominance_model$tunedmodel

## Evaluate Model Performance ##

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(bias_dominance_model$tunedmodel, newdata=bias_dominance_model$test_data)
cm <- confusionMatrix(predictions, bias_dominance_model$test_data$model_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments[i] <- exp_name
results$elapsed <- bias_dominance_model$elapsed
bias_results_cm[["bias_dominance_model"]] <- cm

# calculate a ROC curve
bias_dominance_roc <- calculate_roc_binary_classifier(bias_dominance_model$tunedmodel,
                                                      bias_dominance_model$test_data,
                                                      "model_class_label",
                                                      exp_name)
results$auc[i] <- unlist(bias_dominance_roc$auc@y.values)
bias_results_roc[["bias_dominance_model"]] <- bias_dominance_roc

# add to the final data frame
bias_results <- rbind(bias_results, results)

bias_results$sample_size <- 0
bias_results$ta_duration <- 0

########### TA Sampled Analysis #############

flog.info("Starting analysis of mixconfdom vs. mixanticonfdom with tasampled data", name='cl')

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes

eq4_ta_sampled_biased <- dplyr::filter(eq4_ta_sampled_df, model_class_label != 'allneutral')
eq4_ta_sampled_biased_df <- dplyr::filter(eq4_ta_sampled_biased, model_class_label != 'mixconfequal')
eq4_ta_sampled_biased_df$model_class_label = factor(eq4_ta_sampled_biased_df$model_class_label, levels = c("mixconfdom", "mixantidom"))

# get grid of the sample size and TA duration combinations, to tassize_subset the data set
sample_sizes <- unique(eq4_ta_sampled_biased_df$sample_size)
ta_durations <- unique(eq4_ta_sampled_biased_df$ta_dur)

tassize_subsets <- expand.grid(sample_size = sample_sizes, ta_duration = ta_durations)

exclude_columns <- c("simulation_run_id","innovation_rate", "sample_size", "ta_duration")

experiment_names <- character(nrow(tassize_subsets))

# Add experiment names to the tassize_subsets since I didn't do this in the original analysis
for( i in 1:nrow(tassize_subsets)) {
  experiment_names[i] <- paste("Pro/Anti Conformism - Sample Size: ", tassize_subsets[i, "sample_size"], " Duration: ", tassize_subsets[i, "ta_duration"])
}

tassize_biased_results <- data.frame()
tassize_biased_roc <- NULL
tassize_biased_roc_ssize_20 <- NULL
tassize_biased_roc_ssize_10 <- NULL
tassize_biased_model <- NULL
tassize_biased_cm <- NULL

# To create a smaller test dataset:
# test_tasampled_indices <- createDataPartition(eq4_ta_sampled_biased_df$two_class_label, p = 0.05, list=FALSE)
# test_tasampled_df <- eq4_ta_sampled_biased_df[test_tasampled_indices,]
# switch the DF input to get_tassize_subset_ssize_tadur() back to eq4_ta_sampled_biased_df for production

for( i in 1:nrow(tassize_subsets)) {
  exp_name <- experiment_names[i]
  df <- get_tassize_subset_ssize_tadur(eq4_ta_sampled_biased_df,
                              tassize_subsets[i, "sample_size"],
                              tassize_subsets[i, "ta_duration"])
  print(sprintf("row %d:  sample size: %d  ta duration: %d numrows: %d", i, tassize_subsets[i, "sample_size"], tassize_subsets[i, "ta_duration"], nrow(df)))

  #model <- train_randomforest(df, training_set_fraction, fit_grid, fit_control, exclude_columns)
  model <- train_gbm_classifier(df, training_set_fraction, "model_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

  tassize_biased_model[[exp_name]] <- model$tunedmodel

  # use the test data split by the train_randomforest function and calculate tuned model predictions
  # and then get the confusion matrix and fitting metrics
  predictions <- predict(model$tunedmodel, newdata=model$test_data)
  cm <- confusionMatrix(predictions, model$test_data$model_class_label)
  results <- get_parsed_binary_confusion_matrix_stats(cm)
  results$experiments <- experiment_names[i]
  results$elapsed <- model$elapsed
  results$sample_size <- tassize_subsets[i, "sample_size"]
  results$ta_duration <- tassize_subsets[i, "ta_duration"]
  results$experiments <- exp_name
  tassize_biased_cm[[exp_name]] <- cm

  roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "model_class_label", experiment_names[i])
  tassize_biased_roc[[exp_name]] <- roc
  results$auc <- unlist(roc$auc@y.values)

  if(tassize_subsets[i, "sample_size"] == 20) {
    tassize_biased_roc_ssize_20[[exp_name]] <- roc
  }
  if(tassize_subsets[i, "sample_size"] == 10) {
    tassize_biased_roc_ssize_10[[exp_name]] <- roc
  }

  tassize_biased_results <- rbind(tassize_biased_results, results)

}

############## Complete Processing and Save Results ##########

bias_results <- rbind(bias_results, tassize_biased_results)

# we can now use plot_multiple_roc() to plot all the ROC curves on the same plot, etc.
# as well as graph various of the metrics as they vary across sample size and TA duration
#plot_multiple_roc_from_list(bias_results_roc)

# save objects from the environment

# save objects from the environment
if(length(clargs) == 0) {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                              filename = "bias-model-comparisons-gbm.RData")
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                                      filename = "bias-model-comparisons-gbm-dfonly.RData")

} else {
  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                              filename = "bias-model-comparisons-gbm.RData", args = clargs)

  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                                      filename = "bias-model-comparisons-gbm-dfonly.RData", args = clargs)
}

flog.info("Saving combined_results of analysis to R environment snapshot: %s", image_file, name='cl')
save(bias_results, bias_results_model, bias_results_roc, bias_results_cm,
    tassize_biased_cm, tassize_biased_model, tassize_biased_roc, file=image_file)

flog.info("Saving just data frame of results of analysis to R environment snapshot: %s", image_file_results, name='cl')
save(bias_results, file=image_file_results)

# End
flog.info("Analysis bias comparison complete", name='cl')


runQC <- function() {

	options(warn = -1)

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

	## load the library
	library(MSstats)

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

	## Input data
	arguments <- commandArgs(trailingOnly=TRUE);
	#arguments<-c("address", "1", "FALSE", "FALSE", "FALSE", "10", "10")

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	optionnormalize <- arguments[2]

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

	## missing peaks cbox

	inputmissingpeaks <- arguments[3]

	## feature selection input

	optionfeatureselection <- arguments[4]

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

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

	inputremoveproteins <- arguments[5]

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

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

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

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

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

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

	## --------------------------
	## Function: dataProcessPlots
	## visualization
	## --------------------------

	if (class(quantData) != "try-error") {
		cat("\n\n =======================================")
		cat("\n ** Generating dataProcess Plots..... \n \n")

		dataProcessPlots(data=quantData, type="ProfilePlot", address="", width=as.numeric(arguments[6]), height=as.numeric(arguments[7]))
		cat("\n Saved ProfilePlot.pdf \n \n")

		dataProcessPlots(data=quantData, type="QCPlot", address="", width=as.numeric(arguments[6]), height=as.numeric(arguments[7]))
		cat("\n Saved QCPlot.pdf \n \n")

		dataProcessPlots(data=quantData, type="ConditionPlot", address="")
		cat("\n Saved ConditionPlot.pdf \n ")
	}
}

temp <- try(runQC())

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


# Transcription factor binding site identification! With interactions!

# ---- For my implementation: fix the other factors ---- #
cat('Getting binding status from ChIP-seq data!\n')
#bound_from_chip <- as.matrix(read.table('data/binding_mat',header=T))
bound_from_chip <- as.matrix(read.table('fake_data/fake_binding',header=T))

# ---- Constants! ---- #
FACTORS <- colnames(bound_from_chip)
N_FACTORS <- length(FACTORS)
N_PEAKS <- nrow(bound_from_chip)
#N_PEAKS <- 4
N_ITER <- 5
#N_FEATURES <- 1
N_FEATURES <- 3
EM_THRESHOLD <- 0.5
TAU <- 0.2
N_CORES <- 1

# ---- Load functions! ---- #
source('tf2_functions.r')
#.libPaths(new="/home/sh985/R/x86_64-unknown-linux-gnu-library/3.0")
=======
N_CORES <- 8

# ---- Load functions! ---- #
source('tf2_functions.r')
.libPaths(new="/home/sh985/R/x86_64-unknown-linux-gnu-library/3.0")
library(rqhmm)
library(parallel)

# ---- Load Data! ---- #
cat("Getting data!\n")
#fc <- file('data/processed_data.gz',open='r')
fc <- file('fake_data/fd.gz',open='r')
data <- vector("list",N_PEAKS)
for (peak in 1:N_PEAKS){
    buff <- scan(fc,sep=" ",what=numeric(),nlines=(N_FEATURES+1),quiet=TRUE)
    # columns -> number of locations, rows -> number of emission variables (first one will be DNA sequence)
    data[[peak]] <- matrix(buff,nrow=(N_FEATURES+1),byrow=T)
    }
close(fc)
cat("Data loaded!\n")

# ---- Initialise binding status ---- #
# take it from chip!
binding_status <- bound_from_chip
# initialise our target factor (CTCF) to something random...
binding_status[,"CTCF"]<-rbinom(N_PEAKS,1,0.5)
binding_temp <- binding_status
colnames(binding_status)<-FACTORS
colnames(binding_temp)<-FACTORS

# ---- Initialise parameters! ---- # These are all per-factor! Hence lists!
emission_params <- vector("list",N_FACTORS)
transition_params <- vector("list")
motifs<-vector("list")
# per-peak transition params
for (factor in FACTORS){
    transition_params[[factor]] <- vector("list",N_PEAKS)
    motifs[[factor]]<-get_motif(factor)
}

#ctcf_peaks <- which(bound_from_chip[,"CTCF"]==1)
# for testing: only looping over one TF
TEST_FACTORS<-"CTCF"
delta.binding<-vector("numeric")
# ---- The outer loop: 'sample' over binding configurations ---- #
for (iter in 1:N_ITER){
    cat('Iteration',iter,'\n')
    # ---- First middle loop: iterate over each factor! ---- #
    for (factor in TEST_FACTORS){
        cat('Getting binding status for',factor,'\n')
        # get the motif
        pwm <- motifs[[factor]]
        factor_size <- ncol(pwm)
        N_STATES <- factor_size+2
        # initialise emission parameters for this factor
        if (is.null(emission_params[[factor]])){
            cat("No emission parameters saved for ",factor," - making some up!\n")
            emission_params[[factor]] <- matrix(rep(0.5,N_STATES*N_FEATURES),nrow=N_STATES,ncol=N_FEATURES)
        }
        # initialise a blank hmm with the right size... and fixed variables
        factor_hmm <- build_hmm(N_STATES,N_FEATURES,pwm)
        # calculate coincidence of this TF with the rest (used to get a_BF)
        coincidence <- get_interactions(factor,binding_status)
        # when we finish EM we will record binding predictions for all peaks
        all_peaks_bound <- rep(NA,N_PEAKS)
        # initialise the while loop
        delta.ll <- EM_THRESHOLD*2
        ll.old <- -Inf
        EM.iter <- 0
        ll.all <- vector("numeric")
        decrease <- 0
        # ---- Second middle loop: EM! ---- #
        while(abs(delta.ll)>EM_THRESHOLD){
            EM.iter <- EM.iter + 1
            cat("EM iteration",EM.iter,"\n")
            theta_denom <- rep(0,N_STATES)
            theta_numer <- matrix(rep(0,N_STATES*N_FEATURES),nrow=N_STATES,ncol=N_FEATURES)
            # ll over the peaks
            ll_cumulative <- 0

            # parallel section... this will be lengthy
            # ---- Inner 'loop': iterate over peaks! --- #
            peak_results <- mclapply(1:N_PEAKS,eval_peak,factor_hmm,data,transition_params[[factor]],emission_params[[factor]],N_STATES,N_FEATURES,factor,factor_size,binding_status,coincidence,TAU,mc.cores=N_CORES)

            for (peak in 1:N_PEAKS){
                this_peak <- peak_results[[peak]]

                # theta is additive over peaks, remember
                theta <- this_peak$"theta"
                theta_numer <- theta_numer + theta$"theta_numer"
                theta_denom <- theta_denom + theta$"theta_denom"

                # update transition params per-peak
                transition_params[[factor]][[peak]] <- this_peak$"new_trans_params"

                # loglik is additive over peaks
                loglik<-this_peak$"loglik"
                ll_cumulative <- ll_cumulative + loglik

                # bound or not? we only care after EM has converged
                byn <- this_peak$"bound"
                if (byn==1){
                    print("we think this peak is bound!")
                    browser()
                }
                all_peaks_bound[[peak]] <- this_peak$"bound"
            }
            # update emission parameters after all peaks - if commented out, we're avoiding that (due to numerical issues)
#            emission_params[[factor]] <- theta_numer/theta_denom

            # check how the likelihood has changed...
            ll <- ll_cumulative
            delta.ll <- ll-ll.old
#            print(ll)
            if(delta.ll<0){
                cat("ERROR: likelihood is decreasing!\n")
                print(delta.ll)
                decrease = decrease + delta.ll
            }
            ll.old <- ll
            ll.all <- c(ll.all,ll)
        }
        cat("EM has converged!\n")
#        plot(ll.all,type='l',xlab='Iteration',ylab='Log-likelihood')
        cat('lhood decreased by',decrease,'in total\n')

        binding_temp[,factor] <- all_peaks_bound
    }
    # for the purpose of somehow gauging if convergence is occurring
    # visualise_binding(binding_status)
    # using the infinity norm here, for the... fun?
    delta.binding <- c(delta.binding,norm((binding_status-binding_temp),"I"))

    binding_status <- binding_temp
}

# ---- After iteration: retrieve predictions ---- #
cm <- get_confusion_matrix(binding_status,bound_from_chip,FACTORS)
columns<-cbind("TF","TP","FP","TN","FN","sens","spec")
write(columns,file="cm.txt",ncolumns=7,sep="\t")
for (factor in FACTORS){
    write(c(factor,unlist(cm[[factor]])),file="cm.txt",append=TRUE,sep="\t",ncolumns=7)
}
save.image('tf2.RData')


require(PBSadmb)
source("adfunctions.r")

mod1spl<- readList("for_r.dat")
mod1smu<- readList("for_r.dat")

mod1b<- readList("arc/mod1b_r.dat")
mod1c<- readList("arc/mod1c_r.dat")
mod2 <- readList("arc/mod2_r.dat")
mod3 <- readList("arc/mod3_r.dat")
mod4 <- readList("arc/mod4_r.dat")
mod5 <- readList("arc/mod5_r.dat")

# show projections
plt_proj(mod1c)

# show fit to catch biomass
CatchFit(mod1c)

# show spawning biomass relative to population with no fishing
spwn_ratio(mod1c)

# example of writing multiple plots to pdf file:
pdf("agefits.pdf",width=9, height=7)
  AgeFits(mod1c,f=1)
  AgeFits(mod1c,f=2)
  AgeFits(mod1c,f=3)
  AgeFits(mod1c,f=4)
dev.off()

# another example of writing multiple plots to pdf file:
pdf("indices.pdf",width=9, height=7)
    Indices(mod1a,"Model 1a")
    Indices(mod1b,"Model 1b")
    Indices(mod1c,"Model 1c")
    Indices(mod2,"Model 2")
    Indices(mod3,"Model 3")
    Indices(mod4,"Model 4")
    Indices(mod5,"Model 5")
dev.off()

pdf("selectivity.pdf",width=9, height=7)
Mntns(mod1a,"Model 1a")
Mntns(mod1b,"Model 1b")
Mntns(mod1c,"Model 1c")
Mntns(mod2 ,"Model 2")
Mntns(mod3 ,"Model 3")
Mntns(mod4 ,"Model 4")
Mntns(mod5 ,"Model 5")
dev.off()

Mntns_srv(mod1c,"Model 1c")

# Stock recruitment curve
 p.stock.rec(mod1c)
# recruitment hist w/ errors
 p.rec.hist(mod1c,ylab="Age 2 recruitment",fy=1970,ly=2010)

# Fishing mortality
 p.full.f(mod1c,f=2)

# sample sizes
 p.eff.n(mod1c,typ="f")
 p.eff.n(mod1c,typ="f",f=2)
 p.eff.n(mod1c,typ="f",f=3)
 p.eff.n(mod1c,typ="f",f=4)

# spawning biomass and last year's estimates
 p.biom.pol(mod1c,typ="TB")
 lines(mod1a$TotBiom[,1],mod1a$TotBiom[,2],lty=3,lw=3)

# Survey fit
 p.sur.stk(mod1c,f=1)

# Rec
 p.biom.stk(mod1,typ="R")

# Numbers at age
 p.bub.age(mod1c,siz=3000)


layout(matrix(c(1,2),2,1), heights=c(70,30))
par(mar=c(1,1,3,4.5), mgp=c(3,0.8,0), cex=1.0, cex.axis=1.0, cex.lab=1.2)

############################################################
# Asian_ImportExport_plot.r
#
# y - vector of years
# p - vector of annual production amounts

#Asian_ImportExport_plot <- function(countryID='MZM_WORLD',countrylist=c('BP_WORLD'),
#                         datasource='BP_2010',fuel='coal',units='mtoe',
#                         overlay='MZM_NONE',yscalecode='auto',showmap='M',
#                         special_years=c(),special_x=1975,special_y=90,special_text='',
#                         firstyear=1965,lastyear=2009,txt=list()) {

  countryID='MZM_WORLD'
  countrylist=c('BP_WORLD')
  datasource='BP_2010'
  fuel='coal'
  units='mtoe'
  overlay='MZM_NONE'
  yscalecode='auto'
  showmap='M'
  firstyear=1965
  lastyear=2009
  txt=list()

  # Default plotting parameters
  par(las=1, lend='butt')

  # set up map colors
  color_export_map = '#40CC90'
  color_import_map = '#EE5555'
  color_missing_map = 'gray90'
  color_net_0_map = '#AAAAB9'

  # set up plot colors
  color_exports = '#00AA60'
  color_imports = 'firebrick2'  #EE2C2C
  color_consumption = 'black'
  color_production = 'gray80'
  color_production_decades = 'gray75'
  color_guide_lines = 'gray95'
  color_overlay = 'black'
  color_yscalecode = 'black'

  # set up text colors
  color_labels_text = 'black'
  color_production_text = 'gray40'
  color_consumption_text = 'black'
  color_export_text = '#008050'
  color_import_text = 'firebrick3'
  color_overlay_text = 'black'
  color_yscalecode_text = 'black'
  color_missing_text = 'gray80'
  color_net_0_text = '#777799'

  color_map_label_1 = 'black'
  color_map_label_2 = 'black'

  include_plot_label_1 = TRUE  # Consumption
  include_plot_label_2 = TRUE  # Production
  include_plot_label_3 = FALSE # Exports
  include_plot_label_4 = FALSE # Imports

  include_map_label_1 = FALSE
  include_map_label_2 = FALSE

  yscale = 0
  divisor = 1
  # set up defaults for each datasource
  if (fuel == 'coal') {

    # Only 'mtoe' units are available for Coal
    if (units == 'mtoe') {
      divisor = 1
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 600 }
      if (yscalecode == 'world') { yscale = 3500 }
    } else if (units == 'joule') {
      # NOTE:  1 mtoe ~= 0.042 exajoules
      pivisor = 1/0.042
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 25 }
      if (yscalecode == 'world') { yscale = 150 }
    }

  } else if (fuel == 'oil') {

    if (units == 'bbl') {
      divisor = 1000
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 22 }
      if (yscalecode == 'world') { yscale = 85 }
    } else if (units == 'mtoe') {
      divisor = 1
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 1000 }
      if (yscalecode == 'world') { yscale = 4000 }
    } else if (units == 'joule') {
      # NOTE:  1 mtoe ~= 0.042 exajoules
      divisor = 1/0.042
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 40 }
      if (yscalecode == 'world') { yscale = 170 }
    }

  } else if (fuel == 'gas') {

    if (units == 'ft3') {
      divisor = 1
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 65 }
      if (yscalecode == 'world') { yscale = 300 }
    } else if (units == 'mtoe') {
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 650 }
      if (yscalecode == 'world') { yscale = 3000 }
    } else if (units == 'm3') {
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 650 }
      if (yscalecode == 'world') { yscale = 3000 }
    } else if (units == 'joule') {
      # NOTE:  1 mtoe ~= 0.042 exajoules
      divisor = 1/0.042
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 25 }
      if (yscalecode == 'world') { yscale = 120 }
    }

  } else if (fuel == 'nuclear') {

    if (units == 'twh') {
      divisor = 1
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 800 }
      if (yscalecode == 'world') { yscale = 3000 }
    } else if (units == 'mtoe') {
      divisor = 1
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 200 }
      if (yscalecode == 'world') { yscale = 700 }
    } else if (units == 'joule') {
      # NOTE: 1 Terawatt-hour = 0.0036 Exajoules
      divisor = 1 / 0.0036
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 3 }
      if (yscalecode == 'world') { yscale = 12 }
    }

  } else if (fuel == 'hydro') {

    if (units == 'twh') {
      divisor = 1
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 300 }
      if (yscalecode == 'world') { yscale = 3000 }
    } else if (units == 'mtoe') {
      divisor = 1
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 75 }
      if (yscalecode == 'world') { yscale = 750 }
    } else if (units == 'joule') {
      # NOTE: 1 Terawatt-hour = 0.0036 Exajoules
      divisor = 1 / 0.0036
      if (yscalecode == 'auto') { yscale = 0 }
      if (yscalecode == 'us') { yscale = 2 }
      if (yscalecode == 'world') { yscale = 12 }
    }

  } else {

    divisor = 1

  }

  # For testing the EIA data
  if (datasource == 'EIA_2008' && fuel == 'oil') {
    divisor = 1000
  }

  # Defaults for named labels
  map_label_1 = ''
  map_label_2 = ''
  special_note = ''
  warning_text = ''

  # Set up arrays of zeroes and NA's
  y = c(firstyear:lastyear)
  y_p = y + 0.5
  y_p1 = y + 1.0
  y_m = y - 0.5
  zeroes = y * 0.0
  missing = y * NA
  n = lastyear - firstyear + 1

  # Create the production and consumption data frames:
  # 1) read in the CSV file, applying the appropriate row names
  # 2) leave out the columns for 'country', 'change' and 'share of total'
  # 3) transpose to get countries as columns, years as rows (converts to matrix)
  # 4) convert back into data frame

  if (units == 'joule') {
    if (fuel == 'nuclear' || fuel == 'hydro') {
      filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_',fuel,'_consumption_twh.csv',sep='',collapse='')
    } else {
      filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_',fuel,'_consumption_mtoe.csv',sep='',collapse='')
    }
  } else {
    ###filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_',fuel,'_consumption_',units,'.csv',sep='',collapse='')
    filename = paste('./',datasource,'_',fuel,'_consumption_',units,'.csv',sep='',collapse='')
  }
  c1 = read.csv(file=filename,header=TRUE,skip=6,row.names=1,na.strings=c('na'),strip.white=TRUE)
  c2 = c1[,1:n] / divisor
  c3 = t(c2)
  c4 = as.data.frame(c3)

  # Production data exist for all fuel types except 'nuclear' and 'hydro' where BP assumes production = consumption
  if (fuel == 'nuclear' || fuel == 'hydro') {
    p4 = c4
  } else {
    if (units == 'joule') {
      filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_',fuel,'_production_mtoe.csv',sep='',collapse='')
    } else {
      ###filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_',fuel,'_production_',units,'.csv',sep='',collapse='')
      filename = paste('./',datasource,'_',fuel,'_production_',units,'.csv',sep='',collapse='')
    }
    p1 = read.csv(file=filename,header=TRUE,skip=6,row.names=1,na.strings=c('na'),strip.white=TRUE)
    p2 = p1[,1:n] / divisor
    p3 = t(p2)
    p4 = as.data.frame(p3)
  }

cn_net_exports = p4[['CN']] - c4[['CN']]
in_net_exports = p4[['IN']] - c4[['IN']]
jp_net_exports = p4[['JP']] - c4[['JP']]
kr_net_exports = p4[['KR']] - c4[['KR']]
tw_net_exports = zeroes - c4[['TW']]
au_net_exports = p4[['AU']] - c4[['AU']]
id_net_exports = p4[['ID']] - c4[['ID']]

net_exports = cn_net_exports + in_net_exports + jp_net_exports + kr_net_exports + tw_net_exports + au_net_exports + id_net_exports

cn_ex = pmax(zeroes,cn_net_exports)
cn_im = pmin(zeroes,cn_net_exports)
in_ex = pmax(zeroes,in_net_exports)
in_im = pmin(zeroes,in_net_exports)
jp_ex = pmax(zeroes,jp_net_exports)
jp_im = pmin(zeroes,jp_net_exports)
kr_ex = pmax(zeroes,kr_net_exports)
kr_im = pmin(zeroes,kr_net_exports)
tw_ex = pmax(zeroes,tw_net_exports)
tw_im = pmin(zeroes,tw_net_exports)
au_ex = pmax(zeroes,au_net_exports)
au_im = pmin(zeroes,au_net_exports)
id_ex = pmax(zeroes,id_net_exports)
id_im = pmin(zeroes,id_net_exports)

ex1 = jp_ex
ex2 = jp_ex + kr_ex
ex3 = jp_ex + kr_ex + tw_ex
ex4 = jp_ex + kr_ex + tw_ex + in_ex
ex5 = jp_ex + kr_ex + tw_ex + in_ex + au_ex
ex6 = jp_ex + kr_ex + tw_ex + in_ex + au_ex + id_ex
ex7 = jp_ex + kr_ex + tw_ex + in_ex + au_ex + id_ex + cn_ex

im1 = jp_im
im2 = jp_im + kr_im
im3 = jp_im + kr_im + tw_im
im4 = jp_im + kr_im + tw_im + in_im
im5 = jp_im + kr_im + tw_im + in_im + au_im
im6 = jp_im + kr_im + tw_im + in_im + au_im + id_im
im7 = jp_im + kr_im + tw_im + in_im + au_im + id_im + cn_im

lwd = 18
lwd_net_exports = 1
lwd_zero_line = 1
color_net_exports = 'black'
color_zero_line = 'white'
color_cn = 'purple'
color_au = 'gray40'
color_id = 'gray60'
color_in = 'deepskyblue2' #00B2EE
color_tw = 'deepskyblue3' #009ACD
color_kr = '#0077A8' #
color_jp = '#006080' # 'deepskyblue' = #00688B

color_exports = '#00AA60'
color_imports = 'firebrick2'  #EE2C2C

color_labels_text = 'black'

plot(ex7 ~ y_p, axes=FALSE, type='h', lwd=lwd,
              xlim=c(1980,2010),ylim=c(-350,350),
              main='', xlab='', ylab='',
              col=color_exports)
axis(1,line=-1.0)
axis(4,las=1)

points(ex6 ~ y_p,type='h',lwd=lwd,col=color_id) # indonesia
points(ex5 ~ y_p,type='h',lwd=lwd,col=color_au) # australia
points(ex4 ~ y_p,type='h',lwd=lwd,col=color_in) # india
points(ex3 ~ y_p,type='h',lwd=lwd,col=color_tw) # taiwan
points(ex2 ~ y_p,type='h',lwd=lwd,col=color_kr) # korea
points(ex1 ~ y_p,type='h',lwd=lwd,col=color_jp) # japan

points(im7 ~ y_p,type='h',lwd=lwd,col=color_imports)
points(im6 ~ y_p,type='h',lwd=lwd,col=color_id)
points(im5 ~ y_p,type='h',lwd=lwd,col=color_au)
points(im4 ~ y_p,type='h',lwd=lwd,col=color_in)
points(im3 ~ y_p,type='h',lwd=lwd,col=color_tw)
points(im2 ~ y_p,type='h',lwd=lwd,col=color_kr)
points(im1 ~ y_p,type='h',lwd=lwd,col=color_jp)

abline(h=0,col=color_zero_line,lwd=lwd_zero_line)

# Add year guides (thin gray lines that mark the decades)
guide_years = c(1980,1985,1990,1995,2000,2005)
guide_indices = c(16,21,26,31,36,41)
guides = ex7[guide_indices]
points(guides ~ guide_years, type='h', lwd=1, col=color_guide_lines)
guides = im7[guide_indices]
points(guides ~ guide_years, type='h', lwd=1, col=color_guide_lines)

# Add the axis labels
mtext(text='million tonnes oil equivalent',side=4,line=3.0,cex=1.0,las=0,xpd=NA)

# Add the upper legend
leg_x = 1980.5
leg_y = 350
leg_xjust = 0
leg_yjust = 1
text = c('China (net export years)','Indonesia','Australia')
cols = c(color_exports,color_id,color_au)
pchs = c(15)
pt.cexs = c(1.2)
text.cols = c('black')
legend(x=leg_x, y=leg_y, xjust=leg_xjust, yjust=leg_yjust, bty='n', bg="white",
       legend=text,col=cols,pch=pchs,pt.cex=pt.cexs,cex=1.0,text.col=text.cols)

# Add the upper legend
leg_x = 1980.5
leg_y = -100
leg_xjust = 0
leg_yjust = 1
text = c('Japan','Korea','Taiwan','India','China (net import years)')
cols = c(color_jp,color_kr,color_tw,color_in,color_imports)
pchs = c(15)
pt.cexs = c(1.2)
text.cols = c('black')
# Add a legend
legend(x=leg_x, y=leg_y, xjust=leg_xjust, yjust=leg_yjust, bty='n', bg="white",
       legend=text,col=cols,pch=pchs,pt.cex=pt.cexs,cex=1.0,text.col=text.cols)

title(main="Asia's major coal exporters and importers",line=0.5,cex.main=1.6)

#}

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

par(mar=c(2,1,3,4.5), mgp=c(3,0.8,0), cex=1.0, cex.axis=1.0, cex.lab=1.2)

plot(cn_ex ~ y_p, axes=FALSE, type='h', lwd=lwd,
                      xlim=c(1980,2010),ylim=c(-60,60),
                      main='', xlab='', ylab='',
                      col=color_exports)

#axis(1)
axis(4,las=1)
points(cn_im ~ y_p,type='h',lwd=lwd,col=color_imports)

# Add year guides (thin gray lines that mark the decades)
guide_years = c(1980,1985,1990,1995,2000,2005)
guide_indices = c(16,21,26,31,36,41)
guides = cn_ex[guide_indices]
points(guides ~ guide_years, type='h', lwd=1, col=color_guide_lines)
guides = cn_im[guide_indices]
points(guides ~ guide_years, type='h', lwd=1, col=color_guide_lines)

# Add total imports
points(net_exports ~ y,type='s',lwd=lwd_net_exports,col=color_net_exports)
points(net_exports ~ y_p1,type='S',lwd=lwd_net_exports,col=color_net_exports)

# Add the axis labels
#mtext(text=txt$year,side=1,line=0.8,cex=1.0,adj=0,xpd=TRUE)
mtext(text='mtoe',side=4,line=2.5,cex=1.0,las=0,xpd=NA)

# Add the legend
leg_x = 1980.5
leg_y = -50
leg_xjust = 0
leg_yjust = 1
#text = c('Total Imports/Exports','China (exports)','China (imports)')
text = c('Total Imports/Exports')
#cols = c(color_net_exports,color_exports,color_imports)
cols = c(color_net_exports)
#pchs = c(15,15,15)
pt.cexs = c(1.2)
text.cols = c('black')

title(main="China's role in total net exports",line=0.5,cex.main=1.4)

# Add the mazamascience.com and datasource attribution
###subtitle = 'Data: BP Statistical Review 2010    Graphic: mazamascience.com'
###title(main=txt$subtitle,line=0.0,family='Times',col=color_labels_text,xpd=NA)

title(sub="Data: BP Statistical Review 2010    Graphic: mazamascience.com",line=0.5,family='Times',cex.main=1.0)


#' read newick files, copied directly from phytools
#' @param file file path
#' @param text text string
#' @export
#' @keywords internal
read_newick <- function (file = "", text)
{
    if (file != "")
        text <- scan(file, sep = "\n", what = "character")
    if (length(text) > 1) {
        tree <- lapply(text, newick)
        class(tree) <- "multiPhylo"
    }
    else tree <- newick(text)
    return(tree)
}

#' Newick function required by read_newick
#' @param text input text
#' @export
#' @keywords internal
newick <- function (text)
{
    text <- unlist(strsplit(text, NULL))
    tip.label <- vector(mode = "character")
    node.label <- vector(mode = "character")
    edge <- matrix(c(1, NA), 1, 2)
    edge.length <- vector()
    currnode <- 1
    Nnode <- currnode
    i <- j <- k <- 1
    while (text[i] != ";") {
        if (text[i] == "(") {
            if (j > nrow(edge))
                edge <- rbind(edge, c(NA, NA))
            edge[j, 1] <- currnode
            i <- i + 1
            if (is.na(match(text[i], c("(", ")", ",", ":", ";")))) {
                temp <- get_label(text, i)
                tip.label[k] <- temp$label
                i <- temp$end
                edge[j, 2] <- -k
                k <- k + 1
                if (text[i] == ":") {
                  temp <- getEdgeLength(text, i)
                  edge.length[j] <- temp$edge.length
                  i <- temp$end
                }
            }
            else if (text[i] == "(") {
                Nnode <- Nnode + 1
                currnode <- Nnode
                edge[j, 2] <- currnode
            }
            j <- j + 1
        }
        else if (text[i] == ")") {
            i <- i + 1
            if (is.na(match(text[i], c("(", ")", ",", ":", ";")))) {
                temp <- get_label(text, i)
                node.label[currnode] <- temp$label
                i <- temp$end
            }
            if (text[i] == ":") {
                temp <- getEdgeLength(text, i)
                if (currnode > 1) {
                  ii <- match(currnode, edge[, 2])
                  edge.length[ii] <- temp$edge.length
                }
                else root.edge <- temp$edge.length
                i <- temp$end
            }
            if (currnode > 1)
                currnode <- edge[match(currnode, edge[, 2]),
                  1]
        }
        else if (text[i] == ",") {
            if (j > nrow(edge))
                edge <- rbind(edge, c(NA, NA))
            edge[j, 1] <- currnode
            i <- i + 1
            if (is.na(match(text[i], c("(", ")", ",", ":", ";")))) {
                temp <- get_label(text, i)
                tip.label[k] <- temp$label
                i <- temp$end
                edge[j, 2] <- -k
                k <- k + 1
                if (text[i] == ":") {
                  temp <- getEdgeLength(text, i)
                  edge.length[j] <- temp$edge.length
                  i <- temp$end
                }
            }
            else if (text[i] == "(") {
                Nnode <- Nnode + 1
                currnode <- Nnode
                edge[j, 2] <- currnode
            }
            j <- j + 1
        }
    }
    Ntip <- k - 1
    edge[edge > 0] <- edge[edge > 0] + Ntip
    edge[edge < 0] <- -edge[edge < 0]
    edge.length[is.na(edge.length)] <- 0
    if (length(edge.length) == 0)
        edge.length <- NULL
    node.label[is.na(node.label)] <- ""
    if (length(node.label) == 0)
        node.label <- NULL
    tree <- list(edge = edge, Nnode = as.integer(Nnode), tip.label = tip.label,
        edge.length = edge.length, node.label = node.label)
    class(tree) <- "phylo"
    return(tree)
}

#' get label function from phytools
#' @param text input text
#' @param start start at
#' @export
#' @keywords internal
get_label <- function (text, start)
{
    i <- 0
    label <- vector()
    while (is.na(match(text[i + start], c(",", ":", ")")))) {
        label[i + 1] <- text[i + start]
        i <- i + 1
    }
    return(list(label = paste(label, collapse = ""), end = i +
        start))
}


library(singleCellNet)
library(Seurat)

######################### Section I: Load Training Data and Seurat DATA ########################
#loading training data
stPrim <- utils_loadObject(fname = "meta_primary.rda")  #metadata
stPrim<-stPrim[!(stPrim$Subtype=="Outlier"),] # Remove outlier from calculus
expPrim <- utils_loadObject(fname = "mat_primary_2.rda")  #expression matrix
stPrim <- droplevels(stPrim)

#loading query data
clustered_seurat <- readRDS("JH_org_sc_seurat_integrated_CCA_2batch_clustered.rds")
stOrganoid = clustered_seurat@meta.data         #metadata
expOrganoid = clustered_seurat@assays$RNA@counts                        #expression
stOrganoid$cell <- rownames(stOrganoid) #Add rownames as column "cell"
genesOrganoid = rownames(expOrganoid)

# Find genes in common to the datasets and limit analysis to these
commonGenes = intersect(rownames(expPrim), genesOrganoid)
expPrim = expPrim[commonGenes,]

######################### Section II: Begin Training Dataset & QC ###############################

# Split for training and assessment, and transform training data
set.seed(100) #can be any random seed number
stList = splitCommon(sampTab=stPrim, ncells=100, dLevel="Subtype")
stTrain = stList[[1]]
expTrain = expPrim[,rownames(stTrain)]

system.time(class_info<-scn_train(stTrain = stTrain, expTrain = expTrain, nTopGenes = 75,
	nRand = 70, nTrees = 1000, nTopGenePairs = 150, dLevel = "Subtype", colName_samp = "cell"))

#validate data
stTestList = splitCommon(sampTab=stList[[2]], ncells=100, dLevel="Subtype") #normalize validation data so that the assessment is as fair as possible
stTest = stTestList[[1]]
expTest = expPrim[commonGenes,rownames(stTest)]

#predict
classRes_val_all = scn_predict(cnProc=class_info[['cnProc']], expDat=expTest, nrand = 70)
tm_heldoutassessment = assess_comm(ct_scores = classRes_val_all, stTrain = stTrain,
	stQuery = stTest, dLevelSID = "cell", classTrain = "Subtype", classQuery = "Subtype", nRand = 70)

# Plot Dot Plots, EMAPS
pdfFN <- function(path, object){
  pdf(path, width = 7, height = 11)
  print(object)
  dev.off()
}

#Create a name vector label used later in classification heatmap where the values are cell types/ clusters and names are the sample names
nrand = 70
sla = as.vector(stTest$Subtype)
names(sla) = as.vector(stTest$cell)
slaRand = rep("rand", nrand)
names(slaRand) = paste("rand_", 1:nrand, sep='')
sla = append(sla, slaRand) #include in the random cells profile created

# Assess Clarifier
pdfFN("tm_heldoutassessment.pdf", plot_PRs(tm_heldoutassessment))
pdfFN("tm_heldoutassessment.pdf", plot_metrics(tm_heldoutassessment))

# Classification result heatmap
pdfFN("sc_hmClass.pdf", sc_hmClass(classMat = classRes_val_all,grps = sla, max=300, isBig=TRUE))

# Attribution Plot
pdfFN("plot_attr.pdf",plot_attr(classRes=classRes_val_all, sampTab=stTest, nrand=nrand, dLevel="Subtype", sid="cell"))

# Visualize average top pairs genes expression for training data

gpTab = compareGenePairs(query_exp = expTest, training_exp = expTrain, training_st = stTrain, classCol = "Subtype", sampleCol = "cell", RF_classifier = class_info$cnProc$classifier, numPairs = 20, trainingOnly= TRUE)
train = findAvgLabel(gpTab = gpTab, stTrain = stTrain, dLevel = "Subtype")
pdfFN("top_pairs.pdf", hm_gpa_sel(gpTab, genes = class_info$cnProc$xpairs, grps = train, maxPerGrp = 50))

############################## SECTION III: Apply Trained Datasets to Organoid Data ##########################

nqRand = 70
system.time(crOrganoidall<-scn_predict(class_info[['cnProc']], expOrganoid, nrand=nqRand))

sgrp = as.vector(stOrganoid$integrated_snn_res.0.1)
names(sgrp) = as.vector(stOrganoid$cell)
grpRand =rep("rand", nqRand)
names(grpRand) = paste("rand_", 1:nqRand, sep='')
sgrp = append(sgrp, grpRand)

# This classifies a cell with  the catgory with the highest classification score or higher than a classification score threshold of your choosing.
# The annotation result can be found in a column named category in the query sample table.
stOrganoid <- get_cate(classRes = crOrganoidall, sampTab = stOrganoid, dLevel = "integrated_snn_res.0.1", sid = "cell", nrand = nqRand)

# heatmap classification result
pdfFN("hm_Organoid_all.pdf", sc_hmClass(crOrganoidall, sgrp, max=5000, isBig=TRUE, cCol=F, font=8))
pdfFN("violin_Organoid_all.pdf", sc_violinClass(sampTab = stOrganoid, classRes = crOrganoidall, sid = "cell", dLevel = "integrated_snn_res.0.1", addRand = nqRand))

saveRDS(crOrganoidall, file="crOrganoidall.rds")
saveRDS(expTrain, file="expTrain.rds")
saveRDS(stTrain, file="stTrain.rds")
saveRDS(stOrganoid, file="stOrganoid.rds")
write.csv(t(crOrganoidall),"crOrganoidall.csv")
write.csv(stOrganoid,"stOrganoid.csv")


require("shiny")
require("reshape")
require("ggplot2")
require("plotly")

#1. use require instead of library
#2. four functions: name.tabPanel
#                   name.siderbarPanel
#                   name.prepareData
#                   name.preparePlot
#3. profile to pass parameters for specific data
#4. function fileLocate to locate the date in selected folder
#5. In prepareData, use <<- instead of <- or == to bring the reactive variable out
#6. name each variables with prefix to aviod name conflict
#7  global data frame sampleInfo as the sample profiles
#8. touch server.R to enforce the update
#9. use conditionalPanel in sidebarPanel
#10. global data frame all_parameters to get folder specific parameters
#11. reactive data is shareable
#12. To use the module for one data, put "tools	toolname" in main.profile in the folder
#13. To add parameter for a module for a folder, put "key	value" in toolname in the folder

indBoxplot.tabPanel<-function(profile){
	tabPanel("Box Plot", plotOutput("indBoxplot.plot",width="100%",height = paste(30+120*length(indBoxSig.data()),"px",sep="") ))
#	tabPanel("Box Plot", plotlyOutput("indBoxplot.plot",width="100%",height ="3000px" ))
}
indBoxplot.sidebarPanel<-function(profile,input,session){
	conditionalPanel(condition = "input.tabs1 == 'Box Plot'",
		h5("The box plots only show measurements with statistically significant differences between the groups, defined by \"Group by\", if the number of measurements is larger than 32. The data point of the selected individual is highlighted by a triangular mark in each box plot."),
        #h4(paste(nrow(profile),"rows")),h5(title),h5(subtitle),
		h5(profile$profile_value[profile$profile_key=="desc"])
	)
}

#indBoxplot.prepareData<-function(input){
	indBoxSig.data  <- reactive({
		filename=paste(input$group_by,"sigs.csv",sep="_")
		if(file.exists(fileLocate(filename))){
			sigs<-read.csv(fileLocate(filename))
			sigs<-as.character(sigs$x)
		}
		else{
		share.data=share.data()
		if(length(levels(share.data$variable))>32){
			share.data=share.data[!is.na(share.data$value),]
			ss=split(share.data, share.data$variable)
			f=as.formula(paste("value~",input$group_by))
			uniqp=lapply(ss,function(xx) length(unique(xx[,input$group_by])))
			s2=ss[which(uniqp==2)]
			pp=lapply(s2,function(xx) wilcox.test(f,xx)$p.value)
			sigs=names(which(pp<0.05))
			if(length(sigs)>32){
				sigs=names(which(pp<0.01))

			}
		}
		else{
			sigs=levels(share.data$variable)
		}
			write.csv(sigs,fileLocate(filename),row.names=F)
		}
		sigs

	})
#}

#indBoxplot.preparePlot<-function(input,output){
	output$indBoxplot.plot<- renderPlot({
		data=share.data()
		data=data[data$variable %in% indBoxSig.data(),]
		data$variable=as.factor(as.character(data$variable))
		levels(data$variable)=swr(levels(data$variable))
		data$mark=data$SampleID==input$sample
	  p<-ggplot(data,aes_string(x=input$group_by,y="value"))+
    geom_boxplot(aes_string(fill=input$group_by))+
    geom_jitter(aes(samid=SampleID,shape=mark,size=mark),width=0.1,height=0)+facet_wrap(~variable,scales = "free",ncol=4,strip.position="left")+
		theme(legend.position="none",strip.placement="outside")
	     # use geom_jitter instead of geom_point so that points with the same value could be separated
	#	ggplotly(p,source="indBoxplot.plot")
		p
  })

#}


rm(list=ls())
options(width = 120)

# read from clipboard
d <- read.table(pipe("xclip -selection clipboard -o", open="r"), sep = "\t", header = TRUE)
d[is.na(d)] <- 0
str(d)
head(d)
d[1,]
colnames(d)

d2 <- d # duplicate
d <- d2

# clean
sel <- which(colnames(d) %in% c("ID_SECCION","CASILLA"))
d <- d[,-sel]

# turn characters into NAs
sel <- c(2)
tmp <- d[,-sel]
tmp <- lapply(tmp, as.numeric)
tmp <- as.data.frame(do.call(cbind,tmp))
tmp[is.na(tmp)] <- 0
head(tmp)
d[,-sel] <- tmp

d[2,]
colnames(d)

d <- within(d, expr = {
PAN <- ave(PAN, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PRI <- ave(PRI, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PRD <- ave(PRD, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PT <- ave(PT, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PVEM <- ave(PVEM, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
MC <- ave(MC, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
MORENA <- ave(MORENA, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
NAEM <- ave(NAEM, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PES <- ave(PES, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
RSP <- ave(RSP, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
FXM <- ave(FXM, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PAN_PRI_PRD <- ave(PAN_PRI_PRD, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PAN_PRI <- ave(PAN_PRI, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PAN_PRD <- ave(PAN_PRD, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PRI_PRD <- ave(PRI_PRD, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PT_MORENA_NAEM <- ave(PT_MORENA_NAEM, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PT_MORENA <- ave(PT_MORENA, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PT_NAEM <- ave(PT_NAEM, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
MORENA_NAEM <- ave(MORENA_NAEM, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
PT_MORENA_NAEM.CANDIDATURA.COMUN <- ave(PT_MORENA_NAEM.CANDIDATURA.COMUN, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_1 <- ave(C_I_1, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_2 <- ave(C_I_2, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_3 <- ave(C_I_3, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_4 <- ave(C_I_4, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_5 <- ave(C_I_5, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_6 <- ave(C_I_6, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_7 <- ave(C_I_7, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_8 <- ave(C_I_8, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_9 <- ave(C_I_9, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_10 <- ave(C_I_10, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_11 <- ave(C_I_11, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_12 <- ave(C_I_12, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_13 <- ave(C_I_13, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_14 <- ave(C_I_14, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
C_I_15 <- ave(C_I_15, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
NO_REGISTRADOS <- ave(NO_REGISTRADOS, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
NULOS <- ave(NULOS, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
VOTOS.VALIDOS <- ave(VOTOS.VALIDOS, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
TOTAL <- ave(TOTAL, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
LISTA.NOMINAL <- ave(LISTA.NOMINAL, as.factor(ID_MUNICIPIO), FUN=sum, na.rm=TRUE);
}
)

# drop redundant rows
d <- d[duplicated(as.factor(d$ID_MUNICIPIO))==FALSE,]
dim(d)
head(d)

# rename some cols
sel <- grep("LISTA", colnames(d))
colnames(d)[sel] <- "lisnom"
sel <- grep("NO.REG", colnames(d))
colnames(d)[sel] <- "nr"
sel <- grep("NULOS", colnames(d))
colnames(d)[sel] <- "nul"
sel <- grep("ID_ESTADO", colnames(d))
colnames(d)[sel] <- "edon"
sel <- grep("ID_DISTRITO", colnames(d))
colnames(d)[sel] <- "disn"
sel <- grep("NOMBRE_DIS", colnames(d))
colnames(d)[sel] <- "cabecera"

# add coals

# write to clipboard to export to excel
clipboard <- function(x, sep=",", row.names=FALSE, col.names=TRUE){
     con <- pipe("xclip -selection clipboard -i", open="w")
     write.table(x, con, sep=sep, row.names=row.names, col.names=col.names)
     close(con)
}

clipboard(d)

######################
## mich excel files ##
######################

library(xlsx)
source("~/Dropbox/data/useful-functions/notin.r")
setwd("/home/eric/Downloads/Desktop/MXelsCalendGovt/elecReturns/datosBrutos/not-in-git/resultCasillas/subnat/mic2021ayca")

all.f <- dir()

# get all colnames
all.n <- c()
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.xlsx(all.f[i], sheetIndex = 1)
    #d[1,]
    all.n <- c(all.n, colnames(d))
}
all.n <- all.n[duplicated(all.n)==FALSE]
all.n <- all.n[-which(all.n %in% c("Distrito","Cabecera.distrital","Sección","Casilla","Recuento"))]
all.n <- all.n[order(all.n)]

# get all files, colSums into new object
new.o <- matrix(rep(0, length(all.n)), nrow = 1)
new.o  <- data.frame(new.o); colnames(new.o)  <- all.n; new.o$Municipio <- "drop this obs"
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.xlsx(all.f[i], sheetIndex = 1)
    #str(d)
    #d[1,]
    tmp.n <- which(all.n %notin% colnames(d)) # missing columns
    tmp.x <- matrix(0, nrow=nrow(d), ncol=length(tmp.n))
    tmp.x <- data.frame(tmp.x); colnames(tmp.x) <- all.n[tmp.n]
    d <- cbind(d, tmp.x)
    tmp <- d[1,which(colnames(d) %in% c("Municipio"))] # keep mun
    tmp2 <- d[1,which(colnames(d) %in% c("Cve..Municipio"))] # keep ife
    d <- colSums(d[,-which(colnames(d) %in% c("Municipio","Cve..Municipio","Distrito","Cabecera.distrital","Sección","Casilla","Recuento"))], na.rm=TRUE)
    d <- c(Municipio=tmp, Cve..Municipio=tmp2, d) # paste mun
    d <- d[order(names(d))]
    new.o <-
        rbind(new.o, d)
#    assign(d, paste0("f", sub("^([0-9]+)[,].+", "\\1", all.f[i]))) # rename object
}

clipboard(new.o)

new.o[1,]

#####################
## cua excel files ##
#####################
rm(list = ls())
#library(xlsx)
library(readxl)
source("~/Dropbox/data/useful-functions/notin.r")
f <- "/home/eric/Downloads/Desktop/MXelsCalendGovt/elecReturns/datosBrutos/not-in-git/resultCasillas/subnat/cua2021ay-casilla.xlsx"

# get all colnames
all.n <- c()
for (i in 1:67){
    #i <- 11
    message(sprintf("loop %s", i))
    #d <- read.xlsx(f, sheetIndex = i)
    #d <- read.xlsx(f, sheetIndex = i, header = FALSE, startRow = 1, endRow = 1)
    d <- read_excel(f, sheet = i)
    #d[1,]
    all.n <- c(all.n, colnames(d))
    rm(d)
}
all.n <- all.n[duplicated(all.n)==FALSE]
all.n <- all.n[order(all.n)]
all.n <- all.n[-which(all.n %in% c("Seccion","Casilla","Eleccion"))]

# get all files, colSums into new object
new.o <- matrix(rep(0, length(all.n)), nrow = 1)
new.o  <- data.frame(new.o); colnames(new.o)  <- all.n; new.o$Municipio <- "drop this obs"
#new.o <- new.o[,-which(colnames(new.o) %in% c("Seccion","Casilla","Eleccion"))]
for (i in 1:67){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read_excel(f, sheet = i)
    d <- as.data.frame(d) # chg tibble to data frame
    #d[1,]
    tmp.n <- which(all.n %notin% colnames(d)) # missing columns
    tmp.x <- matrix(0, nrow=nrow(d), ncol=length(tmp.n))
    tmp.x <- data.frame(tmp.x); colnames(tmp.x) <- all.n[tmp.n]
    d <- cbind(d, tmp.x)
    tmp <- d[1,which(colnames(d) %in% c("Municipio"))] # keep mun
    tmp2 <- d[1,which(colnames(d) %in% c("NoMpio"))] # keep ife
    d <- colSums(d[,-which(colnames(d) %in% c("Municipio","NoMpio","Seccion","Casilla","Eleccion"))])
    d <- c(Municipio=tmp, NoMpio=tmp2, d) # paste mun
    d <- d[order(names(d))]
    table(colnames(new.o)==names(d))
    new.o <- rbind(new.o, d)
#    assign(d, paste0("f", sub("^([0-9]+)[,].+", "\\1", all.f[i]))) # rename object
}

clipboard <- function(x, sep=",", row.names=FALSE, col.names=TRUE){
     con <- pipe("xclip -selection clipboard -i", open="w")
     write.table(x, con, sep=sep, row.names=row.names, col.names=col.names)
     close(con)
}
clipboard(new.o)

new.o[2,]

#####################
## san excel files ##
#####################

library(xlsx)
source("~/Dropbox/data/useful-functions/notin.r")
setwd("/home/eric/Downloads/Desktop/MXelsCalendGovt/elecReturns/datosBrutos/not-in-git/resultCasillas/subnat/san2021ayca")

all.f <- dir()

# get all colnames
all.n <- c()
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.xlsx(all.f[i], sheetIndex = 1)
    #d[1,]
    all.n <- c(all.n, colnames(d))
}
all.n <- all.n[duplicated(all.n)==FALSE]
all.n <- all.n[-which(all.n %in% c("Municipio","Casilla","Dto..Local","No..Mpo"))]
all.n <- c(all.n, "mun", "ife")
all.n <- all.n[order(all.n)]

# get all files, colSums into new object
new.o <- matrix(rep(0, length(all.n)), nrow = 1)
new.o  <- data.frame(new.o); colnames(new.o)  <- all.n; new.o$mun <- "drop this obs"
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.xlsx(all.f[i], sheetIndex = 1)
    #d[1,]
    #str(d)
    tmp.n <- which(all.n %notin% colnames(d)) # missing columns
    tmp.x <- matrix(0, nrow=nrow(d), ncol=length(tmp.n))
    tmp.x <- data.frame(tmp.x); colnames(tmp.x) <- all.n[tmp.n]
    d <- cbind(d, tmp.x)
    tmp <- d[1,which(colnames(d) %in% c("Municipio"))] # keep mun
    tmp2 <- as.numeric(d[1,which(colnames(d) %in% c("No..Mpo"))]) # keep ife
    d <- colSums(d[,-which(colnames(d) %in% c("Municipio","Casilla","Dto..Local","No..Mpo"))])
    d["mun"] <- tmp   # paste mun
    d["ife"] <- tmp2  # paste ife
    d <- d[order(names(d))]
    new.o <-
        rbind(new.o, d)
#    assign(d, paste0("f", sub("^([0-9]+)[,].+", "\\1", all.f[i]))) # rename object
}

clipboard(new.o)

new.o[1,]

###################
## oax csv files ##
###################

source("~/Dropbox/data/useful-functions/notin.r")
setwd("/home/eric/Downloads/Desktop/MXelsCalendGovt/elecReturns/datosBrutos/not-in-git/resultCasillas/subnat/oax2021ayca")
all.f <- dir()

# get all colnames
all.n <- c()
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.csv(file = all.f[i], skip = 2, nrows = 1, header = TRUE)
    #d[1,]
    all.n <- c(all.n, colnames(d))
}
all.n <- all.n[duplicated(all.n)==FALSE]
all.n <- all.n[-which(all.n %in% c("ID_ESTADO","NOMBRE_ESTADO","ID_DISTRITO_LOCAL","CABECERA_DISTRITO_LOCAL","SECCION","ID_CASILLA","TIPO_CASILLA","EXT_CONTIGUA","ID_TIPO_CANDIDATURA","ESTATUS_ACTA","CASILLA_INSTALADA","ESTATUS_PAQUETE","ID_INCIDENTE","NUM_ACTA_IMPRESO"))]
#all.n <- c(all.n, "mun", "ife")
all.n <- all.n[order(all.n)]

# get all files, colSums into new object
new.o <- matrix(rep(0, length(all.n)), nrow = 1)
new.o  <- data.frame(new.o); colnames(new.o)  <- all.n; new.o$MUNICIPIO_LOCAL <- "drop this obs"
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.csv(file = all.f[i], skip = 2, header = TRUE)
    sel <- which(colnames(d) %in% c("ID_ESTADO","NOMBRE_ESTADO","ID_DISTRITO_LOCAL","CABECERA_DISTRITO_LOCAL","SECCION","ID_CASILLA","TIPO_CASILLA","EXT_CONTIGUA","ID_TIPO_CANDIDATURA","ESTATUS_ACTA","CASILLA_INSTALADA","ESTATUS_PAQUETE","ID_INCIDENTE","NUM_ACTA_IMPRESO"))
    d <- d[,-sel]
    #d[1,]
    #str(d)
    tmp.n <- which(all.n %notin% colnames(d)) # missing columns
    tmp.x <- matrix(0, nrow=nrow(d), ncol=length(tmp.n))
    tmp.x <- data.frame(tmp.x); colnames(tmp.x) <- all.n[tmp.n]
    d <- cbind(d, tmp.x)
    tmp <- d[1,which(colnames(d) %in% c("MUNICIPIO_LOCAL"))] # keep mun
    tmp1 <- d[1,which(colnames(d) %in% c("ID_MUNICIPIO_LOCAL"))] # keep ife
    d <- colSums(d[,-which(colnames(d) %in% c("MUNICIPIO_LOCAL"))])
    d["MUNICIPIO_LOCAL"] <- tmp   # paste mun
    d["ID_MUNICIPIO_LOCAL"] <- tmp1   # paste ife
    d <- d[order(names(d))]
    new.o <-
        rbind(new.o, d)
#    assign(d, paste0("f", sub("^([0-9]+)[,].+", "\\1", all.f[i]))) # rename object
}

clipboard(new.o)

new.o[1,]


# Gregory Way 2016
# NF1 Inactivation Classifier for Glioblastoma
# scripts/viz/viz_roc.r
#
# Visualizes classifier performance by ROC
#
# Usage:
# Run with nf1_roc.py
#
# Output:
# average training/testing ROC and empirical cdf in multiplot

# Load library
library(ggplot2)
library(dplyr)
library(gridExtra)

# Load Command Args
args <- commandArgs(trailingOnly = T)
print(args)
roc_file <- args[1]
ensemble_roc_file <- args[2]
roc_figure <- args[3]
roc_results <- file.path("results",
                         paste0(tools::file_path_sans_ext(basename(args[2])),
                                "_auroc.tsv"))

# Load Data
roc_data <- readr::read_tsv(roc_file)
roc_ensemble <- readr::read_tsv(ensemble_roc_file)

# Save train/test AUROC results
roc_summary <- roc_data %>%
  group_by(type, seed, fold) %>%
  summarise(avg = mean(auc)) %>%
  group_by(type)

mean_auroc <- roc_summary %>% summarise(mean_auroc = mean(avg))
range_auroc_low <- roc_summary %>% summarise(ci_low = quantile(avg, 0.05))
range_auroc_high <- roc_summary %>% summarise(ci_high = quantile(avg, 0.95))

auroc_results <- cbind(mean_auroc, range_auroc_low$ci_low,
                       range_auroc_high$ci_high)
colnames(auroc_results) <- c("type", "mean", "0.05 CI", "0.95 CI")
write.table(auroc_results, roc_results, row.names = F, sep = "\t")

# Create new variable that stores an ID for each unique iteration
roc_data <- roc_data %>% mutate(iteration = paste(seed, fold, sep = "_"))

# Plot
base_theme <- theme(panel.grid.major = element_blank(),
                    panel.grid.minor = element_blank(),
                    panel.background = element_blank(),
                    axis.line.x = element_line(size = rel(0.8),
                                               linetype = "solid",
                                               color = "black"),
                    axis.line.y = element_line(size = rel(0.8),
                                               linetype = "solid",
                                               color = "black"),
                    axis.text = element_text(size = rel(0.6), color = "black"),
                    axis.ticks = element_line(size = rel(0.8), color = "black"),
                    axis.ticks.length = unit(0.2, "cm"),
                    axis.title = element_text(size = rel(0.8)),
                    axis.title.y = element_text(vjust = 4.5),
                    axis.title.x = element_text(vjust = -4.5),
                    legend.key.size = unit(0.5, "cm"),
                    legend.text = element_text(size = rel(0.9)),
                    legend.title = element_blank())

roc_grob <- ggplot(roc_ensemble, aes(x = fpr, y = tpr,
                                     color = type, fill = type)) +
  labs(x = "False Positive Rate", y = "True Positive Rate") +
  geom_line(size = rel(0.6)) +
  geom_abline(intercept = 0, linetype = "dashed", lwd = rel(0.8)) +
  geom_step(data = roc_data, inherit.aes = FALSE,
            aes(x = fpr, y = tpr, color = type, fill = type,
                group = interaction(seed, fold, type)),
            alpha = 0.1, size = 0.1) +
  scale_y_continuous(breaks = c(0, 0.25, 0.50, 0.75, 1.00),
                     limits = c(0, 1)) +
  scale_x_continuous(breaks = c(0, 0.25, 0.50, 0.75, 1.00),
                     limits = c(0, 1)) +
  base_theme + theme(plot.margin = unit(c(0.1, 0, 0, 0), "cm"))

# Summarize the AUROC for each iteration grouped by train/test
roc_auc_data <- roc_data %>% group_by(iteration, type) %>%
  summarize(auc_mean = mean(auc))

dens_cdf_grob <- ggplot(roc_auc_data, aes(x = auc_mean, colour = type,
                                          fill = type)) +
  stat_ecdf(aes(ymin = 0, ymax = ..y..), geom = "ribbon", alpha = 0.5) +
  labs(x = "AUROC", y = "CDF") +
  geom_vline(xintercept = 0.5, linetype = "dashed", lwd = rel(0.8)) +
  base_theme + theme(plot.margin = unit(c(0.8, 0, 0, 0), "cm"))

# Extract the legend from the CDF plot
gtable <- ggplot_gtable(ggplot_build(dens_cdf_grob))
legend_grob <- which(sapply(gtable$grobs, function(x) x$name == "guide-box"))
legend_grob <- gtable$grobs[[legend_grob]]

layout <- matrix(nrow = 50, ncol = 50)
layout[1:32, 1:42] <- 1
layout[33:50, 1:42] <- 2
layout[1:50, 43:50] <- 3

pdf(roc_figure, height = 5, width = 4.5)
grid.arrange(roc_grob + theme(legend.position = "none"),
             dens_cdf_grob + theme(legend.position = "none"),
             layout_matrix = layout,
             legend_grob, nrow = 1)
dev.off()


#' <brief desc>
#'
#' <full description>
#'
#' @param vcf VCF filename
#' @param indexname index file name to create. Deletes existing file if exists.
#'
#' @export
#' @return NULL
create_rsidx_index_from_vcf <- function(vcf, indexname)
{
	fn <- tempfile()
	cmd <- paste0("gunzip -c ", vcf, " | grep -v '#' | awk '{ print substr($3, 3), $1, $2 }' > ", fn, ".txt")
	message("Extracting position info")
	system(cmd)

	cmd <- c(
		'CREATE TABLE rsid_to_coord (rsid INTEGER PRIMARY KEY, chrom TEXT NULL DEFAULT NULL, coord INTEGER NOT NULL DEFAULT 0);',
		'.separator " "',
		paste0('.import ', fn, '.txt rsid_to_coord')
	)
	utils::write.table(cmd, file=paste0(fn, ".sql"), row=F, col=F, qu=F)
	message("Generating index")
	cmd <- paste0("sqlite3 ", indexname, " < ", fn, ".sql")
	unlink(indexname)
	system(cmd)
}

#' Create new index from existing index using a subset of rsids
#'
#' Note this requires a modified version of plink that allows ld-window-r2 flag for --r option.
#' Available here: https://github.com/explodecomputer/plink-ng
#'
#' @param rsid Vector of rsids
#' @param rsidx Existing index
#' @param newindex New index (Note: will delete existing file if exists)
#'
#' @export
#' @return NULL, creates new index file
create_rsidx_sub_index <- function(rsid, rsidx, newindex)
{
	out <- query_rsidx(rsid, rsidx)
	unlink(newindex)
	conn <- RSQLite::dbConnect(RSQLite::SQLite(), newindex)
	RSQLite::dbWriteTable(conn, "rsid_to_coord", out)
	RSQLite::dbExecute(conn, "CREATE INDEX rsid on rsid_to_coord(rsid);")
	RSQLite::dbDisconnect(conn)
}

#' Create LD reference sqlite database for tags
#'
#' This is used for looking up proxies
#'
#' @param bfile path to plink file
#' @param dbname dbname to produce (overwrites existing if exists)
#' @param tag_r2 minimum tag r2
#'
#' @export
#' @return NULL
create_ldref_sqlite <- function(bfile, dbname, tag_r2=0.6)
{
	stopifnot(check_plink())
	message("identifying indels to remove")
	cmd <- paste0("awk '{ if (length($5) != 1 || length($6) != 1) { print $2 }}' ", bfile, ".bim > ", bfile, ".indels")
	system(cmd)

	message("calculating ld tags")
	cmd <- paste0(options()[["tools_plink"]], " --bfile ", bfile, " --keep-allele-order --exclude ", bfile, ".indels --r in-phase with-freqs gz --out ", bfile, " --ld-window-kb 250 --ld-window 1000 --ld-window-r2 ",  tag_r2)
	system(cmd)

	message("formatting")
	cmd <- paste0("gunzip -c ", bfile, ".ld.gz | awk 'BEGIN {OFS=\",\"}  { if(NR != 1) { print substr($3, 3), $1, $2, $4, substr($7, 3), $5, $6, $9, $8, $10 }}' > ", bfile, ".ld.tab")
	system(cmd)

	message("creating sqlite db")
	cmd <- c(
		'CREATE TABLE tags (',
		'	SNP_A INTEGER NOT NULL, ',
		'	CHR_A TEXT NULL DEFAULT NULL, ',
		'	BP_A INTEGER NOT NULL,',
		'	MAF_A REAL NOT NULL,',
		'	SNP_B INTEGER NOT NULL, ',
		'	CHR_B TEXT NULL DEFAULT NULL, ',
		'	BP_B INTEGER NOT NULL,',
		'	MAF_B REAL NOT NULL,',
		'	PHASE TEXT NOT NULL,',
		'	R REAL NOT NULL',
		');',
		'CREATE INDEX SNP_A_INDEX ON tags(SNP_A);',
		'.separator ","',
		paste0(".import ", bfile, ".ld.tab tags")
	)
	unlink(paste0(bfile, ".ld.sqlite"))
	utils::write.table(cmd, file=paste0(bfile, ".ld.sqlite"), row=F, col=F, qu=F)
	unlink(dbname)
	cmd <- paste0("sqlite3 ", dbname, " < ", bfile, ".ld.sqlite")
	system(cmd)
	unlink(paste0(bfile, ".ld.tab"))
	unlink(paste0(bfile, ".ld.gz"))
	unlink(paste0(bfile, ".ld.sqlite"))
	unlink(paste0(bfile, ".indels"))
}


#!/usr/local/bin/Rscript --vanilla

###############################################################################
# METAREP : High-Performance Comparative Metagenomics Framework (http://www.jcvi.org/metarep)
# Copyright(c)  J. Craig Venter Institute (http://www.jcvi.org)
#
# Licensed under The MIT License
# Redistributions of files must retain the above copyright notice.
#
# link http://www.jcvi.org/metarep METAREP Project
# package metarep
# version METAREP v 1.3.1
# author Kelvin Li et al.
# lastmodified 2010-07-09
# license http://www.opensource.org/licenses/mit-license.php The MIT License
###############################################################################

FRACT_NOISE_THRESHOLD <- 0.00025

progname <- commandArgs(FALSE)[5]
args <- commandArgs(TRUE)

arg_count=1

if(is.na(args[arg_count])){

	script_name <- unlist(strsplit(progname,"="))[2]

	usage <- paste (
			"\nUsage:\n\t", script_name, "\n\t\t<Input FileName>\n\n",
			"Reads input file and produces two plots:  complete linkage and MDS.\n",
			"Be sure to check for samples that were eliminated due to filtering because they\n",
			"because they failed the noise thresholding.\n",
			"\n")

	writeLines(usage)
	writeLines("Input FileName not defined.\n")
	quit(status=0)
}

###############################################################################
# Main program loop

while(!(is.na(args[arg_count]))){
	InputFileName=args[arg_count]
	Option 			= as.numeric(args[2])
	Title 			= as.character(args[3])
	Subtitle 		= as.character(args[4])
	DistanceMethod 	= as.character(args[5])
	ClusterMethod  	= as.character(args[6])
	HeatmapColor 	= as.character(args[7])
	ClusterFile    	= as.character(args[8])

	CompleteLinkagePlotPDF = paste(InputFileName, "_hclust_plot.pdf", sep="")
	MDSPlotPDF = paste(InputFileName, "_mds_plot.pdf", sep="")
	HeatMapPDF = paste(InputFileName, "_heat_map.pdf", sep="")
	MosaicPlotPDF = paste(InputFileName, "_mosaic_plot.pdf", sep="")
	EliminatedSamplesTXT = paste(InputFileName, ".eliminated.txt", sep="")

	cat("\n")
	cat("             Input File Name: ", InputFileName, "\n")
	cat("    CompleteLinkage Plot PDF: ", CompleteLinkagePlotPDF, "\n")
	cat("                MDS Plot PDF: ", MDSPlotPDF, "\n")
	cat("    Mosaic Plot PDF: ", MosaicPlotPDF, "\n")
	cat("                Heat Map PDF: ", HeatMapPDF, "\n")
	cat("Eliminated Samples Text File: ", EliminatedSamplesTXT, "\n")

	# Example input:

	#  Grp1 Grp2 Grp3 Grp4 Grp5 Grp6 Grp7 Grp8 Grp9
	# TS1A-PCR-1 0 0 2 2 1 0 0 0 2
	# TS4A-PCR-1 0 0 1 4 3 0 0 0 2
	# TS25A-PCR-1 0 0 0 1 1 0 0 0 0
	# TS1A-PCR-2 2 1 3 0 1 1 0 1 5
	# TS4A-PCR-2 4 0 0 2 1 0 0 1 4
	# TS25A-PCR-2 0 0 3 0 0 0 0 0 0
	# TS1A-MDA-1 1 0 0 0 0 0 0 1 0
	# TS4A-MDA-1 0 1 0 5 0 0 0 0 7
	# TS25A-MDA-1 0 0 0 0 0 0 0 0 3
	# TS1A-MDA-2 0 0 0 0 0 0 1 0 0
	# TS4A-MDA-2 0 0 1 1 0 0 0 0 2
	# TS25A-MDA-2 0 0 0 0 1 0 0 0 1

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

	## Load data [last argument]
	A<-as.matrix(read.table(InputFileName))

	## Sum up the number of members in each column by doing an outer product
	A.j<-rep(1,nrow(A))%*%A

	## Compute sum across each column now
	total_members <- sum(A)

	## Compute absolute noise threshold based on fraction
	noise_threshold <- total_members * FRACT_NOISE_THRESHOLD
	cat("Percentage Noise Threshold: ")
	cat(FRACT_NOISE_THRESHOLD)
	cat("\nComputed Absolute Noise Threshold: ")
	cat(noise_threshold)
	cat("\n")

	## build a new matrix that excludes any columns with count less than the noise_threshold
	M<-A[,A.j>=noise_threshold]

	## Sum of members (columns) across each sample (row)
	Mi.<-M%*%rep(1,ncol(M))

	Mi_original <- Mi.

	## Try to remove rows that have zero count
	samples_to_keep <- Mi.>0
	samples_to_keep <- samples_to_keep[,1]
	Mi. <- Mi.[samples_to_keep,]
	M <- M[samples_to_keep,]

	## Report eliminated samples
	samples_eliminated <- Mi_original[Mi_original==0,]
	num_samples_eliminated <- (length(samples_eliminated))
	elimination_message <- paste("Note: ", num_samples_eliminated, " samples were eliminated.", sep="")
	cat(paste("\n", elimination_message, "\n\n"))

	## Normalize the counts by converting to percentages, build new matrix with rbind
	## (stick rows into Z, b/c Z has to be initialized for rbind to work)
	Z<-M[1,]*100/Mi.[1]
	for (i in 2:dim(M)[1]) {
		Z<-rbind(Z,M[i,]*100/Mi.[i])
	}

	## Scale the labels sizes so they don't overlap each other.
	## But limit the scaling so it's not too large.
	numRows<-nrow(A);
	numCols<-ncol(A);

	label_scale=42/numRows
	col_scale = 42/numCols

	row.names(Z) <- row.names(M)

	if(label_scale > 1){
		label_scale = 1
	}
	if(col_scale > 1){
		col_scale = 1
	}

	###############################################################################
	#
	# Hierarchical Cluster Plot
	#
	###############################################################################
	if(Option == 7) {

		library(vegan)

		## draw Hierarchical Clustering Plot
		pdf(CompleteLinkagePlotPDF,width=11,height=(5+(1*numRows/3)))

		## calculate pairwise distances
		Zdist<-vegdist(Z, method=DistanceMethod);

		hclustout = hclust(Zdist,method=ClusterMethod)

		op <- par(mar=c(5,2,5,17),oma =c(5,2,2,5))

		## hierarchical Clustering
		plot(as.dendrogram(hclustout), horiz = TRUE,  cexRow=label_scale* 0.80, sub="",main=Title,xlab=paste(DistanceMethod,' distance'))
		mtext(Subtitle,line= 1,cex= 0.75)

		Margins <- capture.output( par()$mar )

		## If there were samples eliminated, throw a message on the plot
		if(num_samples_eliminated > 0){
			# Get the plot boundaries and draw elimination message
			cur_parameters=par()
			ranges <- cur_parameters$usr
			text(0,ranges[3]+1.4, elimination_message, pos=4, col="red")
		}

		## write distance matrix to file
		write.table(as.matrix(Zdist),ClusterFile, sep = "\t",append=TRUE)

		dev.off()
	}

	##############################################################################
	# Draw MDS Plot
	#
	# isoMDS: non-metric multidimensional scaling
	#
	# Multidimensional scaling (MDS) is a set of related statistical techniques often used in information visualization for exploring similarities or
	# dissimilarities in data. MDS is a special case of ordination. An MDS algorithm starts with a matrix of item.item similarities, then assigns a
	# location of each item in a low-dimensional space, suitable for graphing or 3D visualisation.
	###############################################################################

	if(Option == 8) {

		library(MASS)
		library(vegan)

		## calculate pairwise distances
		Zdist<-vegdist(Z, method=DistanceMethod);

		# Get rid of errors when ismMDS doesn't like 0's in the distance matrix
		for(i in 1:length(Zdist)){
			if(Zdist[i]==0){
				Zdist[i]=1e-323;
			}
		}

		mds<-isoMDS(Zdist)

		# Draw IsoMDS Plot
		pdf(MDSPlotPDF,width=11,height=8.5)

		# Compute the padding inside of the graph so the text labels don't fall off the screen
		min<-min(mds$points[,1])
		max<-max(mds$points[,1])
		width=(max-min)
		margin=width*(0.1)

		plot(mds$points,type="n", main=args[3], xlim=c(min-margin, max+margin),xlab="Dimension 1", ylab="Dimension 2")
		text(mds$points,labels=names(M[,1]), cex=0.8*label_scale)
		mtext(Subtitle,line= 1,cex= 0.75)

		# If there were samples eliminated, throw a message on the plot
		if(num_samples_eliminated > 0){
			# Get the plot boundaries and draw elimination message
			cur_parameters=par()
			ranges <- cur_parameters$usr
			text(ranges[1],ranges[4]-2, elimination_message, pos=4, col="red")
		}
		dev.off()

		#write distance matrix to file
		write.table(as.matrix(Zdist),ClusterFile, sep = "\t",append=TRUE)
	}

	###############################################################################
	#
	# Heatmap Plot
	#
	###############################################################################

	if(Option == 9) {
		library(gplots)

		library(vegan)

		pdf(HeatMapPDF, width=11,height=8.5)

		if(HeatmapColor == 1) {
			heatcolor = heat.colors(256);
		}
		else if (HeatmapColor == 2) {
			heatcolor = c("#f7feb0","#ecf8b1","#e2f1b1","#d8ebb1","#cee4b2","#c4deb2","#bad8b2","#b0d1b3","#a5cbb3","#9bc5b3","#91beb4","#87b8b4","#7db1b5","#73abb5","#68a5b5","#5e9eb6","#5498b6","#4a92b6","#408bb7","#3685b7");
		}
		else if (HeatmapColor == 3) {
			heatcolor = c("#e7f0fa","#deebf7","#d4e5f3","#cbdff0","#c2daed","#b9d4ea","#b0cfe7","#a7c9e4","#9ec4e1","#95bede","#8cb9db","#82b3d8","#79aed5","#70a8d2","#67a3cf","#5e9dcc","#5598c9","#4c92c6","#438dc3","#3a87c0")
		}
		else if (HeatmapColor == 4) {
			heatcolor = c("#eef9e7","#e5f5e0","#dbf0d8","#d2ecd1","#c8e8c9","#bfe3c2","#b5dfbb","#acdbb3","#a2d6ac","#99d2a5","#8fce9d","#86c996","#7cc58e","#73c187","#69bc80","#60b878","#56b471","#4daf6a","#43ab62","#3aa75b")
		}

		hclust2  <- function(x, method=ClusterMethod) hclust(x, method=method)
		vegdist2 <- function(x, method=DistanceMethod) vegdist(x, method=method)

		## heatmap colors
		## colorset = rev(rainbow(2^8, start=0, end=0.65)
		## redgreen(75)
		## heat.colors(256)
		## ol=rev(heat.colors(256))

		heatmap.2(Z,trace="none",col=heatcolor, distfun = vegdist2,
				hclustfun = hclust2,cexRow=label_scale* 0.80,keysize = 1.2,scale = c("none"),
				cexCol=col_scale * 0.95,main=args[3], density.info=c('none'),margins=c(18,18))

		mtext(Subtitle,line= 0,cex= 0.75)
		#heatmap(Z, cexRow=label_scale* 0.80,  cexCol=label_scale * 0.63,
		#main=args[3],key=TRUE,
		#col=rev(rainbow(2^16, start=0, end=0.65)),
		#margins=c(18,8)
		#)

		dev.off()

		## write distance matrix to file
		## calculate pairwise distances
		Zdist<-vegdist(Z, method=DistanceMethod);

		write.table(as.matrix(Zdist),ClusterFile, sep = "\t",append=TRUE)
		write.table(NULL,ClusterFile, sep = "\t",append=TRUE)
		write.table(as.matrix(t(Z)),ClusterFile, sep = "\t",append=TRUE)
	}

	if(Option == 10) {
		height = 8+log(numCols)*1.3;
		width = 6+log(numRows)*1.3;
		pdf(MosaicPlotPDF, width=width,height=height);
		#pdf(MosaicPlotPDF);

		par(pin=c(width*0.90, height*0.75))
		mosaicplot(A, las = 2,ann=FALSE,main=Title,color=terrain.colors(numCols),adj=1,cex.axis=(0.70-numCols/200))

		mtext(Subtitle,line= 1,cex= 0.75)
		par(mar=c(2, 2, 5, 1))

		Margins <- capture.output( par()$mar )
		Margins <- substr(Margins, 5, nchar(Margins))
		Margins <-
				paste("mar = c(", gsub(" ",",",Margins), ")", sep="")

		shortname <- "" # or maybe a filename
		mtext(paste(shortname, " ",
						format(Sys.time(), "%Y-%m-%d %H:%M")),
				cex=0.6, line=0, side=SOUTH<-1, adj=0, outer=TRUE)
		dev.off()
	}

	##############################################################################
	##############################################################################
	# Generate list of samples that were eliminated
	#
	elimination_list<-names(samples_eliminated)
	cat("\nElimination List: ")
	print(cat(elimination_list), sep="\n")
	write(elimination_list, file=EliminatedSamplesTXT, sep="\n")

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

	arg_count=arg_count+1;
}

writeLines("Done.\n")

q(status=0)


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

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

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

# Load data in a wide format and convert to something that may be used for estimations of ANOVA and for plotting purposes
wdir 	        <- getwd()
df 		        <- read_excel(paste(wdir, "data-guideXT.xlsx", sep=""), sheet = "table_all")
df 		        <- df %>% drop_na(updrs_GXT)
df 		        <- as.data.frame(df)
df 		        <- df[df$include==1,]
df_angle      <- df %>% select(pseud, DICE_L, DICE_R) %>% gather(side, "DC", DICE_L, DICE_R)
df_angle$side <- as.factor(df_angle$side)

# Required function
data_summ <- function(x) {
   m <- mean(x)
   mdn <- median(x)
   ymin <- m-sd(x)
   ymax <- m+sd(x)
   return(c(y=m,ymin=ymin,ymax=ymax))
}

## ============================== Visualisation for VTA overlap ==============================
gap = .005
bp_size = 2.25

# Start plotting data
p5 <- ggplot(data=df_angle, aes(x=side, y=DC, fill=side)) +
	            ylim(0,1) +
	            geom_jitter(aes(color=side), position=position_jitter(0.05), size=1.25) +
	            scale_color_manual(values = c("#6A7F99", "#B34439")) +
	            geom_rangeframe(y=rep(c(0, 1), 29)) +
	            scale_x_discrete(labels = c('Left STN', 'Right STN')) +
	            ylab("Overlap between VTA estimated via GuideXT\U2122 \nsoftware and Lead-DBS toolbox") +
	            xlab("") +
	            theme_minimal() +
	            theme(legend.position = "none", text=element_text(size=20, family="serif")) +

	# Start plotting q1-3 of the boxplot
	geom_segment(aes(x = 1, y = min(DC[side=="DICE_L"]),
						xend = 1, yend = -gap+median(DC[side=="DICE_L"])),
		size=.25, color="black", linetype=1) +
	geom_segment(aes(x = 1, y = gap+median(DC[side=="DICE_L"]),
						xend = 1, yend = max(DC[side=="DICE_L"])),
		size=.25, color="black", linetype=1) +

	# Start plotting q1-3 of the boxplot
	geom_segment(aes(x = 1, y = quantile(DC[side=="DICE_L"])[2],
						xend = 1, yend = -gap+median(DC[side=="DICE_L"])),
		size=bp_size, color="black", linetype=1) +
	geom_segment(aes(x = 1, y = gap+median(DC[side=="DICE_L"]),
						xend = 1, yend = quantile(DC[side=="DICE_L"])[4]),
		size=bp_size, color="black", linetype=1) +

# Start plotting q1-3 of the boxplot
	geom_segment(aes(x = 2, y = min(DC[side=="DICE_L"]),
						xend = 2, yend = -gap+median(DC[side=="DICE_R"])),
		size=.25, color="black", linetype=1) +
	geom_segment(aes(x = 2, y = gap+median(DC[side=="DICE_R"]),
						xend = 2, yend = max(DC[side=="DICE_R"])),
		size=.25, color="black", linetype=1) +

	# Start plotting q1-3 of the boxplot
	geom_segment(aes(x = 2, y = quantile(DC[side=="DICE_R"])[2],
						xend = 2, yend = -gap+median(DC[side=="DICE_R"])),
		size=bp_size, color="black", linetype=1) +
	geom_segment(aes(x = 2, y = gap+median(DC[side=="DICE_R"]),
						xend = 2, yend = quantile(DC[side=="DICE_R"])[4]),
		size=bp_size, color="black", linetype=1)

## ============================== Visualisation relationship DICE vs. clinical outcome ==============================
# Load data in a wide format and convert to something that may be used for estimations of ANOVA and for plotting purposes
wdir 	          <- getwd()
df 		          <- read_excel(paste(wdir, "data-guideXT.xlsx", sep=""), sheet = "table_all")
df 		          <- df %>% drop_na(updrs_GXT)
df 		          <- as.data.frame(df)
df 		          <- df[df$include==1,]
df$updrs_diffL  <- df$updrs_MTL - df$updrs_GXTL
df$updrs_diffR  <- df$updrs_MTR - df$updrs_GXTR

df_angle            <- 	df %>% select(pseud, DICE_L, DICE_R) %>% gather(side, "DC", DICE_L, DICE_R)
df_angle2           <- 	df %>% select(pseud, updrs_diffL, updrs_diffR) %>% gather(UPDRS_side, "UPDRS", updrs_diffL, updrs_diffR)
df_angle$UPDRSdiff  <- df_angle2$UPDRS
df_angle$side       <- as.factor(df_angle$side)

p6 <- ggplot(data=df_angle, aes(x=abs(UPDRSdiff), y=DC)) +
      geom_point(shape=1) +    # Use hollow circles
      geom_smooth(method=lm,   # Add linear regression line
                se=FALSE)    # Don't add shaded confidence region
p6
# ANNOTATION: p6 is not used in the manuscript vut only described!!


merge = function(method, X, batch, covariate=NULL) {
    if (method == "combat")
        combat(X, batch, covariate)
    else if (method == "dwd")
        dwd(X, batch)
    else if (method == "none")
        none(X)
    else
        stop("invalid method")
}

combat = function(X, batch, covariate=NULL) {
    if (is.matrix(covariate) || is.null(covariate))
        mat = covariate
    else
        mat = model.matrix(~as.factor(batch), data=covariate)
    sva::ComBat(dat=.list2mat(X), batch=batch, mod=mat, par.prior=TRUE)
}

dwd = function(X, batch) {
    ll = .mat2list(X, subsets=batch)
    esets = lapply(ll, ExpressionSet)
    eset = inSilicoMerging::merge(esets, method="DWD")
    exprs(eset)
}

none = function(X, batch=NA) {
    .list2mat(X)
}

.list2mat = function(ll) {
    if (is.list(ll))
        narray::stack(ll, along=2)
    else
        ll
}

.mat2list = function(X, subsets) {
    if (is.matrix(X))
        narray::split(X, along=2, subsets=subsets)
    else
        X
}


shift <- function(x, n, invert=FALSE, default=NA){
  stopifnot(length(x)>=n)
  if(n==0){
    return(x)
  }
  n <- ifelse(invert, n*(-1), n)
  if(n<0){
    n <- abs(n)
    forward=FALSE
  }else{
    forward=TRUE
  }
  if(forward){
    return(c(rep(default, n), x[seq_len(length(x)-n)]))
  }
  if(!forward){
    return(c(x[seq_len(length(x)-n)+n], rep(default, n)))
  }
}

denoise_step <- function(x){
  return(pmax(x, shift(x, 1), na.rm = TRUE))
}

denoise <- function(x){
  return(denoise_step(denoise_step(denoise_step(x))))
}

data <- list()
legends <- list()

basepath <- "../../data/v2/";

data[[1]] <- read.csv(file.path(basepath, "scaling/expt-2/1-thread/lda-progress-mongo-7291.csv"));
legends[[1]] <- "1 thread, adam";

data[[2]] <- read.csv(file.path(basepath, "scaling/expt-2/2-threads/lda-progress-mongo-2757.csv"));
legends[[2]] <- "2 threads, adam";

data[[3]] <- read.csv(file.path(basepath, "scaling/expt-2/4-threads/lda-progress-mongo-2450.csv"));
legends[[3]] <- "4 threads, adam";

data[[4]] <- read.csv(file.path(basepath, "scaling/expt-2/8-threads/lda-progress-mongo-2430.csv"));
legends[[4]] <- "8 threads, adam";

# data[[5]] <- read.csv(file.path(basepath, "scaling/expt-2/16-threads/lda-progress-mongo-2536.csv"));
# legends[[5]] <- "16 threads, adam";
#
# data[[6]] <- read.csv(file.path(basepath, "scaling/expt-2/30-threads/lda-progress-mongo-2750.csv"));
# legends[[6]] <- "30 threads, adam";

data[[5]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.0-threads1/lda-progress-mongo-s0.001-mu0.0-7077.csv"));
legends[[5]] <- "1 thread, sgd, no momentum";

data[[6]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.0-threads2/lda-progress-mongo-s0.001-mu0.0-6154.csv"));
legends[[6]] <- "2 threads, sgd, no momentum";

data[[7]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.0-threads4/lda-progress-mongo-s0.001-mu0.0-6584.csv"));
legends[[7]] <- "4 threads, sgd, no momentum";

data[[8]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.0-threads8/lda-progress-mongo-s0.001-mu0.0-6242.csv"));
legends[[8]] <- "8 threads, sgd, no momentum";

data[[9]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.0-threads16/lda-progress-mongo-s0.001-mu0-5769.csv"));
legends[[9]] <- "16 threads, sgd, no momentum";

data[[10]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.0-threads30/lda-progress-mongo-s0.001-mu0-5327.csv"));
legends[[10]] <- "30 threads, sgd, no momentum";

data[[11]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.3-threads08/lda-progress-mongo-s0.001-mu0.3-5792.csv"));
legends[[11]] <- "8 threads, sgd, momentum=0.3";

data[[12]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.3-threads16/lda-progress-mongo-s0.001-mu0.3-5764.csv"));
legends[[12]] <- "16 threads, sgd, momentum=0.3";

data[[13]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.3-threads30/lda-progress-mongo-s0.001-mu0.3-5314.csv"));
legends[[13]] <- "30 threads, sgd, momentum=0.3";

data[[14]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.6-threads08/lda-progress-mongo-s0.001-mu0.6-6716.csv"));
legends[[14]] <- "8 threads, sgd, momentum=0.6";

data[[15]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.6-threads16/lda-progress-mongo-s0.001-mu0.6-6099.csv"));
legends[[15]] <- "16 threads, sgd, momentum=0.6";

data[[16]] <- read.csv(file.path(basepath, "sgd2/s0.001-mu+0.6-threads30/lda-progress-mongo-s0.001-mu0.6-5327.csv"));
legends[[16]] <- "30 threads, sgd, momentum=0.6";

pdf("../../figures/v2/expt-10-all-0.pdf")

plot(data[[1]]$time, data[[1]]$objective, ylim=c(-48000, -39000), type="n", xlab="Runtime (seconds)", ylab="ELBo", main="LDA");

colors <- rainbow(18)

for (i in 1:16){
    # lines(data[[i]]$time, denoise(data[[i]]$objective), col=colors[i])
}

legend("bottomright", legend=legends, col=colors, lty=1)

dev.off()