library(Seurat)
library(ggplot2)
library(ggpubr)

finalList<-readRDS(parFile1)
obj<-finalList$obj

assay=ifelse("SCT" %in% names(obj@assays), "SCT", "RNA")

cell_df<-read_cell_cluster_file(parFile2)

cluster_df=read.table(parSampleFile1)
cluster_request <- tapply(cluster_df$V1,cluster_df$V2,list)

params_def=read.table(parSampleFile2)
params <- setNames(as.character(params_def$V1), params_def$V2)
gene_number=as.numeric(params['gene_number'])
cluster_name=params['cluster_name']
display_cluster_name=params['display_cluster_name']

if(display_cluster_name == "seurat_clusters"){
  display_cluster_name = "display_seurat_clusters"
}
obj[["final_seurat_clusters"]]=cell_df[,display_cluster_name]

cnames=unique(cell_df[,c(cluster_name, display_cluster_name)])
rownames(cnames)=cnames[,cluster_name]
cnames[,"filename"] = gsub('[ :]+', '_', cnames[,display_cluster_name])

idx=1
for(idx in c(1:length(cluster_request))) {
  curname=names(cluster_request)[idx]
  clusternames = as.character(cluster_request[[idx]])

  if(clusternames == "all"){
    subobj=obj
  }else{
    cells=rownames(cell_df)[cell_df[,cluster_name] %in% clusternames]
    subobj=subset(obj, cells=cells)
  }

  cname_df=data.frame("cluster_name"=subobj[[cluster_name]], "display_cluster_name"=subobj[["final_seurat_clusters"]])

  markers=FindAllMarkers(subobj, only.pos = TRUE, min.pct = 0.25, logfc.threshold = 0.25)

  # Try to find pairwise biomarker
  # allmarkers=NULL
  # for(c1 in clusternames){
  #   c1markers=subset(markers, markers$cluster==c1)
  #   c1markers$sig_count=0
  #   for(c2 in clusternames){
  #     if(c1 == c2){
  #       next
  #     }
  #     c1c2_markers = FindMarkers(subobj, ident.1 = c1, ident.2=c2, only.pos = TRUE, min.pct = 0.25, logfc.threshold = 0.25)
  #     sig_c1c2 = ifelse(rownames(c1markers) %in% rownames(c1c2_markers), 1, 0)
  #     c1markers$sig_count = c1markers$sig_count + sig_c1c2
  #   }
  #   allmarkers=rbind(allmarkers, c1markers)
  # }
  # allmarkers=subset(allmarkers, allmarkers$p_val_adj < 0.01)
  # allmarkers=allmarkers[order(allmarkers$cluster, -allmarkers$sig_count, allmarkers$p_val_adj),]
  # markers=allmarkers

  write.csv(markers, paste0(curname, ".markers.csv"))

  dms=tapply(markers$gene,markers$cluster,list)

  all_genes=c()
  idy=1
  for(idy in c(1:length(dms))) {
    cluster = names(dms)[idy]
    allgenes=unlist(dms[idy])
    genes=unname(allgenes[1:min(gene_number, length(allgenes))])
    display_name=as.character(cnames[cluster,display_cluster_name])
    file_name=cnames[cluster,"filename"]

    all_genes = c(all_genes, genes)

    pdf(file=paste0(curname, ".", file_name, ".dot.pdf"), width=max(length(genes) * 0.4, 10), height=max(6, min(10, length(clusternames))))
    p<-DotPlot(subobj, assay = assay, group.by="final_seurat_clusters", features=genes, cols = c("lightgrey", "red"), dot.scale = 8) + RotatedAxis() +
      xlab("") + ylab("")
    print(p)
    dev.off()
  }

  all_genes=unique(all_genes)
  pdf(file=paste0(curname, ".dot.pdf"), width=max(length(all_genes) * 0.4, 10), height=max(6, min(10, length(clusternames))))
  p<-DotPlot(subobj, assay = assay, group.by="final_seurat_clusters", features=all_genes, cols = c("lightgrey", "red"), dot.scale = 8) + RotatedAxis() +
    xlab("") + ylab("") + ggtitle("Seurat Marker Genes") + theme(plot.title = element_text(hjust = 0.5))
  print(p)
  dev.off()
}


# A treemap R script produced by the REVIGO server at http://revigo.irb.hr/
# If you found REVIGO useful in your work, please cite the following reference:
# Supek F et al. "REVIGO summarizes and visualizes long lists of Gene Ontology
# terms" PLoS ONE 2011. doi:10.1371/journal.pone.0021800

# author: Anton Kratz <anton.kratz@gmail.com>, RIKEN Omics Science Center, Functional Genomics Technology Team, Japan
# created: Fri, Nov 02, 2012  7:25:52 PM
# last change: Fri, Nov 09, 2012  3:20:01 PM

# -----------------------------------------------------------------------------
# If you don't have the treemap package installed, uncomment the following line:
# install.packages( "treemap" );
library(treemap) 								# treemap package by Martijn Tennekes

# Set the working directory if necessary
# setwd("C:/Users/username/workingdir");

# --------------------------------------------------------------------------
# Here is your data from REVIGO. Scroll down for plot configuration options.

revigo.names <- c("term_ID","description","freqInDbPercent","abslog10pvalue","uniqueness","dispensability","representative");
revigo.data <- rbind(c("GO:0006464","cellular protein modification process",12.719,1.6576,0.196,0.000,"cellular protein modification process"),
c("GO:0043412","macromolecule modification",15.900,1.6383,0.432,0.307,"cellular protein modification process"),
c("GO:0006793","phosphorus metabolic process",10.142,1.6383,0.504,0.189,"cellular protein modification process"));

stuff <- data.frame(revigo.data);
names(stuff) <- revigo.names;

stuff$abslog10pvalue <- as.numeric( as.character(stuff$abslog10pvalue) );
stuff$freqInDbPercent <- as.numeric( as.character(stuff$freqInDbPercent) );
stuff$uniqueness <- as.numeric( as.character(stuff$uniqueness) );
stuff$dispensability <- as.numeric( as.character(stuff$dispensability) );

# by default, outputs to a PDF file
pdf( file="revigo_treemap.pdf", width=16, height=9 ) # width and height are in inches

# check the tmPlot command documentation for all possible parameters - there are a lot more
tmPlot(
	stuff,
	index = c("representative","description"),
	vSize = "abslog10pvalue",
	type = "categorical",
	vColor = "representative",
	title = "REVIGO Gene Ontology treemap",
	inflate.labels = FALSE,      # set this to TRUE for space-filling group labels - good for posters
	lowerbound.cex.labels = 0,   # try to draw as many labels as possible (still, some small squares may not get a label)
	bg.labels = "#CCCCCCAA",     # define background color of group labels
												       # "#CCCCCC00" is fully transparent, "#CCCCCCAA" is semi-transparent grey, NA is opaque
	position.legend = "none"
)

dev.off()


# if (!require("R.oo")) try(install.packages("R.oo"));
# if (!require("Rmpi")) try(install.packages("Rmpi"));
# if (!require("BayesTree")) try(install.packages("BayesTree"));
# if (!require("stats")) try(install.packages("stats"));
# if (!require("matrixStats")) try(install.packages("matrixStats"));
# if (!require("Matrix")) try(install.packages("Matrix"));
# if (!require("abind")) try(install.packages("abind"));
# if (!require("restorepoint")) try(install.packages("restorepoint")); ## deprecated
getBartNetwork <- function(tgtLevel, tfLevel, regMat, unperturbedTfLevel, nBin = 3, ...) {
	# use BART to generate a network structure prediction
	# tgtLevel: training target expression levels, in foldchange with respect to wildtype
	# tfLevel: training regulator expression levels, in foldchange with respect to wildtype, the log of which will be fed to BART
	# regMat: adjacency matrix of a prior allowed interactions: ij entry represens wether regulator i is allowed to regulate target j. If missing, everything except self-regulation is allowed
	# ...: additional parameters to pass to bartExpr
	# will construct query TF level for network reconstruction
	#	each query profile contains one and only one perturbed regulator levels
	#	unperturbedTfLevel: specifies the unperturbed regulator levels; defaults are the medians of the regulators
	#	perturbed levels of a regulator taken from its quantiles in the training data, with equally distanced probs from 0 to 1
	#	nBin: specifies the number of quantiles to use for each regulator, default is 3. (giving min, median, and max)
	#	yMean (predicted transformed tgtLevel) and yVar(posterior variance of transformed tgtLevel) will be reshaped so that:
	#		first dimension corresponds to different quantiles of regulators they are responding to
	#		second dimension corresponds to the identity of the perturbed regulator they are responding to
	#		third dimenison is the idenity of the responding target gene itself
	# returns fields including those of bartExpr, with an additional field regScore which is the signed scores of regulation likelihood

    # load libraries
    library("R.oo")
    library("Rmpi")
    library("BayesTree")
    library("stats")
    library("matrixStats")
    library("Matrix")
    library("abind")
	# require("matrixStats");
	nTf <- ncol(tfLevel);
	#
	# constructing query regulator levels
	result <- list();
	result$perturbedTfLevel <- t(colQuantiles(tfLevel, probs = seq(0, 1, length.out = nBin), drop = FALSE)); # quantiles of regulator levels
	testTfLevel <- rbind(colMedians(tfLevel))[rep(1, nBin * nTf), , drop = FALSE]; # shaping testTfLevel
	if (!missing(unperturbedTfLevel)) testTfLevel[] <- c(unperturbedTfLevel); # if unperturbedTfLevel is specified, use it; otherwise, medians of TF levels are used
	ix <- cbind(sequence(nrow(testTfLevel)), rep(sequence(nTf), each = nBin)); # indices of perturbed entries in the matrix
	colnames(result$perturbedTfLevel) <- colnames(tfLevel);
	testTfLevel[ix] <- c(result$perturbedTfLevel); # filling perturbed TF levels to testTfLevel
	#
	# calling BART
	barted <- bartExpr(tgtLevel = tgtLevel, tfLevel = tfLevel, regMat = regMat, testTfLevel = testTfLevel,...);
	result <- c(result, barted);
	#
	# reshaping results
	dim(result$yMean) <- c(dim(result$perturbedTfLevel), ncol(tgtLevel)); # reshaping yMean so that the first dimension is regulator quantiles, second dimension is regulator identities, third dimension is targe identities
	dimnames(result$yMean) <- c(dimnames(result$perturbedTfLevel), list(colnames(tgtLevel)));
	dim(result$yVar) <- dim(result$yMean); # reshaping yVar
	dimnames(result$yVar) <- dimnames(result$yMean);
	try(dim(result$yMeanVar) <- dim(result$yMean)); # reshaping yMeanVar
	try(dimnames(result$yMeanVar) <- dimnames(result$yMean));
	#
	result$regScore <- result$yMean[nBin, , ] - result$yMean[1, , ] # calculating regulation score
	result;
}

bartExpr <- function(tgtLevel, tfLevel, testTfLevel, regMat, verbose = TRUE, noiseModel = c("lognormal", "normal", "linear", "sqrt"), ...) {
	# use BART to predict expressions
	# expression: training target expression levels, in foldchange with respect to wildtype
	# tfLevel: training regulator expression levels, in foldchange with respect to wildtype, the log of which will be fed to BART
	# testTfLevel: query regulator expression levels
	# regMat: adjacency matrix of a prior allowed interactions: ij entry represens wether regulator i is allowed to regulate target j. If missing, everything except self-regulation is allowed
	# noiseModel: "lognormal", "normal", or an object of class AhnNoiseModel
	# returned fields:
	#	yMean: predicted transformed target level
	#	yVar: posterior variance of target level in prediction
	#	predicted: predicted target level in foldchange with respect to wild type
	result <- list();
	if (is.character(noiseModel)) { # determine transform and backTransform from noiseModel
		noiseModel <- match.arg(noiseModel);
		if (noiseModel == "normal" || noiseModel == "linear") {
			transform <- function(x) x;
			backTransform <- function(x) x;
		} else {
			if (noiseModel == "lognormal") {
				transform <- function(x) log(x);
				backTransform <- function(x) exp(x);
			} else {
				if (noiseModel == "sqrt") {
					transform <- function(x) log(sqrt(x));
					backTransform <- function(x) pmax(x, 0)^2;
				}
			}
		}
	} else {
		if ("HbNoiseTransform" %in% class(noiseModel)) {
			transform <- noiseModel$toNormal;
			backTransform <- noiseModel$fromNormal;
		} else {
			if (is.list(noiseModel)) {
				transform <- noiseModel$transform;
				backTransform <- noiseModel$backTransform;
			}
		}
	}
	# calling BART
	barted <- bartMultiresponse(x.train = log(tfLevel), y.train = transform(tgtLevel), x.test = log(testTfLevel), allowed = regMat, verbose = verbose, simplify = TRUE,...);
	result <- c(result, barted);
	result$predicted <- backTransform(barted$yMean); # transform the prediction back to the space of fold changes
	result;
}

bartMultiresponse <- function(x.train, y.train, x.test = NULL, allowed, simplify = TRUE, verbose = TRUE, mpiComm, blockSize, saveTo, ...) {
	# wrapper for using bart on multiple responses, able to invoke mpi
	# allowed: matrix whose ij entry tells if explanatory variable i should be used for response j; by default, if variables names are given in the colnames of x.train and y.train, every explanatory relation is allowed except for a variable explaining itself
	# mpiComm: missing or integer; if specified, will invoke mpi on the given comm number mpiComm (see package Rmpi for details)
	# blockSize: when using mpiComm, each step in the interation a number blockSize of response variables will be dispatched to mpi processes for bart calculation. Default is approximately square root of number of reponse variables
	# saveTo: a file to store current result during calculation; since calculation may take along, partial results are stored in case calculation gets terminated accidentally
	# simplify: same meaning as in function bartRobust, recommend simplify = TRUE other wise spatial complexity with be astronomical
	# verbose = 1: print progress only; verbose = 2: print progress and bart output
	nResponse <- ncol(y.train);
	nExplanatory <- ncol(x.train);
	responseName <- colnames(y.train);
	explanatoryName <- colnames(x.train);
	result <- list(); # place to store results.
	bartedList <- list();
	if (missing(allowed)) {
		# in case allowed is not specified, all exlanatory relations are by default allowed except for self-explaining
		allowed <- matrix(TRUE, nExplanatory, nResponse, dimnames = list(explanatoryName, responseName));
		selfReg <- intersect(responseName, explanatoryName);
		allowed[cbind(selfReg, selfReg)] <- FALSE;
	}
	#
	# function to apply to each response variable for BART analysis
	applicand <- function(i, ...) {
# 		require("Matrix");
        library("Matrix")
		theX <- as.matrix(x.train[, allowed[, i], drop = FALSE]);
		theY <- y.train[, i];
		theTestX <- as.matrix(x.test[, allowed[, i], drop = FALSE]);
		bartRobust(
			x.train = theX,
			y.train = theY,
			x.test = theTestX,
			...
		);
	}
	#
	if (missing(mpiComm) || is.null(mpiComm)) { # calculate without invoking mpi
# 		require("foreach");
# 		require("doParallel");
        library("foreach")
        library("doParallel")

		## define pool
		pool <- makeCluster(min(11, detectCores()[1]-1), outfile="")
		registerDoParallel(pool)
		print(pool)

		## pre-convert list names
		gene2indx <- list()
		for (i in seq(nResponse)) {
			gene2indx[[responseName[i]]] <- i;
		}
		## parallel for loop
		pb <- txtProgressBar(0, nResponse, style=3)
		bartedList <- foreach(i=gene2indx,
							.inorder=T,
							.final=function(x) setNames(x, names(gene2indx)),
							.export=c("bartRobust")
							) %dopar% {
			# if (verbose) print(paste(i, "/", nResponse, responseName[i]));
			if (verbose) setTxtProgressBar(pb, i);
			try(applicand(i, simplify = simplify, verbose = pmax(verbose - 1, 0), ...));
			}
		## exit pool
		stopCluster(pool)

		## old serial processing
		# for (i in sequence(nResponse)) {
		# 	if (verbose) print(paste(i, "/", nResponse, responseName[i]));
		# 	bartedList[[responseName[i]]] <- try(applicand(i, simplify = simplify, verbose = pmax(verbose - 1, 0), ...));
		# 	if (!missing(saveTo) && !is.null(saveTo)) save(bartedList, file = saveTo);
		# }
	} else { # calculate with mpi
# 		require("Rmpi");
        library("Rmpi")
		# try(Sys.setenv(OMPI_MCA_btl_tcp_if_include="eth0"));
		if (mpi.comm.size(comm = mpiComm) == 0) { # initialize mpi comm if have not done so yet
			if (missing(blockSize)) blockSize <- floor(sqrt(nResponse));
			mpi.spawn.Rslaves(nslaves = blockSize, comm = mpiComm);
		}
		nBlock <- ceiling(nResponse / blockSize);
		blockLabel <- head(rep(seq(nBlock), each = blockSize), nResponse);
		blockIxList <- split(seq(nResponse), blockLabel); # a list of which each element is index set of one block
		mpi.bcast.Robj2slave(x.train, comm = mpiComm);
		mpi.bcast.Robj2slave(y.train, comm = mpiComm);
		mpi.bcast.Robj2slave(x.test, comm = mpiComm);
		mpi.bcast.Robj2slave(allowed, comm = mpiComm);
		mpi.bcast.Robj2slave(bartRobust, comm = mpiComm);
		try(mpi.bcast.Rfun2slave(comm = mpiComm));
		environment(applicand) <- globalenv(); # very important, so function applicand broadcasted to other mpi processes will read variables from their global environments instead of bringing this environment with it
		for (i in seq(nBlock)) {
			if (verbose) print(paste(i, "/", nBlock));
			bartedList <- c(bartedList, mpi.apply(blockIxList[[i]], applicand, simplify = simplify, verbose = pmax(verbose - 1, 0), comm = mpiComm, ...));
			if (!missing(saveTo) && !is.null(saveTo)) save(bartedList, file = saveTo);
		}
	}
	names(bartedList) <- responseName;
	bartedList <- lapply(bartedList, as.list); # in case one bart call returns an error message, the error message will be covnerted to a list
	if (!missing(saveTo) && !is.null(saveTo)) save(bartedList, file = saveTo);
	if (simplify) { # simplify results
		result$yMean <- cbindCountingNull(lapply(bartedList, "[[", "yMean"));
		result$yMeanVar <- cbindCountingNull(lapply(bartedList, "[[", "yMeanVar"));
		result$yVar <- cbindCountingNull(lapply(bartedList, "[[", "yVar"));
		colnames(result$yMean) <- responseName;
		rownames(result$yMean) <- rownames(if (missing(x.test) || is.null(x.test)) x.train else x.test);
		dimnames(result$yMeanVar) <- dimnames(result$yMean);
		dimnames(result$yVar) <- dimnames(result$yMean);
		result$sigest <- c(cbindCountingNull(lapply(bartedList, "[[", "sigest")));
		names(result$sigest) <- responseName;
		result;
	} else {
		bartedList;
	}
}

bartRobust <- function(x.train, y.train, x.test, simplify = FALSE, keepBartObj = TRUE, keepevery = 1, verbose = TRUE, sigest = NA, ...) {
	# wrap bart to a more robust function, circumventing some bugs there, and adding some useful stats about the query prediction in fields in the result:
	# 	$barted: the orignal bart object returned
	# 	$yMean: mean of posterior prediction, rows are samples, ncol = 1;
	#	$y: posterior predictions, rows are samples, ncol = 1, third dimension is MCMC steps
	#	$yVar: posterior variance, rows are samples, ncol = 1
	# for internal usage, called by other functions.
	# x.test: query features, default is using training data
	# keepevery: thinning number, see bart in package BayesTree
	# sigest: may be left unspecified; see bart in package BayesTree
	# keepBartObj: if FALSE, result$barted will be removed (overridden by simplify = TRUE)
	# simplify: if TRUE, return only fields yMean, yVar, yMeanVar and sigest
# 	require("BayesTree");
# 	require("matrixStats");
    library("BayesTree")
    library("matrixStats")

	result <- list(); # place to store results.
	#
	#if (missing(x.test)) x.test <- x.train[c(), , drop = FALSE]; # use empty test data if not specified otherwise
	#
	nonNaIx <- c(!is.na(y.train)); 		#
	x <- x.train[nonNaIx, , drop = FALSE];		#
	y <- y.train[nonNaIx];				# remove NA entries
	if (ncol(x) > nrow(x) - 1 && is.na(sigest)) sigest <- sd(y, na.rm = TRUE); # in case ncol(x) > nrow(x) - 1, sigest get manually specified here, otherwise bart would run into a bug and crash
	if (length(unique(y)) > 1) { # only call bart if there's multiple values in training reponses y, otherwise bart would run into a bug and crash
		defaultTest <- if (missing(x.test) || is.null(x.test)) matrix(0, 0, 0) else x.test;
		set.seed(747)
		result$barted <- bart(
			x.train = x,
			y.train = y,
			x.test = defaultTest,
			keepevery = keepevery,
			verbose = (verbose != 0),
			sigest = sigest,
			...
		);
		# summarizing results
		if (missing(x.test) || is.null(x.test)) { # summarize training result if x.test is not specified
			result$yMean <- cbind(y * NA);
			result$yMean[nonNaIx, ] <- result$barted$yhat.train.mean;
			rownames(result$yMean) <- rownames(x.train);
			result$y <- array(NA, c(dim(result$yMean), nrow(result$barted$yhat.train)));
			dimnames(result$y)[1:2] <- dimnames(result$yMean);
			result$y[nonNaIx, , ] <- c(t(result$barted$yhat.train));
			result$yMeanVar <- result$yMean * NA;
			result$yMeanVar[nonNaIx, ] <- colVars(result$barted$yhat.train);
		} else { # summarize query result if x.test is given
			result$yMean <- cbind(result$barted$yhat.test.mean);
			rownames(result$yMean) <- rownames(x.test);
			result$y <- array(NA, c(dim(result$yMean), nrow(result$barted$yhat.test)));
			dimnames(result$y)[1:2] <- dimnames(result$yMean);
			result$y[] <- c(t(result$barted$yhat.test));
			result$yMeanVar <- result$yMean * NA;
			result$yMeanVar[] <- colVars(result$barted$yhat.test);
		}
		result$yVar <- mean(result$barted$sigma^2) + result$yMeanVar;
		result$sigest <- result$barted$sigest;
	} else { # trivial case, no need to run bart
		result$barted <- list();
		if (missing(x.test)) {
			result$yMean <- matrix(y[1], nrow(x.train), 1, dimnames = list(rownames(x.train), colnames(y.train)));
		} else {
			result$yMean <- matrix(y[1], nrow(x.test), 1, dimnames = list(rownames(x.test), colnames(y.train)));
		}
		result$y <- result$yMean;
		result$yMeanVar <- result$yMean * 0;
		result$yVar <- result$yMean * 0;
		result$sigest <- 0;
	}
	#
	if (!keepBartObj) result$barted <- NULL;
	if (simplify) result[c("yMean", "yVar", "yMeanVar", "sigest")] else result;
}

robustBart <- bartRobust;

cbindCountingNull <- function(colList, default = NA) { # column-binding elements of colList, with null elements replaced by NA columns
	nullIx <- mapply(is.null, colList);
	nonNullCombined <- do.call("cbind", colList[!nullIx]);
	combined <- matrix(default, nrow(nonNullCombined), length(colList));
	rownames(combined) <- rownames(nonNullCombined);
	colnames(combined) <- names(colList);
	combined[, !nullIx] <- nonNullCombined;
	combined;
}

# save.image();

# # formating input arguments
# argStringList <- commandArgs()[7:length(commandArgs())]
# argTable <- read.table(text = unlist(argStringList), sep = "=", header = 0, stringsAsFactors = FALSE, row.names = 1);
# write.table(t(argTable), file = textConnection("transposedArgString", open = "w"), quote= FALSE);
# argList <- as.list(read.table(text = transposedArgString, stringsAsFactors = FALSE));
#
# # reading data
# fc <- as.matrix(read.table(argList$fcFile, check.names=FALSE, sep="\t")); # training fold change expression matrix, rows are samples, cols are genes
# isPerturbed <- as.matrix(read.table(argList$isPerturbedFile, check.names=FALSE)); # training logical matrix of perturbation, rows are samples, cols are genes
# tfName <- read.table(argList$tfNameFile, stringsAsFactors = FALSE)[[1]]; # get TF names, each row is a TF

# # preparing training data
# tfLevel <- matrix(1, nrow(fc), length(tfName), dimnames = list(rownames(fc), tfName));
# availableTfName <- intersect(tfName, colnames(fc)); # names of TFs available in the expression data
# unavailableTfName <- setdiff(tfName, colnames(fc));
# if (length(unavailableTfName) > 0) warning(paste("data unavailable for TF", paste(unavailableTfName, collapse = ", ")));
# tfLevel[, availableTfName] <- fc[, availableTfName];
# tgtLevel <- fc;
# tgtLevel[isPerturbed] <- NA;  # masking perturbed entries in response variables from training

# # preparing regMat
# nTf <- ncol(tfLevel);
# nTgt <- ncol(tgtLevel);
# tgtName <- colnames(tgtLevel);
# regMat <- matrix(FALSE, nTf, nTgt, dimnames = list(tfName, tgtName));
# regMat[availableTfName, ] <- TRUE; # only allow a target to be regulated by TFs whose expression levels are avaiable in the data
# regMat[cbind(availableTfName, availableTfName)] <- FALSE; # disallow autoregulation

# if (!is.null(argList$saveTo)) saveProcessTo <- paste(argList$saveTo, ".bartProcess.RData", sep = "") else saveProcessTo <- NULL;
# if (!is.null(argList$useMpi))
# 	if (argList$useMpi)
# 		mpiComm <- 1 else mpiComm <- NULL;
# if (!is.null(argList$mpiBlockSize))
# 	if (argList$mpiBlockSize)
# 		mpiBlockSize <- argList$mpiBlockSize else mpiBlockSize <- 1;

# #try(Sys.setenv(OMPI_MCA_btl_tcp_if_include="eth0")); # otherwise mpi freezes, not sure why. Please ask IT support for details
# result <- getBartNetwork(
# 	tgtLevel = tgtLevel,
# 	tfLevel = tfLevel,
# 	regMat = regMat,
# 	mpiComm = mpiComm,
# 	blockSize = mpiBlockSize,
# 	saveTo = saveProcessTo
# );

# if (!is.null(argList$saveTo)) {
# 	save(result, file = paste(argList$saveTo, ".bartResult.RData", sep = ""));
# 	write.table(result$regScore, file = argList$saveTo, sep = "\t");
# }


################################################################################
# library("glmnet")
# library("randomForest")
# library("gbm")

ResidualTrain <- function(train.name,old.method,old.args,new.method,new.args) {
	# Creates a model for predicting residuals
	#
	# Args:
	#	train.name: base name of training dataset
	#	old.method: first method used to make predictions (string)
	#	old.args: list of arguments passed to first method to make predictions
	#	new.method: method to be used for training on residuals (string)
	#	new.args: list of arguments passed to new method to predict on residuals
	#
	# Returns:
	#	A model for predicting residuals on test data
	#
	# Example usage:
	#	old.args<-list(test.name="test",R=1,corr.bias=FALSE,pls=FALSE,prune=FALSE,
	#		std=FALSE,features=c("static","alsfrs","fvc","svc","vital"),
	#		slope.features=NULL)
	#	new.args=list(test.name="test",R=1,pls=FALSE,prune=FALSE,std=FALSE,
	#		features=c("static","alsfrs","fvc","svc","vital","lab"),
	#		slope.features=NULL)
	#	model<-ResidualTrain("train",old.method="RandomForestTrain",
	#		old.args=old.args,new.method="GbmTrain",new.args=new.args)
	# 	predictions<-model("test")

	# Get test name
	test.name<-old.args[["test.name"]]

	# Get filename of old prediction
	old.train.file<-GetPredictionFilename(old.method,train.name,train.name,old.args)

	# If it exists, load it
	old.preds.exist<-file.exists(old.train.file)
	if (old.preds.exist) {
		print(paste("loading first method prediction from",old.train.file))
		old.train.pred<-read.csv(old.train.file,sep=",",header=FALSE)
	}
	# Otherwise get the model and predictions
	else {
		print("Running first method")
		method.old<-get(old.method)
		old.model<-method.old(train.name,args=old.args)
		old.train.pred<-old.model(train.name)
	}

	# Initialize training targets
	target<-Slopes(GetAlsfrsData(train.name),3,12,"f")

	# Subtract predictions from target to get residuals
	new.target<-target-old.train.pred[,2]

	# Train on residuals with method
	method.new<-get(new.method)
	new.model<-method.new(train.name,target=new.target,args=new.args)

	ResidualPredict <- function(test.name="test",save.preds=TRUE) {
	# Makes predictions for residuals
	#
	# Args:
	#	test.name: base name of test data
	#	save.preds: save predictions to file? TRUE by default
	#
	# Returns:
	#	Two column matrix, ordered by the first column, with first column
	#   "subject.id" containing test set subject ids and the second column
	#   "prediction" containing predicted slopes.
	#
	# Side effects:
	#	Saves predictions to file

		# Get old test file name
		old.test.file<-GetPredictionFilename(old.method,train.name,test.name,old.args)

		# If there was no old training prediction file or no test prediction file,
		# create the old predictions for the test data
		if (!old.preds.exist|!file.exists(old.test.file)) {
			old.test.pred<-old.model(test.name,save.preds=TRUE)
		}

		# If old test file exists, read in
		else {
			old.test.pred<-read.csv(old.test.file,sep=",",header=FALSE)
		}

		# Form predictions by adding old test predictions to test residual predictions
		predictions<-old.test.pred[,2]+new.model(test.name,save.preds=FALSE)[,2]

		predictions<-cbind(old.test.pred[,1],predictions)
		colnames(predictions)<-c("subject.id","predictions")

		if(save.preds) {
			# Write predictions to file
			out.file = GetPredictionFilename("Residual",train.name,test.name,
				args=c(old.method,old.args,new.method,new.args))
			WritePredictions(predictions, out.file)
		}

		return(predictions)
	}

	return(ResidualPredict)
}


#' Rdym
#'
#' Most search engines have a "did you mean?" feature, where
#' suggestions are given in the presence of likely typos. We are able to
#' somewhat replicate this functionality with ancient spellchecker techniques.
#' When R detects that a function or object listed in the user's input is not
#' found, the package finds the minimum 'Levenshtein' distance between the
#' "'un-found'" token and all symbols in the user's global environment plus all
#' loaded 'namespaces'.  The word with minimum 'Levenshtein' distance (in the event
#' of ties, the first such detected) is then suggested as an alternative to the
#' missing symbol.  To use, simply load the package from an interactive R
#' session and start making some errors.  However, there is an explicit
#' interface for starting and stopping "did you mean?" behavior.
#'
#' @useDynLib Rdym R_levenshtein_dist R_find_closest_word
#'
#' @name Rdym-package
#' @docType package
#' @author Drew Schmidt and Homer White
#' @keywords Package
NULL


  panel.levelplot =  function (x, y, z, subscripts, at = pretty(z), shrink, labels = FALSE,
    label.style = c("mixed", "flat", "align"), contour = FALSE,
    region = TRUE, col = add.line$col, lty = add.line$lty, lwd = add.line$lwd,
    ..., col.regions = regions$col, alpha.regions = regions$alpha, rez=NULL )
{
  # copy from lattice: panel.levelplot
  # modifying the grid.rect() to be a user specified (fixed) value
    require(grid)

    if (length(subscripts) == 0)
        return()
    regions <- trellis.par.get("regions")
    label.style <- match.arg(label.style)
    x.is.factor <- is.factor(x)
    y.is.factor <- is.factor(y)
    x <- as.numeric(x)
    y <- as.numeric(y)
    z <- as.numeric(z)
    zcol <- level.colors(z, at, col.regions, colors = TRUE)
    x <- x[subscripts]
    y <- y[subscripts]
    minXwid <- if (length(unique(x)) > 1)
        min(diff(sort(unique(x))))
    else 1
    minYwid <- if (length(unique(x)) > 1)
        min(diff(sort(unique(y))))
    else 1
    fullZrange <- range(as.numeric(z), finite = TRUE)
    z <- z[subscripts]
    zcol <- zcol[subscripts]
    shrinkx <- c(1, 1)
    shrinky <- c(1, 1)
    if (!missing(shrink)) {
        if (is.numeric(shrink)) {
            shrinkx <- rep(shrink, length.out = 2)
            shrinky <- rep(shrink, length.out = 2)
        }
        else if (is.list(shrink)) {
            shrinkx <- rep(shrink[[1]], length.out = 2)
            shrinky <- rep(shrink[[1]], length.out = 2)
            if ("x" %in% names(shrink))
                shrinkx <- rep(shrink$x, length.out = 2)
            if ("y" %in% names(shrink))
                shrinky <- rep(shrink$y, length.out = 2)
        }
        else warning("Invalid 'shrink' parameter ignored")
    }
    scaleWidth <- function(z, min = 0.8, max = 0.8, zl = range(z,
        finite = TRUE)) {
        if (diff(zl) == 0)
            rep(0.5 * (min + max), length(z))
        else min + (max - min) * (z - zl[1])/diff(zl)
    }
    if (x.is.factor) {
        ux <- sort(unique(x[!is.na(x)]))
        lx <- rep(1, length(ux))
        cx <- ux
    }
    else {
        ux <- sort(unique(x[!is.na(x)]))
        bx <- if (length(ux) > 1)
            c(3 * ux[1] - ux[2], ux[-length(ux)] + ux[-1], 3 *
                ux[length(ux)] - ux[length(ux) - 1])/2
        else ux + c(-0.5, 0.5) * minXwid
        lx <- diff(bx)
        cx <- (bx[-1] + bx[-length(bx)])/2
    }
    if (y.is.factor) {
        uy <- sort(unique(y[!is.na(y)]))
        ly <- rep(1, length(uy))
        cy <- uy
    }
    else {
        uy <- sort(unique(y[!is.na(y)]))
        by <- if (length(uy) > 1)
            c(3 * uy[1] - uy[2], uy[-length(uy)] + uy[-1], 3 *
                uy[length(uy)] - uy[length(uy) - 1])/2
        else uy + c(-0.5, 0.5) * minYwid
        ly <- diff(by)
        cy <- (by[-1] + by[-length(by)])/2
    }
    idx <- match(x, ux)
    idy <- match(y, uy)
    if (region) {
        grid.rect(x = cx[idx], y = cy[idy], width = rez[1],
            height = rez[2], default.units = "native", gp = gpar(fill = zcol,
                lwd = 0.00001, col = "transparent", alpha = alpha.regions))
    }
    if (contour) {
        cpl <- current.panel.limits(unit = "cm")
        asp <- diff(cpl$ylim)/diff(cpl$xlim)
        if (is.logical(labels) && !labels)
            labels <- NULL
        else {
            if (is.characterOrExpression(labels))
                labels <- list(labels = labels)
            text <- trellis.par.get("add.text")
            tmp <- list(col = text$col, alpha = text$alpha, cex = text$cex,
                fontfamily = text$fontfamily, fontface = text$fontface,
                font = text$font)
            labels <- if (is.list(labels))
                updateList(tmp, labels)
            else tmp
            if (!is.characterOrExpression(labels$labels))
                labels$labels <- format(at, trim = TRUE)
        }
        add.line <- trellis.par.get("add.line")
        m <- matrix(NA_real_, nrow = length(ux), ncol = length(uy))
        m[(idy - 1) * length(ux) + idx] <- z
        clines <- contourLines(x = ux, y = uy, z = m, nlevels = length(at),
            levels = at)
        for (val in clines) {
            llines(val, col = col, lty = lty, lwd = lwd)
            if (length(val$x) > 5) {
                if (!is.null(labels)) {
                  slopes <- diff(val$y)/diff(val$x)
                  if (label.style == "flat") {
                    textloc <- which.min(abs(slopes))
                    rotangle <- 0
                  }
                  else if (label.style == "align") {
                    rx <- range(ux)
                    ry <- range(uy)
                    depth <- pmin(pmin(val$x - rx[1], rx[2] -
                      val$x)/diff(rx), pmin(val$y - ry[1], ry[2] -
                      val$y)/diff(ry))
                    textloc <- min(which.max(depth), length(slopes))
                    rotangle <- atan(asp * slopes[textloc] *
                      diff(rx)/diff(ry)) * 180/base::pi
                  }
                  else if (label.style == "mixed") {
                    rx <- range(ux)
                    ry <- range(uy)
                    depth <- pmin(pmin(val$x - rx[1], rx[2] -
                      val$x)/diff(rx), pmin(val$y - ry[1], ry[2] -
                      val$y)/diff(ry))
                    textloc <- which.min(abs(slopes))
                    rotangle <- 0
                    if (depth[textloc] < 0.05) {
                      textloc <- min(which.max(depth), length(slopes))
                      rotangle <- atan(asp * slopes[textloc] *
                        diff(rx)/diff(ry)) * 180/base::pi
                    }
                  }
                  else stop("Invalid label.style")
                  i <- match(val$level, at)
                  ltext(labels$labels[i], adj = c(0.5, 0), srt = rotangle,
                    col = labels$col, alpha = labels$alpha, cex = labels$cex,
                    font = labels$font, fontfamily = labels$fontfamily,
                    fontface = labels$fontface, x = 0.5 * (val$x[textloc] +
                      val$x[textloc + 1]), y = 0.5 * (val$y[textloc] +
                      val$y[textloc + 1]))
                }
            }
        }
    }
}


#' Load raw beta matrix
#'
#' @param qc.objects A list of outputs from \code{\link{meffil.create.qc.object}()}.
#' @param pseudo Value to add to the denominator to make the methylation
#' estimate more stable when calculating methylation levels (Default: 100).
#' @param just.beta If \code{TRUE}, then return just the methylation levels; otherwise,
#' return the methylated and unmethylated matrices (Default: TRUE).
#' @param verbose If \code{TRUE}, then detailed status messages are printed during execution (Default: \code{FALSE}).
#' @param ... Arguments passed to \code{\link[parallel]{mclapply}()}.
#' @return If \code{just.beta == TRUE}, the matrix of
#' methylation levels between between 0 and 1
#' equal to methylated signal/(methylated + unmethylated signal + pseudo).
#' Otherwise, a list containing two matrices, the methylated and unmethylated signals.
#'
#' @export
meffil.load.raw.data <- function(qc.objects,
                                 pseudo=100,
                                 just.beta=T,
                                 max.bytes=2^30-1,
                                 verbose=F,
                                 ...) {
    stopifnot(all(sapply(qc.objects, is.qc.object)))

    featuresets <- sapply(qc.objects, function(qc.object) qc.object$featureset)
    featureset <- featuresets[1]

    if (is.list(featuresets)) { ## backwards compatibility
        featureset <- featuresets <- "450k"
    }

    if (any(featuresets != featureset))
        stop("Multiple feature sets were used to create these QC objects:",
             paste(unique(featuresets), collapse=", "))

    sites <- meffil.get.sites(featureset)

    intensity.R <- sapply(qc.objects, function(object) object$intensity.R)
    intensity.G <- sapply(qc.objects, function(object) object$intensity.G)
    valid.idx <- which(intensity.R + intensity.G > 200)
    if (length(valid.idx) == 0) {
        valid.idx <- 1:length(intensity.R)
        warning("All of the microarrays have very low intensity")
    }
    reference.idx <- valid.idx[which.min(abs(intensity.R/intensity.G-1)[valid.idx])]
    dye.intensity <- (intensity.R + intensity.G)[reference.idx]/2

    ret <- mcsapply.safe(qc.objects, function(qc.object) {

        if (is.null(qc.object$featureset)) { ## backwards compatibility
            qc.object$chip <- qc.object$featureset <- "450k"
        }

        probes <- meffil.probe.info(qc.object$chip)
        rg <- read.rg(qc.object$basename, verbose=verbose)
        rg <- background.correct(rg, probes, verbose=verbose)
        rg <- dye.bias.correct(rg, probes, dye.intensity, verbose=verbose)
        mu <- rg.to.mu(rg, probes)

        m.idx <- match(sites, names(mu$M))
        u.idx <- match(sites, names(mu$U))
        if (just.beta)
            get.beta(unname(mu$M[m.idx]), unname(mu$U[u.idx]), pseudo)
        else
            c(unname(mu$M[m.idx]), unname(mu$U[u.idx]))
    }, ..., max.bytes=max.bytes)

    if (!just.beta) {
        ret <- list(M=ret[1:length(sites),],
                    U=ret[(length(sites)+1):nrow(ret),])
        dimnames(ret$M) <- dimnames(ret$U) <- list(sites, names(qc.objects))
    }
    else
        dimnames(ret) <- list(sites, names(qc.objects))
    ret
}


#!/usr/bin/env Rscript

####################
#
# Parameters:
# 1 - File to scale
# 2 - File containing scale values
# 3 - File containing center values
# 4 - Output file with scaling dataset
#
###################
args <- commandArgs(trailingOnly = TRUE)
validation = read.csv(args[1], check.names=FALSE)
center_values <- readRDS(paste(args[2],sep = ""))
scale_values <- readRDS(paste(args[3],sep = ""))

validation_scaled = mapply(function(x, y, z) scale((x), center=y, scale=z), (validation), (center_values[,1]), (scale_values[,1]))

#Shift to the right in order to avoid negative values
validation_scaled <- validation_scaled + 300

independent = args[5]
validation_scaled[,independent] <- validation[,independent]

if("timestamp" %in% colnames(validation_scaled)){
  validation_scaled[,"timestamp"] <- validation$timestamp
}
if("Core_1CPU" %in% colnames(validation_scaled)){
  validation_scaled[,"Core_1CPU"] <- validation$Core_1CPU
}
if("Core_2CPU" %in% colnames(validation_scaled)){
  validation_scaled[,"Core_2CPU"] <- validation$Core_2CPU
}
if("numSockets" %in% colnames(validation_scaled)){
  validation_scaled[,"numSockets"] <- validation$numSockets
}
validation_scaled[is.na(validation_scaled)] <- 0
validation_scaled[is.infinite(validation_scaled)] <- 0

#validation_scaled <- round(validation_scaled,6)

write.csv(validation_scaled, file = args[4],row.names=FALSE)


library(keras)
library(readr)
library(stringr)
library(purrr)
library(tibble)
library(dplyr)

# Function definition -----------------------------------------------------

tokenize_words <- function(x){
  x <- x %>%
    str_replace_all('([[:punct:]]+)', ' \\1') %>%
    str_split(' ') %>%
    unlist()
  x[x != ""]
}

parse_stories <- function(lines, only_supporting = FALSE){
  lines <- lines %>%
    str_split(" ", n = 2) %>%
    map_df(~tibble(nid = as.integer(.x[[1]]), line = .x[[2]]))

  lines <- lines %>%
    mutate(
      split = map(line, ~str_split(.x, "\t")[[1]]),
      q = map_chr(split, ~.x[1]),
      a = map_chr(split, ~.x[2]),
      supporting = map(split, ~.x[3] %>% str_split(" ") %>% unlist() %>% as.integer()),
      story_id = c(0, cumsum(nid[-nrow(.)] > nid[-1]))
    ) %>%
    select(-split)

  stories <- lines %>%
    filter(is.na(a)) %>%
    select(nid_story = nid, story_id, story = q)

  questions <- lines %>%
    filter(!is.na(a)) %>%
    select(-line) %>%
    left_join(stories, by = "story_id") %>%
    filter(nid_story < nid)

  if(only_supporting){
    questions <- questions %>%
      filter(map2_lgl(nid_story, supporting, ~.x %in% .y))
  }

  questions %>%
    group_by(story_id, nid, question = q, answer = a) %>%
    summarise(story = paste(story, collapse = " ")) %>%
    ungroup() %>%
    mutate(
      question = map(question, ~tokenize_words(.x)),
      story = map(story, ~tokenize_words(.x)),
      id = row_number()
    ) %>%
    select(id, question, answer, story)
}

vectorize_stories <- function(data, vocab, story_maxlen, query_maxlen){

  questions <- map(data$question, function(x){
    map_int(x, ~which(.x == vocab))
  })

  stories <- map(data$story, function(x){
    map_int(x, ~which(.x == vocab))
  })

  # "" represents padding
  answers <- sapply(c("", vocab), function(x){
    as.integer(x == data$answer)
  })

  list(
    questions = pad_sequences(questions, maxlen = query_maxlen),
    stories   = pad_sequences(stories, maxlen = story_maxlen),
    answers   = answers
  )
}

# Parameters --------------------------------------------------------------

max_length <- 99999
embed_hidden_size <- 50
batch_size <- 32
epochs <- 40

# Data Preparation --------------------------------------------------------

path <- get_file(
  fname = "babi-tasks-v1-2.tar.gz",
  origin = "https://s3.amazonaws.com/text-datasets/babi_tasks_1-20_v1-2.tar.gz"
)
#path = "/Users/chan/.keras/datasets/babi-tasks-v1-2.tar.gz"
untar(path, exdir = str_replace(path, fixed(".tar.gz"), "/"))
path <- str_replace(path, fixed(".tar.gz"), "/")

# Default QA1 with 1000 samples
# challenge = '%stasks_1-20_v1-2/en/qa1_single-supporting-fact_%s.txt'
# QA1 with 10,000 samples
# challenge = '%stasks_1-20_v1-2/en-10k/qa1_single-supporting-fact_%s.txt'
# QA2 with 1000 samples
challenge <- "%stasks_1-20_v1-2/en/qa2_two-supporting-facts_%s.txt"
# QA2 with 10,000 samples
# challenge = '%stasks_1-20_v1-2/en-10k/qa2_two-supporting-facts_%s.txt'

train <- read_lines(sprintf(challenge, path, "train")) %>%
  parse_stories() %>%
  filter(map_int(story, ~length(.x)) <= max_length)

test <- read_lines(sprintf(challenge, path, "test")) %>%
  parse_stories() %>%
  filter(map_int(story, ~length(.x)) <= max_length)

# extract the vocabulary
all_data <- bind_rows(train, test)
vocab <- c(unlist(all_data$question), all_data$answer,
           unlist(all_data$story)) %>%
  unique() %>%
  sort()

# Reserve 0 for masking via pad_sequences
vocab_size <- length(vocab) + 1
story_maxlen <- map_int(all_data$story, ~length(.x)) %>% max()
query_maxlen <- map_int(all_data$question, ~length(.x)) %>% max()

# vectorized versions of training and test sets
train_vec <- vectorize_stories(train, vocab, story_maxlen, query_maxlen)
test_vec <- vectorize_stories(test, vocab, story_maxlen, query_maxlen)

# Defining the model ------------------------------------------------------

sentence <- layer_input(shape = c(story_maxlen), dtype = "int32")
encoded_sentence <- sentence %>%
  layer_embedding(input_dim = vocab_size, output_dim = embed_hidden_size) %>%
  layer_dropout(rate = 0.3)

question <- layer_input(shape = c(query_maxlen), dtype = "int32")
encoded_question <- question %>%
  layer_embedding(input_dim = vocab_size, output_dim = embed_hidden_size) %>%
  layer_dropout(rate = 0.3) %>%
  layer_lstm(units = embed_hidden_size) %>%
  layer_repeat_vector(n = story_maxlen)

merged <- list(encoded_sentence, encoded_question) %>%
  layer_add() %>%
  layer_lstm(units = embed_hidden_size) %>%
  layer_dropout(rate = 0.3)

preds <- merged %>%
  layer_dense(units = vocab_size, activation = "softmax")

model <- keras_model(inputs = list(sentence, question), outputs = preds)
model %>% compile(
  optimizer = "adam",
  loss = "categorical_crossentropy",
  metrics = "accuracy"
)

model

# Training ----------------------------------------------------------------

model %>% fit(
  x = list(train_vec$stories, train_vec$questions),
  y = train_vec$answers,
  batch_size = batch_size,
  epochs = epochs,
  validation_split=0.05
)

evaluation <- model %>% evaluate(
  x = list(test_vec$stories, test_vec$questions),
  y = test_vec$answers,
  batch_size = batch_size
)

evaluation


library(yaml)
library(s2dverification)
library(multiApply) # nolint
library(climdex.pcic)
library(ClimProjDiags) #nolint
library(parallel)
library(ncdf4)

## Insurance products
args <- commandArgs(trailingOnly = TRUE)
params <- read_yaml(args[1])

plot_dir <- params$plot_dir
run_dir <- params$run_dir
work_dir <- params$work_dir
## Create working dirs if they do not exist
dir.create(plot_dir, recursive = TRUE)
dir.create(run_dir, recursive = TRUE)
dir.create(work_dir, recursive = TRUE)

# setup provenance file and list
provenance_file <- paste0(run_dir, "/", "diagnostic_provenance.yml")
provenance <- list()

#FOR THE FIRST METADATA.yml
input_files_tasmax <- yaml::read_yaml(params$input_files[1])
model_names <- input_files_tasmax[[1]]$dataset
var_names_tmax <- input_files_tasmax[[1]]$short_name
experiment <- lapply(input_files_tasmax, function(x){x$exp}) #nolint
filename_tasmax <- lapply(input_files_tasmax, function(x){x$filename}) #nolint

input_files_tasmin <- yaml::read_yaml(params$input_files[2])
var_names_tmin <- input_files_tasmin[[1]]$short_name
filename_tasmin <- lapply(input_files_tasmin, function(x){x$filename}) #nolint

reference_files <- which(experiment == "historical")
projection_files <- which(experiment != "historical")

start_historical <- input_files_tasmax[[reference_files]]$start_year
end_historical <- input_files_tasmax[[reference_files]]$end_year
start_projection <- input_files_tasmax[[projection_files[1]]]$start_year
end_projection <- input_files_tasmax[[projection_files[1]]]$end_year

fullpath_hist_tasmax <- filename_tasmax[[reference_files]]
file <- nc_open(fullpath_hist_tasmax)
historical_tasmax <- ncvar_get(file, "tasmax")
names(dim(historical_tasmax)) <- rev(names(file$dim))[-1]
lat <- ncvar_get(file, "lat")
lon <- ncvar_get(file, "lon")
units <- ncatt_get(file, "tasmax", "units")$value
calendario <- ncatt_get(file, "time", "calendar")$value
long_names <-  ncatt_get(file, "tasmax", "long_name")$value
time <-  ncvar_get(file, "time")
start_date <- as.POSIXct(substr(ncatt_get(file, "time",
                                          "units")$value, 11, 29))
nc_close(file)

fullpath_hist_tasmin <- filename_tasmin[[reference_files]]
file <- nc_open(fullpath_hist_tasmin)
historical_tasmin <- ncvar_get(file, "tasmin")
names(dim(historical_tasmin)) <- rev(names(file$dim))[-1]
lat <- ncvar_get(file, "lat")
lon <- ncvar_get(file, "lon")
units <- ncatt_get(file, "tasmin", "units")$value
calendario <- ncatt_get(file, "time", "calendar")$value
long_names <-  ncatt_get(file, "tasmin", "long_name")$value
tunits <- ncatt_get(file, "time", "units")$value
time <-  ncvar_get(file, "time")
start_date <- as.POSIXct(substr(ncatt_get(file, "time",
                                          "units")$value, 11, 29))
nc_close(file)
dia <- as.Date(strsplit(tunits, " ")[[1]][3], format = "%Y-%m-%d")
time <- time + dia

dtr_base <- DTRRef(tmax = historical_tasmax, #nolint
                   tmin = historical_tasmin, by.seasons = TRUE,
                   ncores = NULL, dates = time, calendar = calendario)

for (i in 1 : length(projection_files)) {
    fullpath_projection_tasmax <- filename_tasmax[[projection_files[i]]]
    file <- nc_open(fullpath_projection_tasmax)
    rcp_tasmax <- ncvar_get(file, "tasmax")
    names(dim(rcp_tasmax)) <- rev(names(file$dim))[-1]
    lat <- ncvar_get(file, "lat")
    lon <- ncvar_get(file, "lon")
    units <- ncatt_get(file, "tasmax", "units")$value
    calendario <- ncatt_get(file, "time", "calendar")$value
    long_names <-  ncatt_get(file, "tasmax", "long_name")$value
    time <-  ncvar_get(file, "time")
    start_date <- as.POSIXct(substr(ncatt_get(file, "time",
                                          "units")$value, 11, 29))
    nc_close(file)

    fullpath_projection_tasmin <- filename_tasmin[[projection_files[i]]]
    file <- nc_open(fullpath_projection_tasmin)
    rcp_tasmin <- ncvar_get(file, "tasmin")
    names(dim(rcp_tasmin)) <- rev(names(file$dim))[-1]
    lat <- ncvar_get(file, "lat")
    lon <- ncvar_get(file, "lon")
    units <- ncatt_get(file, "tasmin", "units")$value
    calendario <- ncatt_get(file, "time", "calendar")$value
    long_names <-  ncatt_get(file, "tasmin", "long_name")$value
    tunits <- ncatt_get(file, "time", "units")$value
    time <-  ncvar_get(file, "time")
    start_date <- as.POSIXct(substr(ncatt_get(file, "time",
                                          "units")$value, 11, 29))
    nc_close(file)

    dia <- as.Date(strsplit(tunits, " ")[[1]][3], format = "%Y-%m-%d")
    time <- time + dia

dtr_indicator <- DTRIndicator(rcp_tasmax, rcp_tasmin, ref = dtr_base,
                              by.seasons = TRUE, ncores = NULL,
                              dates = time, calendar = calendario)

dtr_rcp <- array(dim = c(4, length(lon), length(lat)))
for (j in 1 : 4){
    dtr_rcp[j , , ] <- Mean1Dim(dtr_indicator$indicator[, j, , ], 1)#nolint
}
names(dim(dtr_rcp)) <- c("season", "lon", "lat")
title <- c("Number of days exceeding the DTR by 5 degrees",
          paste0("\n\nduring the period ", start_projection,
                 "-", end_projection))
PlotLayout(PlotEquiMap, plot_dims = c("lon", "lat"), #nolint
           var = dtr_rcp, colNA = "white", lon = lon, lat = lat,
           titles = c("DJF", "MAM", "JJA", "SON"), toptitle = title,
           filled.continents = FALSE, units = "Days", axelab = FALSE,
           draw_separators = TRUE, subsampleg = 1,
           brks = seq(0, max(dtr_rcp, na.rm = TRUE), 2),
           color_fun = clim.palette("yellowred"),
           extra_margin = c(0, 0, 1, 0),
           bar_extra_labels = c(2, 0, 0, 0), title_scale = 0.7,
           fileout = file.path(plot_dir, paste0("Seasonal_DTRindicator_",
                               model_names, "_", start_projection, "_",
                               end_projection, "_", start_historical, "_",
                               end_historical, ".png")),
           col_inf = "white", col_sup = "darkred")

dimlon <- ncdim_def(name = "lon", units = "degrees_east",
                    vals = as.vector(lon), longname = "longitude")
dimlat <- ncdim_def(name = "lat", units = "degrees_north",
                    vals = as.vector(lat), longname = "latitude")
dimseason <- ncdim_def(name = "season", units = "season", vals = 1 : 4,
                       longname = "season of the year: DJF, MAM, JJA, SON")
defdata <- ncvar_def(name = "VulnerabilityIndex", units = "number_of_days",
                   dim = list(season = dimseason, lat = dimlat, lon = dimlon),
                   longname = paste0("Number of days exceeding in 5 degrees ",
                                     "the Diurnal Temeprature Range for ",
                                     "the reference period"))
filencdf <- paste0(work_dir, "/", "Seasonal_DTRindicator_", model_names, "_",
                   start_projection, "_", end_projection, "_",
                   start_historical, "_", end_historical, ".nc")
file <- nc_create(filencdf, list(defdata))
ncvar_put(file, defdata, dtr_rcp)
nc_close(file)

    # Set provenance for output files
    xprov <- list(ancestors = list(filename_tasmin[[reference_files]],
                                   filename_tasmax[[reference_files]],
                                   filename_tasmin[[projection_files[i]]],
                                   filename_tasmax[[projection_files[i]]]),
                  authors = list("hunter_alasdair",
                                 "manubens_nicolau",
                                 "caron_louis-philippe"),
                  projects = list("c3s-magic"),
                  caption = title,
                  statistics = list("other"),
                  realms = list("atmos"),
                  themes = list("phys"),
                  plot_file = file.path(plot_dir,
              paste0("Seasonal_DTRindicator_", model_names, "_",
              start_projection, "_", end_projection, "_",
              start_historical, "_", end_historical, ".png")))

      provenance[[filencdf]] <- xprov
}

# Write provenance to file
write_yaml(provenance, provenance_file)


  exploitationrates = function( p, areas, labels=NULL, CFA4X.exclude.year.assessment=FALSE  ){

    if ( is.null(labels)) labels = areas

    # ------------ fisheries data
    landings = bio.snowcrab::snowcrab_landings_db()
    # year is year of capture
    # yr is "fishing year" relative to the assessment cycle

    landings.north = landings[ which(landings$cfa =="cfanorth"), ]
    ln = aggregate(landings.north$landings, list(yr=landings.north$yr), function(x) sum(x, na.rm=T))
    names(ln) = c("yr", "landings")
    ln = factor2number(ln, c("yr", "landings"))
    ln$id = paste(ln$yr, "cfanorth", sep=".")

    landings.south = landings[ which(landings$cfa =="cfasouth") , ]
    ls = aggregate(landings.south$landings, list(yr=landings.south$yr), function(x) sum(x, na.rm=T))
    names(ls) = c("yr", "landings")
    ls = factor2number(ls, c("yr", "landings"))
    ls$id = paste(ls$yr, "cfasouth", sep=".")

    landings.4x = landings[ which(landings$cfa =="cfa4x" ) , ]
    lx = aggregate(landings.4x$landings, list(yr=landings.4x$yr), function(x) sum(x, na.rm=T))
    names(lx) = c("yr", "landings")
    lx = factor2number(lx, c("yr", "landings"))
    lx$id = paste(lx$yr, "cfa4x", sep=".")

    # lx$landings[2:(nrow(lx))] = lx$landings[1:(nrow(lx)-1)]  # offset due to the fishing season being after the Survey

    la = rbind(ln, ls, lx)
    la$yr = NULL
    la$landings.kt = as.numeric(as.character(la$landings))/1000/1000

    # -----------  biomass data
    p$vars.to.model ="R0.mass"

    p = parallel_run( p=p, runindex=list(y=p$yrs, v=p$vars.to.model ) )

    td = interpolation.db( DS="interpolation.simulation", p=p )
    td = td[ which(td$region %in% areas ), ]
    td$id = paste(td$yr, td$region, sep=".")
    td$biomass = td$total / 1000
    td$lbound =  td$total.ub / 1000
    td$ubound =  td$total.lb / 1000

    td$total = NA

    X = merge( td, la, by="id", all.x=T, all.y=F, sort=F)
    td = X[ which(is.finite( X$biomass)) ,]

    years= sort(unique(td$yr))

    for (rs in areas) {
    for (ys in years) {

      i = which(td$yr == ys & as.character(td$region) == rs )
      j = which(td$yr == (ys-1) & as.character(td$region) == rs )

      # post-2002 surveys have surveys in autumn
        if (ys >= 2002) {
          td$total[i] = td$landings.kt[i] / (td$biomass[i] + td$landings.kt[i])
          td$lb[i] = td$landings.kt[i] / (td$ubound[i] + td$landings.kt[i])
          td$ub[i] = td$landings.kt[i] / (td$lbound[i] + td$landings.kt[i])
        } else if (ys <= 2001 ) {
          td$total[i] = td$landings.kt[i] / td$biomass[i]
          td$lb[i] = td$landings.kt[i] / td$ubound[i]
          td$ub[i] = td$landings.kt[i] / td$lbound[i]
        }
    }}

    td$region = factor(as.character(td$region), levels=areas, labels=labels)

    eps = 1e-6

    varstocheck = c("total", "ubound", "lbound")

    for (vs in varstocheck) {
      td[,vs] = td[,vs]
      kk = which(td[,vs] <= eps)
      if (length(kk)>0) td[kk,vs] = 0
    }

    td = td[is.finite(td$total) ,]
    td = td[order(td$region,td$yr),]

    if (CFA4X.exclude.year.assessment) {
        td$total[ which( td$region=="4X" & td$yr==p$year.assessment) ] = NA  # the fishery is ongoing
        td$ub[ which(td$region=="4X" & td$yr==p$year.assessment) ] = NA  # the fishery is ongoing
        td$lb[ which(td$region=="4X" & td$yr==p$year.assessment) ] = NA  # the fishery is ongoing
    }

    ii = which(td$region=="4X" & td$yr<2004)
    td$total[ ii ] = NA
    td$ub[ ii ] = NA
    td$lb[ ii ] = NA

    return(td)

  }


#' site.level_dirlichet_intercept.only_jags()
#' Fits a site.level dirlichet model with x-values ONLY OBSERVED AT SITE LEVEL.
#' Accounts for missing data.
#'
#' @param y species matrix as a dataframe. Column names are species names.
#' @param adapt   number of adaptive iterations for JAGS simulation.
#' @param burnin  number of burnin iterations for JAGS simulation.
#' @param sample  number of sample iterations for JAGS simulation.
#' @param n.chains number of chains for JAGS simulation.
#' @param parallel whether or not to run JAGS chains in parallel.
#'
#' @return returns a list with the fitted model, a list of species by parameter tables, and matrices of predicted, observed and residual values on the observation scale (0,1)
#' @export
#'
#' @examples
site.level_dirlichet_intercept.only_jags<-function(y,
                                          adapt = 500, burnin = 1000, sample = 2000, n.chains = 3,
                                          parallel = F, silent.jags = F){
  #Load some important dependencies.
  source('NEFI_functions/crib_fun.r')
  source('NEFI_functions/sd_to_precision.r')
  source('NEFI_functions/precision_matrix_match.r')

  #Some checks before we get started.
  y    <- as.data.frame(y)
  y.names <- colnames(y)

  ###massage your data together.
  #deal with zero relative abundances.
  y <- data.frame(y)

  #make sure every else is a matrix.
  y <- as.matrix(y)
  x <- as.matrix(rep(1, length(y)))

  ###setup jags data object.
  jags.data <- list(N = nrow(y), N.spp = ncol(y), #number of observations and number of species
                    y = y, x=x)                   #species matrix, y, x is vector of 1's.

  ###specify JAGS model.
  jags.model = "
  model {
  #parameter priors for each species.
  for(j in 1:N.spp){
    x.m[j] ~ dnorm(0, 1.0E-3)
  }

  #fit species abundances as a linear combination of predictors and parameters.
  for(i in 1:N){
    for(j in 1:N.spp){
      log(a0[i,j]) <- x.m[j] * x[i,]
    }
  y[i,1:N.spp] ~ ddirch(a0[i,1:N.spp])
  }

  } #close model loop.
  "

  ###Fit JAGS model.
  #parallel or not parallel.
  run.method <- ifelse(parallel == F,'rjags','rjparallel')
  #run jags model.
  jags.out <- runjags::run.jags(   model = jags.model,
                                   data = jags.data,
                                   adapt = adapt,
                                   burnin = burnin,
                                   sample = sample,
                                   n.chains = n.chains,
                                   method = run.method,
                                   silent.jags = silent.jags,
                                   monitor = c('x.m','deviance'))
  #summarize output
  out <- summary(jags.out)

  #grab parmeters by species, make a list of species-parameter dataframes
  output.list <- list()
  for(i in 1:ncol(y)){
    z <- out[grep("^x\\.m\\[",rownames(out), value = T),]
    z <-   z[i,]
    names <- c('intercept')
    z <- c(names,z)
    names(z)[1] <- 'predictor'
    output.list[[i]] <- data.frame(t(z))
  }
  names(output.list) <- y.names

  #get deviance score.
  deviance <- out[grep('deviance',rownames(out)),]

  #make a super output that also returns model
  super.list <- list(jags.out, output.list,y,deviance)
  names(super.list) <- c('jags_model','species_parameter_output','observed','deviance')

  #return model and output
  return(super.list)

} #end function.


# This function produces a map of the area surrounding a box of the study area using ggplot.
# The extent of the area to plot around the studyArea is defined by "buf" parameter in km (sets "zoom")
# This function was created for searchPEZ and it is used as a "basemap" for other plots
#
# Inputs:
# 1. studyArea: polygon of the study area (sf object, defined by the user in the shiny app)
# 2. site: polygon of a study site (like aquaculture site);for now it is a centroid (a point, centre of studyArea)
#    in the past we plotted the site polygon and site is kept for now as a placeholder for the future
# 3. land_layer: polygon developed for Atlantic canada, could be 10K or 50K scale (preloaded)
# 4. buf: how many km around the study area to plot (acts like "zoom")
# 5. CANborder: Canada border, including water (preloaded)
# 6. studyBox_geom: geometry portraying study box (defines the "look" of the study box, defined in the main script)
#
# Outputs: list containing 2 items
# 1. map, that can be used as a basemap for adding data layers
# 2. bounding box of the map that can be used for cropping datasets
#
# Written by Gordana Lazin for reproducibble reporting project, April 12, 2021
# ggplot map developed by Greg Puncher, winter/spring 2021

area_map <- function(studyArea,site,land_layer,buf, CANborder, studyBox_geom) {

  # buf is in km, and now converted to degrees
  buf=buf/100

  # bounding box for study area
  bbox=sf::st_bbox(studyArea)

  # create bounding box for buffer (plot area)
  bboxBuf=bbox

  bboxBuf["xmin"]=(bbox$xmin)-buf
  bboxBuf["xmax"]<-(bbox$xmax)+buf
  bboxBuf["ymin"]<-(bbox$ymin)-buf*0.72
  bboxBuf["ymax"]<-(bbox$ymax)+buf*0.72

  # convert buffer to polygon
  # pp=st_as_sfc(bboxBuf,crs=4326)

  # subset land to plot area to speed up plotting
  land=sf::st_crop(land_layer,bboxBuf)

  # subset US-Canad boundary to plot area to speed up plotting
  bound=sf::st_transform(CANborder,crs=4326) # to fix: currently the projection is NAD83
  bound=sf::st_crop(bound,bboxBuf)

  # make a plot and write it to m
  m<-ggplot()+
    geom_sf(data=site,fill="yellow",col="black", size=0.6)+
    geom_sf(data=bound, col = "darkgrey", linetype = "dashed", size = 1.1)+ # creates US boundary line, 200 nm limit
    geom_sf(data=land,fill=c("lightgrey"), col="black", size=0.7)+
    watermark(show = TRUE, lab = "DFO Internal Use Only")+
    annotation_scale(location="bl")+
    theme_bw()+
    eval(studyBox_geom)+
    coord_sf(xlim = c(bboxBuf["xmin"], bboxBuf["xmax"]), ylim = c(bboxBuf["ymin"], bboxBuf["ymax"]),expand=FALSE)+
    labs(x="Longitude", y="Latitude", col="")+
    theme(axis.title.y = element_text(size = 13))+
    theme(axis.title.x = element_text(size = 13))

  outList=list(m,bboxBuf)

  return(outList)

}


##plots=group
##showplots
##Layer=vector
##Value=field Layer
boxplot(Layer[[Value]], col="red", main="Cajas y Bigotes")


  proportion.cc = function(odb, region, year) {
    # sex codes
    male = 0
    female = 1
    sex.unknown = 2

    out= NULL

    # Remove CW's outside norms and remove production (pre-sorted) samples
    i = which( odb$sex==male & odb$fishyr==year )  # --- fishing year is used and not the actual year caught
    r = polygon_inside(x=odb, region=aegis.polygons::polygon_internal_code(region), planar=F)

    c.r.y = unique( intersect (r, i) )

    # soft = which( odb$durometer < 68 ) # unreliable

    ccs = c(1:5)
    for (cc in ccs) {
      icc = which( odb$shell == cc )
     # if (cc==1) icc = unique( union( icc, soft ) )
     # if (cc>1)  icc = unique( setdiff( icc, soft ) )
      out = c(out, length( intersect( c.r.y, icc ) ) )
    }

    ntot = sum(out, na.rm=T)

    out = c( round(out/ntot*100,2), ntot)

    return(out)
  }