#################################################################
#################################################################
#################################################################
#' @title Find upper/lower thresholds from ROC curves
#'
#' @description Fit a smoothed ROC curve, find bounds for threshold and report partial AUC statistics
#'
#' @details
#' See Examples.
#'
#' @param ins
# @param plot.f
#' @param max.sens=0.95
# @param doPlot=FALSE
# @param trinaryPlotArgs
# @param openFig=FALSE
# @param mapOutputDir=NULL
# @param ... options to be passed to `pROC::smooth`
# @keywords
#'
# @examples
#'
#'
#' @return a data.frame
#' @author Cory Merow <cory.merow@@gmail.com>
# @note
# @seealso
# @references
# @aliases - a list of additional topic names that will be mapped to
# this documentation when the user looks them up from the command
# line.
# @family - a family name. All functions that have the same family tag will be linked in the documentation.

#' @export
trinaryROCRoots=function(ins,
 												 max.sens=0.95,
 												 smoothMethod='binormal',...){

out=try({

	aa=pROC::roc(ins[,1], ins[,2],quiet=T)
	a=try(pROC::smooth(aa,method=smoothMethod, n=1024,...),silent=TRUE)
	# i used this default because its the pROC package defualt so i assumed it was the best. if it breaks, try the next one
	if(class(a)=='try-error') {
		a=pROC::smooth(aa,method='density',...)
		message("Used method=density for ROC smoothing because your selected method (set by argument smoothMethod) broke. If you're unhappy about this, see other options for methods in ?pROC::smooth." )
	}
	xx=rev(1-a$specificities)
	xx.=.middle_pts(xx)
	xx..=.middle_pts(.middle_pts(xx))
	xx...=.middle_pts(.middle_pts(.middle_pts(xx)))

	xout=seq(0,1,length=200)
	y=rev(a$sensitivities)
	y.r= .deriv(xx, y)
	y..r <- .deriv(xx., y.r)
	y...r <- .deriv(xx.., y..r)
	y....r <- .deriv(xx..., y...r)

	#== make the derivatives real functions so they can be evaluated at the x points (e.g. for curvature)
	y.=suppressWarnings(approx(xx.,y.r,xout=xout,method='linear')$y)
	y..=approx(xx..,y..r,xout=xout,method='linear')$y
	y...=approx(xx...,y...r,xout=xout)$y
	y....=approx(.middle_pts(xx...),y....r,xout=xout)$y

	#== youden index
	youden=a$specificities+a$sensitivities-1
	best.youden=which.max(youden)
	y.youden=a$sensitivities[best.youden]
	x.youden=(1-a$specificities)[best.youden]

	#== remove NAs
	keep=complete.cases(y..r)
	y..1=y..r[keep]
	xx..1=xx..[keep]

	#== get locations of sign changes of the logmod of the second derivative
	(switches=cumsum(rle(sign(logmod(y..1)))[[1]]))
	#-- remove  nans
	switches[which(switches==length(y..1))]=NA
	switches=na.omit(switches)

		#-- since y is evaluated at the midpoint of the xs get the midpoint...
	if(length(switches)>0 & any(switches>best.youden)){
		x.as=(xx..1[switches]+xx..1[switches+1])/2
		#### x.as=xout[switches]
		x.as=x.as[which(x.as>x.youden)[1]] # this finds the midpoint, need to find the left interval

		x.ind=findInterval(x.as,xx)
		y.as=y[x.ind]

	} else {
		#-- if no asymptote reached, use max sens
		y.as=max.sens
		not.root.index=findInterval(max.sens,y)
		x.as=xx[not.root.index]
	}

	#== prep for COR (inverse ROC) to find asymptote
	y1=1-xx
	xx1=1-y
	xx1.=.middle_pts(xx1)
	xx1..=.middle_pts(.middle_pts(xx1))
	xx1...=.middle_pts(.middle_pts(.middle_pts(xx1)))
	x1out=seq(0,1,length=200)
	y1.r= .deriv(xx1, y1)
	y1..r <- .deriv(xx1., y1.r)
	y1...r <- .deriv(xx1.., y1..r)
	y1....r <- .deriv(xx1..., y1...r)
	y1.=suppressWarnings(approx(xx1.,y1.r,xout=xout)$y)
	y1..=approx(xx1..,y1..r,xout=xout)$y
	y1...=approx(xx1...,y1...r,xout=xout)$y
	y1....=approx(.middle_pts(xx1...),y1....r,xout=xout)$y
	####keep=complete.cases(y1..)
	####y1..1=y1..[keep]
	keep=complete.cases(y1..r)
	y1..1=y1..r[keep]
	(switches=cumsum(rle(sign(logmod(y1..1)))[[1]]))
	#-- remove  nans
	switches[which(switches==length(y1..1))]=NA
	switches=na.omit(switches)

		#-- since y is evaluated at the midpoint of the xs get the midpoint...
	#if(length(switches)>0 & any(switches>best.youden)){
	x.lo.inv=min((xx1..[switches]+xx1..[switches+1])/2)
	#### x.lo=max(xout[switches]) #- not sure this will generally work
	#x.lo=x.lo[which(x.lo<y.lo)[1]] # just hoping this is ok

	x.ind=findInterval(x.lo.inv,rev(xx1))
	y.lo.inv=rev(y1)[x.ind]

	#} else {
	# 		#-- if no asymptote reached, use max sens
	# commented because hopefully not an issue
	# 		y.as=max.sens
	# 		not.root.index=findInterval(max.sens,y)
	# 		x.as=xx[not.root.index]
		#}
		# plot(xx1,y1,type='l')
	# 	abline(h=y.lo)
	# 	abline(v=x.lo)
	# 	plot(x1out,y1.,type='l',log='y')
	# 	plot(x1out,y1..,type='l',log='y')

	x.lo=1-y.lo.inv
	y.lo=1-x.lo.inv

	a.pauc=try(pROC::roc(ins[,1], ins[,2],auc=T,partial.auc=1-c(x.lo,x.as), partial.auc.focus='specificity', partial.auc.correct=T,smooth=TRUE,quiet=T),silent=T)
	if(is.na(a.pauc)) a.pauc=try(pROC::roc(ins[,1], ins[,2],auc=T,partial.auc=1-c(x.lo,x.as), partial.auc.focus='specificity', partial.auc.correct=T,smooth.method='density',quiet=T),silent=T)
	if(class(a.pauc)=='try-error') a.pauc=list(auc=NA)

	#== find thresholds
	#-- smoothing the auc, which was needed for derivativies, doesn't give you thresholds associated with the prediction (it just smooths the ROC curve, and there are no underlying threshold values associated with this smooth) so i ask for the data threshold associated with the smoothed curve. It can happen that when there are few points, the same threshold is associated with different hi, youden, low estimates that came from smoothing. This  means that all the maps are the same.
	#-- cm: 9/3/21 i canned this approach and used the smoothed curves because in cases where there are big jumps between data points or AUC ~1, you don't get any differences in the estimated threoushold
	a.rough=pROC::roc(ins[,1], ins[,2],quiet=T)
	threshLo=rev(a.rough$thresholds)[findInterval(x.lo, rev(1-a.rough$specificities))]
	threshYouden=rev(a.rough$thresholds)[findInterval(x.youden, rev(1-a.rough$specificities))]
	threshHi=rev(a.rough$thresholds)[findInterval(x.as, rev(1-a.rough$specificities))]

	#== prep outputs
	out1=data.frame(lo.thresh.x=x.lo,           lo.thresh.y=y.lo,
									youden.thresh.x=x.youden,   youden.thresh.y=y.youden,
									hi.thresh.x=x.as,           hi.thresh.y=y.as,
									y.lo.inv=y.lo.inv,          x.lo.inv=x.lo.inv,
									trinary.pauc=as.numeric(a.pauc$auc))
	plotThings=list(xx=xx,y=y,y.=y.,y..=y..,xx1=xx1,y1=y1,x1out=x1out,y1..=y1.., a.pauc=a.pauc,xout=xout,x1out=x1out,threshLo=threshLo,threshHi=threshHi,threshYouden=threshYouden)

	list(out1=out1,plotThings=plotThings)

	})
	return(out)
}

#################################################################
#################################################################
#################################################################
#' @title Make trinary maps
#'
#' @description Use previously calculated thresholds to make trinary maps
#'
#' @details
#' See Examples.
#'
# #' @param mod.out
# #' @param stats
# #' @param proj.env
# #' @param name
# @keywords
#'
# @examples
#'
#'
#' @return a data.frame
#' @author Cory Merow <cory.merow@@gmail.com>
# @note
# @seealso
# @references
# @aliases - a list of additional topic names that will be mapped to
# this documentation when the user looks them up from the command
# line.
# @family - a family name. All functions that have the same family tag will be linked in the documentation.

#' @export

# stats to grab model paths (could move that outside as an input arf
# inputPaths=stats[!is.na(stats$meanModelPath),] (could use modelPath already)
# dirs to get species name and define output directory
# outputPaths=paste0(
# !!!!!! shoulds split this into making the map and plotting it.

# should add the option to use a map in memory
trinaryMap=function(model,
										threshLo,
										threshHi,
										threshYouden,
										modelNames,
										species,
										rasterOutputDir=NULL,
										...
										){

	out=try({

	 #== set up inputs for workflow use or independent use
	# 	 if(is.null(modelPath)){
	# 	 	 species=basename(dirs$sp.pred.path)
	# 	 	 stats=stats[!is.na(stats$meanModelPath),]
	# 	 	 preds.r=cmsdm::unrtrans(raster::stack(stats$meanModelPath))
	# 	 	 modelName=stats$modelName[x]
	# 	 } else {
	# 	 	 species=basename(dirname(modelPath))
	# 	 	 preds.r=cmsdm::unrtrans(raster::raster(modelPath))
	# 	 	 modelName=tools::file_path_sans_ext(basename(modelPath))
	# 	 }
	preds.r=model
	#== make trinary maps
	trinary.rasters=stack(lapply(1:nlayers(preds.r),
												function(x) {
													#stack(lapply(1:ncol(thresh[x,]),
													 #function(y) {
													 out1=preds.r[[x]]>threshLo
													 out2=preds.r[[x]]>threshHi
													 out3=out1+out2
													 names(out3)=paste0(modelNames[x],'_', round(threshLo,2),'_',round(threshHi,2))
													 out3
											}))#}))

	 #plot(hist(log(values(preds.r))))
	 #abline(v=log(threshLo)); abline(v=log(threshHi))

		# just make this to get the range size
  youden.binary.tmp.raster=preds.r>threshYouden

	 #== write results
	if(!is.null(rasterOutputDir)){
		 lapply(1:nlayers(trinary.rasters),function(x){
			 if(is.null(rasterOutputDir)){
			 	trinaryDirSp=paste0(dirs$trinaryDir,'/',species)
			 	if(!file.exists(trinaryDirSp)) dir.create(trinaryDirSp)
			 	trinaryModel=paste0(trinaryDirSp,'/', names(trinary.rasters)[x] ,".tif")
			 } else {
			 		trinaryModel=paste0(rasterOutputDir,'/',species,'_', names(trinary.rasters)[x] ,".tif")
			 }

			 rf <- suppressWarnings(writeRaster(trinary.rasters[[x]],
												 filename=trinaryModel, ...))
		 })
	  } # end if is.null(rasterF)

	  return(trinary.rasters)
	})
	return(out)
}

#################################################################
#################################################################
#################################################################
#' @title Calculate upper and lower limits of range size
#'
#' @description Size limits based on trinary thresholds
#'
#' @details
#' See Examples.
#'
#' @param trinary.rasters,
#' @param youden.binary.tmp.raster
# @keywords
#'
# @examples
#'
#'
#' @return a data.frame with the lower, upper, and optimal (Youden threshold) range size
#' @author Cory Merow <cory.merow@@gmail.com>
# @note
# @seealso
# @references
# @aliases - a list of additional topic names that will be mapped to
# this documentation when the user looks them up from the command
# line.
# @family - a family name. All functions that have the same family tag will be linked in the documentation.

#' @export
trinaryRangeSize=function(trinary.rasters,
                          youden.binary.tmp.raster=NULL){

  cell.size=prod(res(trinary.rasters)/1e3)
	if(!is.null(youden.binary.tmp.raster)){ range.size.youden.km2=sum(values(youden.binary.tmp.raster)>0,na.rm=T)
	} else {
		range.size.youden.km2=NA
	}

	range.size= cell.size * data.frame(
				range.size.lo.km2=sum(values( trinary.rasters)>1,na.rm=T),
	 			range.size.hi.km2=sum(values( trinary.rasters)>0,na.rm=T),
	 			range.size.youden.km2=range.size.youden.km2)

	range.size
}


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

ImputeNas <- function(training.set,test.set=NULL) {
	# Imputes NAs in a training set or test set of features
	#
	# Args:
	#	training.set: dataset with training features
	#	test set: dataset with test features; if NULL, will impute NAs for the
	#	training set
	#
	# Returns:
	#	A dataset with NAs filled in
	#
	# Example usage:
	# 	train.data[,1]<-ImputeNas(train.data[,-1])

	#Compute column medians
	col.names<-colnames(training.set)
	medians<-apply(training.set,2,median,na.rm=TRUE)

	# Replace NAs with column medians in training set if test set is NULL
	if (is.null(test.set)) {
		training.set<-sapply(1:ncol(training.set),ColReplace,training.set,medians)
		colnames(training.set)<-col.names
		# Keep only columns that have no NAs
		na.col<-apply(training.set,2,function(x) {any(is.na(x))})
		training.set<-training.set[,!na.col]
		return(training.set)
	}

	# Otherwise replace NAs with training set column medians in test set
	else {
		nrows <- nrow(test.set)
		ncols <- ncol(test.set)
		# Reshape test set into data frame of the correct dimension after replacing NAs
		test.set<-data.frame(matrix(sapply(1:ncol(test.set),ColReplace,test.set,medians),nrow=nrows,ncol=ncols))
		colnames(test.set)<-col.names
		# Keep only columns that have no NAs
		na.col<-apply(test.set,2,function(x) {any(is.na(x))})
		test.set<-test.set[,!na.col]
		return(test.set)
	}

}

# Replace NA function to be used in apply functions
ColReplace <- function(i,data,medians) {
	data[,i][is.na(data[,i])]<-medians[i]
	return(data[,i])
}


vetor <- (c(1,2,3,4,5,6,7,8,9,10,11,12))
vetor

matriz1 <- matrix(c(1:16), nrow = 4, ncol = 4)
mat

lista1  <- list(vetor, matriz1)
lista1

df <- data.frame(read.table("http://data.princeton.edu/wws509/datasets/effort.dat"))
df

names(df) = c("config", "esfc","chang")
df

iris

class(iris)

dim(iris)

summary(iris)

str(iris)

plot(iris$Sepal.Length, iris$Sepal.Width)

help(subset)

iris1 <- subset(iris, Sepal.Length > 7)
iris1

install.packages("dplyr")
library("dplyr")

?slice

iris2 <- slice(iris, 1:15)
iris2

RSiteSearch("filter")

iris3 <- filter(iris2, Sepal.Length > 6)
iris3


################################################################################
# library(glmnet)

RegressPredictionsTrain<- function(train.name="train",method.list,num.cv=10) {

	# Calculates ridge regression weights based on the cv prediction files made
	#	by other methods, ie, regresses cv test predictions on the truth
	#	(Note: GetPredictionData function is in the average_predictions file)
	#
	# Args:
	#	train.name: base name of training data from which splits are created
	# 	method.list: a list, where each element is a list of method args used for
	#   	each prediction to be averaged and the name of each element is the  method
	#
	# Returns:
	#	  A ridge regression model
	#
	# Example usage:
	if(FALSE) {
		features <- c("static","alsfrs","fvc","svc","vital")
		slope.features <- NULL
		glm.args <- list(R=1,pls=FALSE,prune=FALSE,std=FALSE,features=features,slope.features=slope.features)
		rf.args <- c(corr.bias=FALSE, glm.args)
		gbm.args <- glm.args
		bag.args <- glm.args
		glm.prune.args <- glm.args; glm.prune.args$prune = TRUE
		rf.prune.args <- rf.args; rf.prune.args$prune = TRUE
		gbm.prune.args <- glm.prune.args
		bag.prune.args <- glm.prune.args

		method.list<-list(
			"RandomForestTrain"=rf.prune.args,
			"GlmnetTrain"=glm.prune.args,
			"GbmTrain"=gbm.prune.args,
			"BaggingTrain"=bag.prune.args,
			"RandomForestTrain"=rf.args,
			"GlmnetTrain"=glm.args,
			"GbmTrain"=gbm.args,
			"BaggingTrain"=bag.args
		)

		model<-RegressPredictionsTrain("train", method.list)
		predictions<-model("test")
	}
	#######################################################################

	# Get vector of train names corresponding to cv splits
	train.names<-paste(train.name,"-cvtrain_",1:num.cv,"of",num.cv,sep="")

	# Get vector of test names corresponding to cv splits
	test.names<-paste(train.name,"-cvtest_",1:num.cv,"of",num.cv,sep="")

	# Function that gets prediction data from each set of arguments for one cv split
	GetCvPredictions<-function(train.name.cv,test.name.cv,method.list) {
		return(sapply(names(method.list),GetPredictionData,train.name.cv,
			test.name.cv,method.list))
	}
    # Get prediction data for all cv splits
    train.preds<-mapply(GetCvPredictions,train.names,test.names,list(method.list))

    # Stack prediction data
    train.preds<-do.call(rbind,train.preds)

    # Get subject ids in same order
    subject.ids<-do.call(rbind,lapply(test.names,GetSubjectIds))

    # Put together prediction data with subject ids
    train.preds<-cbind(subject.ids,train.preds)

    # Sort by subject id
    train.preds<-train.preds[order(train.preds$subject.id),]

    # Convert to numeric matrix
	train.preds <- as.matrix(train.preds)
	mode(train.preds) <- "numeric"

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

    # Ridge regression
    cv.res <- cv.glmnet(as.matrix(train.preds[,-1]), target, alpha=0, nfolds=nrow(train.preds))

    print(paste("Internal CV error:",sqrt(min(cv.res$cvm))))
    train.err <- Rmsd(target, predict(cv.res$glmnet.fit,as.matrix(train.preds[,-1]),s=cv.res$lambda.min))
    print(paste("Error on our CV splits:",train.err))
    print(coef(cv.res))
    print(paste("lambda:",cv.res$lambda.min))

	RegressPredictionsPredict<- function(test.name="test",save.preds=TRUE) {
		#	Makes predictions based on a ridge regression on predictions from
		#	other methods
		#
		# Args:
		#	test.name: base name of test data
		# 	save.preds: saves to file if TRUE
		#
		# Returns:
		#	 A matrix of subject ids and corresponding predictions
		#
		# Side effects:
		# 	Writes to a file in the predictions folder

		# Get test prediction data
		test.preds<-sapply(names(method.list),GetPredictionData,train.name,
			test.name,method.list)

    	# Convert to numeric matrix
    	test.preds <- as.matrix(test.preds)
		mode(test.preds) <- "numeric"

       	# Make test predictions
       	predictions<-predict(cv.res$glmnet.fit,test.preds,s=cv.res$lambda.min)

		# Get subject ids for test set
		subject.ids<-GetSubjectIds(test.name)

		predictions <- cbind(subject.ids,predictions)

		if(save.preds) {
			# Write predictions to file
			out.file = GetPredictionFilename("RegressPredictionTrain",train.name,test.name,method.list)
			WritePredictions(predictions, out.file)
		}

		return(predictions)
	}

	return(RegressPredictionsPredict)
}


#Libraries
require(ggplot2)
library(BayesTwin)
library(cowplot)

#Functions
plotHistogram <- function(df, x, y) {
  #Calculate
  hiNum <- round(colSums((x-y) > 0)/nrow(x-y),2)
  loNum <- round(colSums((x-y) < 0)/nrow(x-y),2)
  textPercent <- paste(loNum, "% < 0 < ", hiNum, "%", sep="")
  textXAxis <- expression(paste(mu,"Rate1 - ",mu,"Rate2", sep=""))
  df["muDiff"] = x - y
  hpdLimits <- HPD(x-y)

  #Plot
  ggplot(df, aes(x=muDiff)) +
    geom_histogram(bins=50, colour="black", fill="white", alpha=0.6) +                        # Histrogram
    geom_vline(aes(xintercept=mean(x=muDiff)), color="red", linetype="dashed", size=1) +      # Mean lines
    geom_vline(aes(xintercept=0), color="black", linetype="solid", size=2) +                  # Zero line
    geom_vline(aes(xintercept=hpdLimits[1]), color="blue", linetype="dashed", size=1) +       # Low HPD
    geom_vline(aes(xintercept=hpdLimits[2]), color="blue", linetype="dashed", size=1) +       # High HPD
    annotate(geom="text", x=mean(x-y), y=Inf, label=textPercent, color="red", fontface="bold", vjust=1, hjust=0.5) +
    annotate(geom="text", x=hpdLimits[1], y=0, label=hpdLimits[1], color="blue", fontface="bold", vjust=0, hjust=0) +
    annotate(geom="text", x=hpdLimits[2], y=0, label=hpdLimits[2], color="blue", fontface="bold", vjust=0, hjust=1) +
    scale_x_continuous(name =textXAxis)
}

#Load in data
subset1 <- read.csv("results/subset1.log.txt", skip = 3, header = T, sep="\t")
subset4 <- read.csv("results/subset4.log.txt", skip = 3, header = T, sep="\t")
subset5 <- read.csv("results/subset5.log.txt", skip = 3, header = T, sep="\t")
subset6 <- read.csv("results/subset6.log.txt", skip = 3, header = T, sep="\t")
subset7 <- read.csv("results/subset7.log.txt", skip = 3, header = T, sep="\t")
subset8 <- read.csv("results/subset8.log.txt", skip = 3, header = T, sep="\t")
subset9 <- read.csv("results/subset9.log.txt", skip = 3, header = T, sep="\t")

#Burn-in 10% of data
subset1 <- subset1[-c(1:101),]
subset4 <- subset4[-c(1:101),]
subset5 <- subset5[-c(1:101),]
subset6 <- subset6[-c(1:101),]
subset7 <- subset7[-c(1:101),]
subset8 <- subset8[-c(1:101),]
subset9 <- subset9[-c(1:101),]

#Bayesian estimation suspersedes t-test
x <- as.matrix(subset1["civf.meanRate"])
y <- as.matrix(subset1["d1b.meanRate"])
(plot1 <- plotHistogram(subset1,x,y))

x <- as.matrix(subset4["X2010.1.aln.meanRate"])
y <- as.matrix(subset4["delta1b.aln.meanRate"])
(plot4 <- plotHistogram(subset4,x,y))

x <- as.matrix(subset5["alpha.aln.meanRate"])
y <- as.matrix(subset5["cluster_ivb.aln.meanRate"])
(plot5 <- plotHistogram(subset5,x,y))

x <- as.matrix(subset6["X2010.1.aln.meanRate"])
y <- as.matrix(subset6["alpha.aln.meanRate"])
(plot6 <- plotHistogram(subset6,x,y))

x <- as.matrix(subset7["civa.aln.meanRate"])
y <- as.matrix(subset7["civb.aln.meanRate"])
(plot7 <- plotHistogram(subset7,x,y))

x <- as.matrix(subset8["civa.aln.meanRate"])
y <- as.matrix(subset8["delta1a.aln.meanRate"])
(plot8 <- plotHistogram(subset8,x,y))

x <- as.matrix(subset9["X2010.1.aln.meanRate"])
y <- as.matrix(subset9["delta1a.aln.meanRate"])
(plot9 <- plotHistogram(subset9,x,y))

#Pretty plot
tiff('test.tiff', units="in", width=13.5, height=9, res=300, compression = 'lzw')

plot_grid(plot1, plot4, plot5, plot6, plot7, plot8, plot9,
          labels = c("A", "B", "C", "D", "E", "F", "G"),
          ncol = 3, nrow = 3)
dev.off()

###Frequentist analysis, ignore
#Kolmogorov-Smirnov test
x <- as.matrix(subset1["civf.meanRate"])
y <- as.matrix(subset1["d1b.meanRate"])
ks.test(x,y)
t.test(x,y)
wilcox.test(x,y)
kruskal.test(list(x,y))
chisq.test(x,y)

x <- as.matrix(subset4["X2010.1.aln.meanRate"])
y <- as.matrix(subset4["delta1b.aln.meanRate"])
hist(x)
hist(y)
hist(x-y)
ks.test(x,y)
t.test(x,y)
wilcox.test(x,y)
kruskal.test(list(x,y))
chisq.test(x,y)

x <- as.matrix(subset5["alpha.aln.meanRate"])
y <- as.matrix(subset5["cluster_ivb.aln.meanRate"])
ks.test(x,y)
t.test(x,y)
wilcox.test(x,y)
kruskal.test(list(x,y))
chisq.test(x,y)

x <- as.matrix(subset6["X2010.1.aln.meanRate"])
y <- as.matrix(subset6["alpha.aln.meanRate"])
ks.test(x,y)
t.test(x,y)
wilcox.test(x,y)
kruskal.test(list(x,y))
chisq.test(x,y)

x <- as.matrix(subset7["civa.aln.meanRate"])
y <- as.matrix(subset7["civb.aln.meanRate"])
ks.test(x,y)
t.test(x,y)
wilcox.test(x,y)
kruskal.test(list(x,y))
chisq.test(x,y)

x <- as.matrix(subset8["civa.aln.meanRate"])
y <- as.matrix(subset8["delta1a.aln.meanRate"])
ks.test(x,y)
t.test(x,y)
wilcox.test(x,y)
kruskal.test(list(x,y))
chisq.test(x,y)

x <- as.matrix(subset9["X2010.1.aln.meanRate"])
y <- as.matrix(subset9["delta1a.aln.meanRate"])
ks.test(x,y)
t.test(x,y)
wilcox.test(x,y)
kruskal.test(list(x,y))
chisq.test(x,y)

# https://rpubs.com/mharris/KSplot
# simulate two distributions - your data goes here!
group <- c(rep("sample1", length(x)), rep("sample2", length(y)))
dat <- data.frame(KSD = c(x,y), group = group)
# create ECDF of data
cdf1 <- ecdf(x)
cdf2 <- ecdf(y)
# find min and max statistics to draw line between points of greatest distance
minMax <- seq(min(x, y), max(x, y), length.out=length(x))
x0 <- minMax[which( abs(cdf1(minMax) - cdf2(minMax)) == max(abs(cdf1(minMax) - cdf2(minMax))) )]
y0 <- cdf1(x0)
y1 <- cdf2(x0)

ggplot(dat, aes(x = KSD, group = group, color = group))+
  stat_ecdf(size=1) +
  theme_bw(base_size = 28) +
  theme(legend.position ="top") +
  xlab("Sample") +
  ylab("ECDF") +
  #geom_line(size=1) +
  geom_segment(aes(x = x0[1], y = y0[1], xend = x0[1], yend = y1[1]),
               linetype = "dashed", color = "red") +
  geom_point(aes(x = x0[1] , y= y0[1]), color="red", size=8) +
  geom_point(aes(x = x0[1] , y= y1[1]), color="red", size=8) +
  ggtitle("K-S Test: Sample 1 / Sample 2") +
  theme(legend.title=element_blank())

#hiNum <- round(colSums((x-y) > 0)/nrow(x-y),2)
#loNum <- round(colSums((x-y) < 0)/nrow(x-y),2)
#textPercent <- paste(loNum, "% < 0 < ", hiNum, "%", sep="")
#textXAxis <- expression(paste(mu,"Rate1 - ",mu,"Rate2", sep=""))
#subset4["muDiff"] = x - y
#hpdLimits <- HPD(x-y)
#ggplot(subset4, aes(x=muDiff)) +
#  geom_histogram(bins=50, colour="black", fill="white", alpha=0.6) +                        # Histrogram
#  geom_vline(aes(xintercept=mean(x=muDiff)), color="red", linetype="dashed", size=1) +      # Mean lines
#  geom_vline(aes(xintercept=0), color="black", linetype="solid", size=2) +                  # Zero line
#  geom_vline(aes(xintercept=hpdLimits[1]), color="blue", linetype="dashed", size=1) +       # Low HPD
#  geom_vline(aes(xintercept=hpdLimits[2]), color="blue", linetype="dashed", size=1) +       # High HPD
#  annotate(geom="text", x=mean(x-y), y=Inf, label=textPercent, color="red", fontface="bold", vjust=1, hjust=0.5) +
#  annotate(geom="text", x=hpdLimits[1], y=0, label=hpdLimits[1], color="blue", fontface="bold", vjust=0, hjust=0) +
#  annotate(geom="text", x=hpdLimits[2], y=0, label=hpdLimits[2], color="blue", fontface="bold", vjust=0, hjust=1) +
#  scale_x_continuous(name =textXAxis)


rm(list=ls(all=TRUE)); graphics.off();

library(maptools)
library(sp)
library(rgeos)

sppList<-c("BOGR","HECO","PASM","POSE")

zzz<-1
# This script uses RGEOS functions to calculate the area of
# neighboring species within annuli of each focal genet in
# the genet_xy input file

focalSppName<-sppList[zzz]
focalSpp<-paste0("h:/montanachart/ipm/speciesData/",focalSppName,"/edited/",focalSppName,"_genet_xy_edited.csv")
sppShapes <- c("h:/montanachart/lifetables/polys/Species/BOGR-edited/Bouteloua gracilis/",
               "h:/montanachart/lifetables/polys/Species/Hesperostipa comata/",
               "h:/montanachart/lifetables/polys/Species/Pascopyrum smithii/",
                "h:/montanachart/lifetables/polys/Species/Poa secunda/")
nbSpp <- c("BOGR","HECO","PASM","POSE")  # make sure these are listed in same order as sppShapes
annuli <- c(seq(2,20,2),seq(25,50,5),seq(60,150,10))
outfile <- paste0("h:/montanachart/ipm/speciesData/",focalSppName,"/",focalSppName,"_nbhood_rings.csv")

# DEFINE FUNCTIONS -----------------------------------------------------

makeDiscs <- function(x,y,annuli){
  centroid<-readWKT(paste("POINT(",x," ",y,")",sep=""))
  n <- length(annuli)
  output <- list(n)
  for(ii in 1:n){
    output[[ii]] <-gBuffer(centroid,width=annuli[ii],quadsegs=50)
  }
  return(output)
}

ringXquad <- function(discList){
  output <- numeric(length(discList))
  qpoly <- readWKT("POLYGON((0 0,100 0,100 100,0 100,0 0))")
  for(ii in 1:length(discList)){
    output[ii]<-gArea(gIntersection(qpoly,discList[[ii]]))/gArea(discList[[ii]])
  }
  return(output)
}

# LOOPS ----------------------------------------------------

Nrings <- length(annuli)

# set up data frame for output
template1 <- data.frame(species=character(0),quad=character(0),year=numeric(0),
                        genetID=numeric(0),stringsAsFactors=F)
template2 <- as.data.frame(matrix(0,0,(length(nbSpp)+1)*Nrings))
names(template2) <- paste(c(sort(rep(nbSpp,Nrings)),rep("propQ",Nrings)),c(0,annuli[1:(length(annuli)-1)]),annuli,sep=".")
outD <-cbind(template1,template2)

# import focal genets
focalD <- read.csv(focalSpp)

# list unique quad x year combinations
quadyear <- unique(focalD[,c("quad","year")],MARGIN=2)

# loop through quads and years
for(i in 1:NROW(quadyear)){
  doQuad=quadyear$quad[i] ; doYear=quadyear$year[i]
  tmpD <- subset(focalD,  quad==doQuad & year==doYear)

  # import shapefiles
  polys <- list(length(nbSpp))
  for(j in 1:length(sppShapes)){
      tmpDir<-paste(sppShapes[j],doQuad,"/",sep="" )
    tmpfile<-paste(doQuad,"_",doYear,".shp",sep="" )
    if(sum(is.element(list.files(tmpDir),tmpfile))==1){
      polys[[j]]<-readShapePoly(paste(tmpDir,tmpfile,sep=""))
    }else{
      polys[[j]]<-0
    }
  } # next j

  #kk<-if(i==1){1}else{1}
# loop through focal genets
  for(k in 1:NROW(tmpD)){

    ID <- tmpD$trackID[k]; x <- tmpD$x[k] ; y <- tmpD$y[k] ;

    print(list(i=paste(i,"out of", NROW(quadyear), sep=" "),k=paste(k, "out of", NROW(tmpD), sep=" "),
               doQuad=doQuad, doYear=doYear, ID=ID, x=x, y=y))

    # format output
    tout1 <- template1
    tout1[1,1:2] <- c(focalSppName,as.character(doQuad)); tout1[1,3:4] <- c(doYear,ID)
    tout2 <- template2; tout2[1,]<-0

    # make circles
    discList <- makeDiscs(x,y,annuli)

    # calculate proportion of each ring inside the quadrat
    propRing <- ringXquad(discList)

    # get areas
    nbarea <- numeric(Nrings)
    for(j in 1:length(sppShapes)){
      if(is.numeric(polys[[j]])==F){
        for(m in 1:Nrings){
           A <-gIntersection(discList[[m]],polys[[j]])
           if(!is.null(A)){
             nbarea[m] <- gArea(A) # calculate area only if A is not NULL
           }else{
             nbarea[m] <- 0
           }
        } # next m
        if(nbSpp[j]==focalSppName){
          nbarea <- nbarea - tmpD$area[k] # subtract focal genet
          nbarea[nbarea<0] <- 0  # fix rounding error
        }  # end if
        nbarea <- nbarea-c(0,nbarea[1:(Nrings-1)]) # calculate ring-specific areas
        tout2[1,(1+(j-1)*Nrings):(Nrings+(j-1)*Nrings)] <- nbarea
      } # end if polys null
    } # next j

    tout2[1,(NCOL(tout2)-Nrings+1):NCOL(tout2)] <- propRing
    tout1 <- data.frame(tout1,tout2)
    #outD <- rbind(outD,tout1)

    if (i==1 & k==1){write.table(tout1,file=as.character(outfile),row.names=FALSE, col.names=TRUE, sep=",")}else{
      write.table(tout1,file=as.character(outfile),
                  col.names=FALSE,row.names=FALSE, sep=",", append=TRUE)}
  } # next k

  print(paste(i,"of",NROW(quadyear),"quad years complete",sep=" "))
  #flush.console()

} # next i

#write.csv(outD,outfile,row.names=FALSE)


rm(list=ls())
setwd("~/Dropbox (Penn)/Greek Targeted Testing (Kimon-Vishal)/CounterFactualAnalysis/")

dat <- read.csv("grey_eb_preds.csv")
dat$X <- NULL
dat$date <- as.Date(dat$date, format = "%Y-%m-%d")

dat2 <- read.csv("grey_arrivs.csv")
dat2$X <- NULL
dat2$date <- as.Date(dat2$date, format = "%Y-%m-%d")

grey_list_se <- read.csv("https://raw.githubusercontent.com/ovelixasterix/greek_project/master/grey_list_start_end.csv")
grey_list_se$start_date <- as.Date(grey_list_se$start_date, format = "%Y-%m-%d")

lag = 9 # alter if desired

for(i in 1:nrow(grey_list_se)){
  # irrelevant dates
  ind <- which(dat$country == grey_list_se$country[i] & (dat$date <= grey_list_se$start_date[i]
               | dat$date > (grey_list_se$start_date[i] + lag)))
  dat <- dat[-ind,]
  ind <- which(dat2$country == grey_list_se$country[i] & (dat2$date <= grey_list_se$start_date[i]
                                                         | dat2$date > (grey_list_se$start_date[i] + lag)))
  dat2 <- dat2[-ind,]
}

# merge
df <- merge(dat[c("country", "date", "pred_prev", "sd_prev")],
            dat2[c("country", "date", "pred_arr", "sd_arr")],
            by = c("country", "date"))
df$peak = as.integer(df$date < as.Date("2020-10-01"))
ind <- which(df$peak == 1)

# numerically simulate sum, drawing arr and eb predictions from independent normals
B = 1000000
res = matrix(0, nrow = nrow(df), ncol = B)
for(i in 1:nrow(df)){
  res[i,] = rnorm(B, mean = df[i,"pred_prev"], sd = df[i,"sd_prev"]) * rnorm(B, mean = df[i,"pred_arr"], sd = df[i,"sd_arr"])
}

# peak
res2 <- colSums(res[ind,])
sd(res2)

# off-peak
res2 <- colSums(res[-ind,])
sd(res2)


# Saharan Dust Transport Research
# 2016-05-04 Ismail SEZEN
# sezenismail@gmail.com

source("code/filehelper.r")

corstat <- function(x, dim = NULL) {
  csb <- function(x, func = max) {
    dn <- dimnames(x)
    as_char <- function(i) {
      if (is.vector(i)) i <- matrix(i, ncol = 1)
      ret <- sapply(1:ncol(i), function(j) dn[[j]][i[,j]])
      if (is.vector(ret)) ret <- matrix(ret, ncol = length(ret), byrow = T)
      return(ret)
    }
    fn <- as.character(substitute(func))
    fres <- func(x)
    i <-  which(x == fres, arr.ind = T); rownames(i) <- NULL
    ichar <- as_char(i); colnames(ichar) <- paste0('v', colnames(i))
    colnames(i) <- paste0('i', colnames(i))
    df <- data.frame(fres, i, ichar, check.names = F)
    colnames(df)[1] <- fn
    return(df)
  }

  cs <- function(x) {
    mx <- csb(x, max)
    mn <- csb(x, min)
    colnames(mx)[1] <- colnames(mn)[1] <- "max_min"
    df <- rbind(mx, mn)
    return(df)
  }

  if (is.null(dim)) {
    return(cs(x))
  } else {
    l <- list()
    for (i in dimnames(x)[[dim]])
      l[[i]] <- cs(rwind:::index_array(x, dim, i))
    return(l)
  }
}

corstat_from_files <- function(pattern = NULL) {
  dir_data_cor <- "data/cor"
  files <- list.files(dir_data_cor, full.names = T)
  for (p in pattern) files <- Filter(function(x) grepl(p, x), files)
  for (f in files) {
    bf <- basename(f)
    if (tools::file_ext(bf) == "rds") {
      tryCatch({
        data <- readRDS(f)
        longname <- attr(data, "longname")
        if (is.null(longname)) longname <- bf
        if (grepl("log", bf)) longname <- paste0(longname, " (log)")
        cat(longname, ":\n")
        print(corstat(data))
        cat("\n")
      }, error = function(e) {
        cat(bf, "cannot be read.\n")
      }, finally = {
        next
      })
    }
  }
}

get_data_by_cor <- function(fun=max) {
  dir_data_cor <- "data/cor"
  files <- list.files(dir_data_cor, full.names = T)
  files <- Filter(function(x) grepl("daily", x), files)
  ret <- NULL
  for (f in files) {
    bf <- basename(f)
    if (tools::file_ext(bf) == "rds") {
      tryCatch({
        xc <- readRDS(f)
        longname <- attr(xc, "longname")
        varname <- attr(xc, "name")
        if (is.null(longname)) longname <- bf
        if (grepl("log", bf)) longname <- paste0(longname, " (log)")
        cat(longname, ":\n")
        df <- corstat(xc)
        imx <- which(df[,1] == fun(df[,1]), arr.ind = T)[1]
        df <- df[imx,]
        x <- readRDS(attr(xc, "filename"))
        if (grepl("uv", bf)) {
          x <- rwind::rotax(x, alfa = as.numeric(as.character(df$valfa[1])))
          if (grepl("pres", bf)) {
            x <- x[df$ilon[1], df$ilat[1], df$ilevel[1],,df$icomponent[1]]
          } else if (grepl("surf", bf)) {
            x <- x[df$ilon[1], df$ilat[1],,df$icomponent[1]]
          }
        } else if (grepl("hgt", bf)) {
          x <- x[df$ilon[1], df$ilat[1], df$ilevel[1],]
        } else if (grepl("mslp", bf)) {
          x <- x[df$ilon[1], df$ilat[1],] / 100
        } else if (grepl("omega", bf)) {
          x <- x[df$ilon[1], df$ilat[1], df$ilevel[1],]
        }
        cname <- if  (grepl("log", bf)) paste0("log_", varname) else varname
        if (grepl("uv", bf)) {
          if (grepl("surf", bf)) {
            cname <- paste0(cname, "_surf")
          }
        }
        if (is.null(ret)) {
          ret = matrix(x, ncol = 1)
          colnames(ret)[1] <- cname
          rownames(ret) <- names(x)
        } else {
          ret <- cbind(ret, x)
          colnames(ret)[ncol(ret)] <-  cname
        }

      }, error = function(e) {
        print(e)
      }, finally = {
        next
      })
    }
  }
  return(ret)
}

save_data_by_cor <- function(fun = max, file = "out.csv") {
  data <- get_data_by_cor(fun)
  save_csv(data, file)
}

cor2 <- function(x, pm, alfa = seq(0, 360, 20), par = T) {
  calc <- function(uv) {
    r <- if (is.null(dim(uv))) matrix(uv, ncol = 1) else uv
    rot <- function(a) rotax(uv, alfa = a)
    cor2 <- function(x1) apply(pm, 2, cor, y = x1, use = "pairwise.complete.obs")
    if (ncol(r) == 2) {
      r <- vapply(alfa, rot, outer(1:dim(r)[1], 1:dim(r)[2]))
      ret <- apply(r, 2:3, cor2)
      dimnames(ret)[[3]] <- alfa
    } else {
      ret <- apply(r, 2, cor2)
    }
    return(ret)
  }

  if (is.null(dim(pm))) pm <- matrix(pm, ncol = 1)
  dims <- (1:length(dim(x)))
  comp_loc <- which(dim(x) == 2) # find uv dim
  if (length(comp_loc) > 0) {
    dims <- dims[-comp_loc]
    dim_comp <- dim(x)[comp_loc]
    dim_comp_names <- dimnames(x)[[comp_loc]]
    dim_alfa <- length(alfa)
  } else {
    alfa = 0
    dim_comp <- 1
    dim_comp_names <- "X"
    dim_alfa <- 1
  }
  time_loc <- which(dim(x) == nrow(pm)) # find time dim
  if (length(time_loc) == 0)
    stop("x does not have a dim suitable with pm")
  dims <- dims[-time_loc]
  if (require(rwind)) {
    if (require(parallel) && par) {
      cl <- parallel::makeCluster(getOption("cl.cores", detectCores() / 2))
      parallel::clusterExport(cl, c("pm", "alfa"), envir = environment())
      parallel::clusterEvalQ(cl, library(rwind))
      r <- parallel::parApply(cl, x, dims, calc)
      parallel::stopCluster(cl)
    } else {
      r <- apply(x, dims, calc)
    }
  } else {
    stop("Install rwind package")
  }
  r <- array(r, dim = c(ncol(pm), dim_comp,
                        dim_alfa, dim(x)[dims]))
  names(dim(r)) <- c("pm",
                     "component",
                     "alfa",
                     names(dim(x)[dims]))
  dimnames(r) <- append(list(pm = colnames(pm),
                             component = dim_comp_names,
                             alfa = alfa), dimnames(x)[dims])
  dim_order <- 1:length(dim(r))
  first <- match(dim(x)[dims], dim(r))
  remain <- dim_order[-first]
  r <- aperm(r, c(first, remain))

  # copy attributes
  attrs <- names(attributes(x))
  attrs <- attrs[!(attrs %in% c("dim", "dimnames"))]
  for (a in attrs) attr(r, a) <- attr(x, a)

  return(drop(r))
}


# Preparing the Dataset

# Loading the dataset loans.csv into a data frame called loans:
loans = read.csv('loans.csv')
# exploring it using the str() and summary() functions:
str(loans)
summary(loans)

# Looking for NAs
# We could see in the summary that the following variables have missing values: "log.annual.inc", "days.with.cr.line", "revol.util", "inq.last.6mths", "delinq.2yrs", "pub.rec".

# building a dataset with the missing values:
missing = subset(loans, is.na(log.annual.inc) | is.na(days.with.cr.line) | is.na(revol.util) | is.na(inq.last.6mths) | is.na(delinq.2yrs) | is.na(pub.rec))
str(missing)

# We can see that only 62 obs. have missing values, considering that we have 9578 obs.
# Removing this small number of observations would not lead to overfitting.

#omitting the NAs values:
library(dplyr)
loans = na.omit(loans)

# Splitting the data into train and test

# We are now splitting the dataset into training data and testing data, using a proportion of
# 70% of the data for the training set and 30% for the testing set. We are setting the random seed
# to 144.

library(caTools) #loading the package.
set.seed(144) #setting the random seed.
#splitting the data using the sample.split function:
split=sample.split(loans$not.fully.paid, SplitRatio = 0.7)
train = subset(loans, split == TRUE)
test = subset(loans, split == FALSE)

# Building the model
# Now we are going to build the model using the training set.

model = glm(not.fully.paid~., data = train, family=binomial)
summary(model)

# Adjusting the model
# Now that we have our model, we must take the irrelevant variables out looking at its p-values.

model = glm(not.fully.paid~.-dti, data = train, family=binomial)
model = glm(not.fully.paid~.-dti -int.rate, data = train, family=binomial)
model = glm(not.fully.paid~.-dti -int.rate -delinq.2yrs, data = train, family=binomial)
model = glm(not.fully.paid~.-dti -int.rate -delinq.2yrs -days.with.cr.line, data = train, family=binomial)
summary(model)

# Making predictions
# Now we are realizing the predictions based on our model.

# predictions on the test set.
predicted.risk = predict(model, newdata=test, type='response')
# saving our predictions as a new column in the test set.
test$predicted.risk = predicted.risk

# Calculating the accuracy of the model
# We can calculate the accuracy of the model by comparing the percentage of right predictions that we made.

# creating a matrix where we can see how many observations we get right using a threshold of 0.5.
confmatrix = table(test$not.fully.paid, predicted.risk>0.5)
confmatrix

# Now that we have our matrix, we can see how much obs. we get right and dividing it by the total number of obs.

(2382+17)/nrow(test)

# We got an accuracy of 0.84, what is impressively good.

# Accuracy of AUC
# We can calculate the accuracy of the model using another metric, that is the AUC.

library(ROCR)
ROCRpred=prediction(test$predicted.risk,test$not.fully.paid)
as.numeric(performance(ROCRpred,'auc')@y.values)

# In this case, we got an accuracy of 0.66.


suppressMessages(library(cop))

x = matrix(1:4, 2) + 10*comm.rank()

mpi_cat("\n", quiet=TRUE)

mpi_cat("function:\n", quiet=TRUE)
mpi_print("qr_allreduce")

ar=FALSE
mpi_cat("\ninput:\n", quiet=TRUE)
mpi_print(x, all.rank=ar)

out = qr_allreduce(x)
mpi_cat("\noutput:\n", quiet=TRUE)
mpi_print(out, all.rank=ar)

out = qr_allreduce(x, type="float")
mpi_cat("\noutput:\n", quiet=TRUE)
mpi_print(out, all.rank=ar)

finalize()


suppressMessages(library(Seurat))
suppressMessages(library(dplyr))
suppressMessages(library(Matrix))
suppressMessages(library(methods))
suppressMessages(library(scales))
suppressMessages(library(ggplot2))

args=commandArgs(T);
#sample=as.character(args[1]);
sample=args[1];

setwd("./")
path_out="./"

data1=read.table(paste("data_ref/expr.txt",sep=""))
data2=read.table(paste("data_obj/",sample,".txt",sep=""))
gene1=read.table(paste("data_ref/gene.txt",sep=""))

data3=rbind(data1[,1:ncol(data1)],data2[,1:ncol(data2)])
data4=t(data3)
cell_all=nrow(data3)
colnames(data4) <- paste("cell",c(1:cell_all),sep="")
rownames(data4) <- gene1[,2]

suppressWarnings(suppressMessages(bmmc <- CreateSeuratObject(counts = data4, project = "test")))
suppressWarnings(suppressMessages(bmmc <- ScaleData(object = bmmc)))

suppressWarnings(suppressMessages(bmmc <- RunPCA(bmmc, features = rownames(bmmc), npcs = 30,weight.by.var = TRUE)))

write.table(bmmc@reductions$pca@cell.embeddings[,1:30],file=paste(path_out,"temp_out/s5_embedding_",sample,".txt",sep=""),sep = "\t",row.names=F,col.names=F)


pdf_file<-"pdf/timeseries_columns_share_growth.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11,height=9)

par(las=1,cex=0.9,omi=c(0.75,0.5,1.25,0.5),mai=c(0.5,1,0,1),family="Lato Light",las=1)

# Define data

myData<-c(25296,28365,32187,36835,39788,44282,51122,60420,58437,62484)/1000
myLabels<-c(2002:2011)
myGrowth<-0
for (i in 2:length(myData)) myGrowth<-c(myGrowth,myData[i]-myData[i-1])
myValueLeft<-myData-myGrowth

x<-rbind(t(myData),t(myData))
y<-rbind(t(myValueLeft),rep(0,length(myData)))
f1<-"darkgreen"; f2<-"grey60"
myColours<-c(f1,f2)
for (i in 1:length(myData)-1) myColours<-c(myColours,f1,f2)

for (i in 1:length(myData))
{
if (y[1,i]>x[1,i])
{
	tmp<-x[1,i]; x[1,i]<-y[1,i]; y[1,i]<-tmp
	myColours[(2*i)-1]<-"darkred"
}
}

# Create chart and other elements

barplot(x,beside=T,border=NA,col=myColours,space=c(0,2),axes=F)
barplot(y,beside=T,border=NA,col=rep("grey60",2*length(myData)),add=T,names.arg=myLabels,space=c(0,2),axes=F)
axis(2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)

hoehe<-0.1*max(myData)
j<-1
k<-j
for (i in 1:length(myData))
{
if (j > 1) k<-k+4
text(k+1.3,hoehe,format(round(x[2,i]),nsmall=0),cex=1.25,adj=0,xpd=T,col="white")
j<-j+3
if (i<length(myData)) text(k+3.1,y[1,i+1]+((x[1,i+1]-y[1,i+1])/2),
	format(round(myGrowth[i+1],1),cex=0.75,nsmall=1),adj=0)
}

# Titling

mtext("Sales Development Microsoft",3,line=4,adj=0,family="Lato Black",outer=T,cex=2)
mtext("Figures in Bill. US-Dollars",3,line=1,adj=0,cex=1.35,font=3,outer=T)
mtext("Source: money.cnn.com",1,line=2,adj=1.0,cex=1.1,font=3,outer=T)
dev.off()


require(colorspace)

scores = read.delim("scores.tsv")
counts = read.delim("counts.tsv")
growth = read.delim("growth.tsv")

pdf("scores.pdf", width=4, height=3, pointsize=10)
old = par(mar=c(5.1, 4.5,3.1,2.1))

color = cut(scores$score, breaks=c(0,9,16,25,36,64,100), labels=heat_hcl(6))

plot(score ~ merchant, data=scores, cex=0.5, col=color, pch=21,
     main="LLR score for simulated merchants", ylab="Breach Score (LLR)",
     yaxt='n')

abline(h=9,col=heat_hcl(6)[2],lty=3)
abline(h=16,col=heat_hcl(6)[3],lty=3)
abline(h=25,col=heat_hcl(6)[4],lty=3)

axis(side=2, at=c(-10,0,10,20,30,40))
text(800, 30, "Compromised Merchant", adj=0, cex=0.7)
arrows(750, 32, 120, 40, length=0.06, angle=15)
par(old)
dev.off()

pdf("scores-binned.pdf", width=4, height=3, pointsize=10)
old = par(mar=c(5.1, 4.5,3.1,2.1))

scores$bin = as.integer(cut(scores$score, breaks=150))

binned = data.frame(
    score=aggregate(scores$score, by=list(scores$bin), FUN=mean)$x,
    count=aggregate(scores$bin, by=list(scores$bin), FUN=length)$x)

color = cut(binned$score, breaks=c(0,9,16,25,36,64,100), labels=heat_hcl(6))

plot(score ~ count, data=binned, cex=0.6, col=color, pch=20,
     main="LLR score for simulated merchants", ylab="Breach Score (LLR)", xlab="Number of Merchants",
     yaxt='n', xlim=c(1,1e6), log='x', ylim=c(0,80), xaxt='n')

ticks <- seq(0,6, by=1)
labels <- sapply(ticks, function(i) as.expression(bquote(10^ .(i))))
axis(1,at=c(1,10,100,1000,10000,100000,1000000),labels=labels)

abline(h=16,col=3,lty=3)
abline(h=25,col=4,lty=3)

axis(side=2, at=c(-10,0,20,40,60,80))
text(20, 50, "Compromised Merchant", adj=0, cex=0.7)
arrows(15, 49, 1.5, 43, length=0.06, angle=15)
par(old)
dev.off()

pdf("counts.pdf", width=4, height=3, pointsize=10)
old = par(mar=c(4.3, 4.2,1.5,1.5))
plot(compromises ~ day, data=counts, col=rgb(0,0,0,alpha=0.7), pch=21, type='l', xlim=c(0,100), ylab="count")
lines(frauds ~ day, data=counts, col='red')

# annotates the compromise window
compromiseY = 350
text(19,compromiseY+30, "Compromise period", adj=0, cex=0.9)
arrows(7,compromiseY, 12.5,compromiseY, length=0.06, angle=15)
arrows(23,compromiseY, 17.5,compromiseY, length=0.06, angle=15)
lines(c(12.6,12.6),c(compromiseY-20,compromiseY+20))
lines(c(17.4,17.4),c(compromiseY-20,compromiseY+20))

# annotates the exploit windwo
exploitY = 230
text(34,exploitY+30, "Exploit period", adj=0.5, cex=0.9)

arrows(24,exploitY,19,exploitY,length=0.06, angle=15)
arrows(44,exploitY,49,exploitY,length=0.06, angle=15)
lines(c(18.9,18.9),c(exploitY-20,exploitY+20))
lines(c(49.1,49.1),c(exploitY-20,exploitY+20))

# indicates which line is which
legend(x=65, y=560, legend=c("compromises", "frauds"), fill=c('black', 'red'), cex=0.8)
par(old)
dev.off()

pdf("growth.pdf", width=4, height=3, pointsize=10)
old = par(mar=c(4.3, 4.2,3.5,1.5))
plot(score ~ day, data=growth, col=rgb(0,0,0,alpha=0.7), pch=21, type='l',
     ylim=c(0,45), ylab=expression(-2*log(lambda)), xlab="Day in exploit window",
     main="Growth of LLR during exploit window")

par(old)
dev.off()


# Information about code:
# This code corresponds to a chapter in my MSc thesis for
# Chapter 3, the section on Gender analysis: utility  functions.
# adapted from https://github.com/lukeholman/genderGapCode/
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# Set up
source('2020-08-31-jsa-type-v2/subset.r')
source('2020-08-31-jsa-type-v2-ch3-gender/analysis1/libraries.r')
source('2020-08-31-jsa-type-v2-ch3-gender/analysis1/params.r')

# Scripts

# get data from UN's API and save locally
# source('2020-08-31-jsa-type-v2-ch3-gender/analysis1/data-un.r')

# read local/ bee data
source('2020-08-31-jsa-type-v2-ch3-gender/analysis1/data-model.r')

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - gender rep - in text fig
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# % of M, F, U
names(auth_full)
dim(auth_full)
table(auth_full$describer.gender)
prop.table(table(auth_full$describer.gender))

dim(auth[describer.gender!="U"])
table(auth[describer.gender!="U"]$describer.gender)
prop.table(table(auth[describer.gender!="U"]$describer.gender))

# Earliest date
min_yr_female <- min(dat[describer.gender=="F" ]$date.n)
dat[describer.gender=="F" & date.n== min_yr_female]

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - gender rep time series - visualisation
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# By n species described
ts_prop_f <- dat[, list(
    nF = sum(describer.gender == "F"),
    nM = sum(describer.gender == "M")
), by = "date.n"]

ts_prop_f$prop <- ts_prop_f$nF/ ( ts_prop_f$nF + ts_prop_f$nM )
# ggplot(ts_prop_f, aes(x=date.n, y=prop)) + geom_line() + theme

# By taxonomist
ts_prop_f_tax <- auth_years[, list(
    nF = sum(describer.gender == "F"),
    nM = sum(describer.gender == "M")
), by = "years"]

ts_prop_f_tax$prop <- ts_prop_f_tax$nF/ ( ts_prop_f_tax$nF + ts_prop_f_tax$nM )
# ggplot(ts_prop_f_tax, aes(x=years, y=prop)) + geom_line() + theme

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - gender rep - run model for taxonomists
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

unique(auth_years[describer.gender=="U", 'full.name.of.describer'])

# Output data
country <- "All"; position <- "All"; type <- "Tax"
prop  <- generate_prop_t_tax(country=country)
output <- main(country=country, position=position, prop)

r <- output$summary$r; c <- output$summary$c
parity.year <- output$summary$years.to.parity

baseline_yr <- min(prop$date.n)
max_y <- 70

# determine x-axis max value
max_predict_year <- as.integer((max(prop$date.n) - min(prop$date.n)) * 1.75)
parity.year <- as.numeric(parity.year) + CURRENT_YEAR - baseline_yr
max_predict_year <- ifelse(
    parity.year > max_predict_year, parity.year, max_predict_year
)

prop_overlay <- cbind(prop, get.CIs(prop$nFemales, prop$nMales))
prop_template <- data.frame(
    yrs_fr_baseline = 0:max_predict_year + baseline_yr,
    predicted = sapply(0:max_predict_year, pfunc, r=r, c=c)
)

prop_overlay <- merge(
    prop_template, prop_overlay,
    by.x="yrs_fr_baseline", by.y="date.n",
    all.x=T, all.y=F
)

# NOTE! the unknowns were excluded!
sum(prop_overlay$`U`, na.rm=T)

prop_overlay$U <- NULL
prop_overlay$n <- NULL
prop_overlay$date <- NULL

names(prop_overlay) <- c(
    "year", "prop_F_predicted", "N_female", "N_males",
    "prop_Fl", "prop_F_lwrCI", "prop_F_uprCI"
)

wfile <- paste0(v2_dir_data_webapp, "ch3-fig-05-data.csv")
fwrite(prop_overlay, wfile, na="")

# Run model
result <- run_specific_scenario(
    country="All", position="All", dir_data_subf2, "tax"
)

prop_table <- generate_prop_t(country="All")
result_summary_tax <- result$summary

result_summary_countries_tax <- lapply(countries[1:6], function(country) {

    run_specific_scenario(
        country=country, position="All", dir_data_subf2, "tax"
    )$summary

})

outputs <- rbindlist(c(list(result_summary_tax), result_summary_countries_tax))
write.csv(outputs, paste0(dir_data_subf2, "_outputs.csv"), row.names=F)

# # Testing
#
# # Test generating prop tables
# generate_prop_t_tax("Germany")
# generate_prop_t_tax("United States of America")
#
# # Test plotting
# source('2020-08-31-jsa-type-v2-ch3-gender/analysis1/model.r')
# prop_t <- generate_prop_t_tax(country="Brazil")
# output <- main(country = "Brazil", position = "All", prop_t)
#
# save_graph(
#     dir_data_subf2, country="Brazil", position="All", prop_t,
#     output$summary$r, output$summary$c, output$summary$years.to.parity, "tax"
# )

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - gender rep - in text fig on country
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- gender rep - in text fig on country"))

prop_tax <- auth[, .N, c("Country", "describer.gender")][order(-N)]
prop_tax <- dcast(prop_tax, Country ~ describer.gender, value.var="N")
prop_tax <- prop_tax[!is.na(Country)]
prop_tax[is.na(prop_tax)] <- 0
prop_tax$N <- prop_tax$F + prop_tax$M
prop_tax$prop_F <- prop_tax$F / prop_tax$N
prop_tax <- prop_tax[order(-prop_F)]

head(prop_tax, 3)

dim(prop_tax)
prop_tax[U >= 1 & (F == 0 & M == 0)]

# Exclude those countries with only unknown gender
prop_tax <- prop_tax[!(U >= 1 & (F == 0 & M == 0))]
prop_tax[grepl("Unknown", Country)]

dim(prop_tax)[1]              # N countries
length(prop_tax[prop_F==0]$F) # N countries w no females
length(prop_tax[prop_F>0]$F)  # N countries w females
median(prop_tax[prop_F>0]$F)  # Median F taxonomists in countries w females
median(prop_tax[prop_F>0]$M)  # Median M taxonomists in countries w females

prop_tax[F+M+U>5][1:10] #

len = dim(prop_tax[F+M+U>5])[1]
prop_tax[F+M+U>5][(len-10):len]

write.csv(
    prop_tax, paste0(v2_dir_data_ch3_gender, "2019-11-15-prop-taxonomist.csv"),
    row.names=F, fileEncoding='UTF-8'
)

# # Proportion of papers (! NOT USED)
# prop_t_countries <- rbindlist(lapply(countries, function(country) {
#     prop <- generate_prop_t(country=country, position="All")

#     if (!is.null(prop)) {
#         data.frame(Country=country, M=sum(prop$nMales), F=sum(prop$nFemales))
#     }

# }))

# prop_t_countries <- prop_t_countries[!is.na(Country)]
# prop_t_countries[is.na(prop_t_countries)] <- 0
# prop_t_countries$N <- prop_t_countries$F + prop_t_countries$M
# prop_t_countries$prop_F <- prop_t_countries$F / prop_t_countries$N
# prop_t_countries <- prop_t_countries[order(-prop_F)]

# write.csv(
#     prop_t_countries,
#     paste0(v2_dir_data_ch3_gender, "2019-11-15-prop-taxonomist-spp.csv"),
#     row.names=F, fileEncoding='UTF-8'
# )

############### NOT USED IN MAIN TEXT ###############

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - gender rep - run model for species
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- gender rep - run model for species"))

#################
# By Position
#################

result_summary_all_prop <- generate_prop_t(country="All")

spp_sum <- dat[, .N, by=c("describer.gender")]
spp_sum[describer.gender=="U"]$N/sum(spp_sum$N)*100
spp_sum <- spp_sum[describer.gender != "U"]; sum(spp_sum$N)
prop.table(spp_sum[,2])*100

result_summary_all <- lapply(
    c("All", "First", "Last", "First_s", "Last_s"), function(pos) {

        run_specific_scenario(
            country="All", position=pos, dir_data_subf1
        )$summary

})

#################
# By Country
#################

# countries <- c(
#     "United States of America", "Germany", "Brazil",
#     "France", "United Kingdom", "Japan"
# )

result_summary_countries <- lapply(countries[1:6], function(country) {
    run_specific_scenario(
        country=country, position="All", dir_data_subf1
    )$summary
})
# usa, germany, brazil, france, united kingdom, japan [top 6 countries]
# as case studies; they have more than 30 taxonomists across the years
# and potentially have interesting stories to tell

outputs <- rbindlist(c(result_summary_all, result_summary_countries))
write.csv(outputs, paste0(dir_data_subf1, "_outputs.csv"), row.names=F)

# Testing
# print(result_summary[[1]])
# rbindlist(result_summary)

# generate_prop_t("Germany", "All")
# generate_prop_t("France", "All")

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - gender rep - if UN factors affect gender propo
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- gender rep - if UN factors affect gender proportion"))

# Modelling taxonomists
prop_tax_mdf <- merge(prop_tax, df_r, by="Country", all.x=T, all.y=F)
prop_tax_mdf <- prop_tax_mdf[N!=0]

prop_tax_mdf$F_yn <- factor(
    ifelse(prop_tax_mdf$F > 0, "Y", "N"),
    levels=c("N", "Y")
)

names(prop_tax_mdf)

prop_tax_mdf[is.na(country)]
prop_tax_mdf <- prop_tax_mdf[!is.na(country)]

ggplot(prop_tax_mdf, aes(x=F_yn, y=schl_f)) + geom_boxplot()
ggplot(prop_tax_mdf, aes(x=F_yn, y=gnip_f)) + geom_boxplot()
ggplot(prop_tax_mdf, aes(x=F_yn, y=gdip_a)) + geom_boxplot()

var <- unlist(lapply(prop_tax_mdf, is.numeric))
cor(prop_tax_mdf[, ..var])
heatmap(cor(prop_tax_mdf[, ..var]), Colv = NA, Rowv = NA)

# note: it did not look promising


#' Generates the preseason projections for the teams
#'
#' This function generates preseason projections using mulilevel models to
#' estimate the contribution of each team's offense and defense provides to
#' their Expected Points Added per Play.
#' @param run_plays the cleaned run plays after the \code{add_epa} function
#' @param pass_plays the cleaned pass plays after the \code{add_epa} function
#' @return a data frame containing the estimated team values at the end of each year.
#' @importFrom magrittr "%>%"
#' @examples
#' years <- 2013:2014
#' plays <- readin("play", years)
#' teams <- readin("team", years)
#' runs <- readin("rush", years)
#' pass <- readin("pass", years)
#' games <- readin("game", years)
#' conf <- readin("conference", years)

#' epa_model <- expected_points_build(plays[plays$Year != 2014, ], drives[drives$Year != 2014, ])
#' fixed_games <- fix_games(games)
#' model_plays <- combine_run_pass(runs, pass, fixed_games) %>% remove_garbage %>% fix_fcs(teams, conf) %>% add_epa(epa_model)
#' preseason_vals <- generate_preseason_mlm(model_plays[[1]], model_plays[[2]])

generate_preseason_mlm <- function(run_plays, pass_plays){

  run_year_vals <- run_plays %>%
    dplyr::group_by(Year) %>%
    dplyr::do(
      lme4::lmer(EPA ~ 1 + factor(Home.Team) + Site + (1 | Offense.Team.Code) + (1 | Defense.Team.Code), data = .) %>%
      broom::tidy() %>%
      tidyr::spread(group, estimate) %>%
      dplyr::mutate(Team.Code = as.numeric(level)) %>%
      dplyr::filter(term == "(Intercept)") %>%
      dplyr::select(-level, -term) %>%
      dplyr::rename(DRush = Defense.Team.Code, ORush = Offense.Team.Code)) %>%
    dplyr::mutate(Prev.Year = Year - 1) %>%
    dplyr::ungroup()
  run_year_vals <- dplyr::left_join(run_year_vals, run_year_vals, by = c("Team.Code" = "Team.Code", "Year" = "Prev.Year"))

  team_pred <- dplyr::select(run_year_vals, Team.Code, Year.y, ORush.x, DRush.x) %>%
    dplyr::rename(Pred.ORush = ORush.x, Pred.DRush = DRush.x)

  pass_year_vals <- pass_plays %>%
    dplyr::group_by(Year) %>%
    dplyr::do(
      lme4::lmer(EPA ~ 1 + factor(Home.Team) + Site + (1 | Offense.Team.Code) + (1 | Defense.Team.Code), data = .) %>%
      broom::tidy() %>%
      tidyr::spread(group, estimate) %>%
      dplyr::mutate(Team.Code = as.numeric(level)) %>%
      dplyr::filter(term == "(Intercept)") %>%
      dplyr::select(-level, -term) %>%
      dplyr::rename(DPass = Defense.Team.Code, OPass = Offense.Team.Code)) %>%
    dplyr::mutate(Prev.Year = Year - 1) %>%
    dplyr::ungroup()
  pass_year_vals <- dplyr::left_join(pass_year_vals, pass_year_vals, by = c("Team.Code" = "Team.Code", "Year" = "Prev.Year"))

  team_vals <- dplyr::select(pass_year_vals, Team.Code, Year.y, OPass.x, DPass.x) %>%
    dplyr::left_join(team_pred, by = c("Team.Code", "Year.y")) %>%
    dplyr::rename(Year = Year.y, Pred.OPass = OPass.x, Pred.DPass = DPass.x) %>%
    dplyr::filter(!is.na(Year))
}


# Goal: Make a time-series object using the "zoo" package

A <- data.frame(date=c("1995-01-01", "1995-01-02", "1995-01-03", "1995-01-06"),
                x=runif(4),
                y=runif(4))
A$date <- as.Date(A$date) # yyyy-mm-dd is the default format
# So far there's nothing new - it's just a data frame. I have hand-
# constructed A but you could equally have obtained it using read.table().

# I want to make a zoo matrix out of the numerical columns of A
library(zoo)
B <- A
B$date <- NULL
z <- zoo(as.matrix(B), order.by=A$date)
rm(A, B)

# So now you are holding "z", a "zoo" object. You can do many cool
# things with it.
# See http://www.google.com/search?hl=en&q=zoo+quickref+achim&btnI=I%27m+Feeling+Lucky

# To drop down to a plain data matrix, say
C <- coredata(z)
rownames(C) <- as.character(time(z))
# Compare --
str(C)
str(z)

# The above is a tedious way of doing these things, designed to give you
# an insight into what is going on. If you just want to read a file
# into a zoo object, a very short path is something like:
#        z <- read.zoo(filename, format="%d %b %Y")

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/r6.r


library("testthat");
source("../equalSizedBins.r");

# q1 == minX and q2 == minXX
x1Binned = equalSizedBins(rbind(1,1,1,1,1,2,2,2,3,3));
expect_equal(x1Binned, rbind(0,0,0,0,0,1,1,1,2,2));

# q1 == minX and q2 == maxXX
x1Binned = equalSizedBins(rbind(1,1,1,1,1,2,2,3,3,3));
expect_equal(x1Binned, rbind(0,0,0,0,0,1,1,2,2,2));

# q1 == minX and normal split
x1Binned = equalSizedBins(rbind(1,1,1,1,1,2,3,4,5,6));
expect_equal(x1Binned, rbind(0,0,0,0,0,1,1,2,2,2));

# q3 == maxX and q1 == minXX
x1Binned = equalSizedBins(rbind(1,1,1,2,2,3,3,3,3,3));
expect_equal(x1Binned, rbind(0,0,0,1,1,2,2,2,2,2));

# q3 == maxX and q1 == maxXX
x1Binned = equalSizedBins(rbind(1,1,2,2,2,3,3,3,3,3));
expect_equal(x1Binned, rbind(0,0,1,1,1,2,2,2,2,2));

# q3 == maxX and q1 == maxXX
x1Binned = equalSizedBins(rbind(1,2,3,4,5,6,6,6,6,6));
expect_equal(x1Binned, rbind(0,0,1,1,1,2,2,2,2,2));

# q1==q2
x1Binned = equalSizedBins(rbind(1,2,2,2,2,2,2,2,2,3));
expect_equal(x1Binned, rbind(0,1,1,1,1,1,1,1,1,2));

# main case - nicely separates into 3 bins
x1Binned = equalSizedBins(rbind(1,2,3,4,5,6,7,8,9,10));
expect_equal(x1Binned, rbind(0,0,0,1,1,1,2,2,2,2));


install.packages("readxl")
model_names = c("PD_SEV", "BI_SEV","PD_FRQ", "BI_FRQ")
p_vec = list(c(12), c(1), c(1,2,3), c(1,2))
p_vec_seas = list(NA,c(12),NA,NA)
d_vec = list(c(1),NA,c(12),c(1,12))
q_vec = list(c(1),NA,c(12,24), c(12))

p_coeff = list(c(-0.3432),c(-0.6122),c(0.1829, -0.0141, 0.2892),c(0.7008, 0.3897))
p_seas_coeff = list(NA,c(-0.4383),NA,NA)
q_coeff = list(c(-0.5337),c(-0.6122,-0.4383),c(-0.1989,-0.3304),c(-0.1756))

#Function for refitting the state specific model with the countrywide coefficients
#historical_dat the historical data vector containing values for Y(t-12) etc.
#model_coeff coefficients from the countrywide model to be fitted on to the state model
#champion_model the name of the champion model we're suppoesd to use
#t is the month/time variable for getting the data
countrywide_fit = function(historical_dat, model_coeff, champion_model, t) {
  yt_vec = rep(NA,length(historical_dat))
  yt_vec[13] = historical_dat$data[13]
  datvec = historical_dat$data
  starting_index = 14
  for (pred_index in seq(starting_index, length(historical_dat))) {
    yt = 0
    index = match(champion_model, model_names)
    if (is.na(index)) {
      break;
    }

    # adding the autoregressive terms both seasonal and non seasonal
    if(!is.na(p_vec[[index]])) {
      vec = p_vec[[index]]
      coef_vec = p_coeff[[index]]
      for (i in seq_len(length(vec))) {
        lagvec = hitorical_dat$data[historical_dat$time == (t-(i%%12))]
        term1 = lagvec[length(lagvec)]
        term2 = lagvec[length(lagvec) - 1]
        yt = yt + coef_vec[i]*(term1 - term2)
      }
      if(!is.na(p_vec_seas[[index]])) {
        vec2 = p_vec_seas[[index]]
        coef_vec2 = p_seas_coeff[[index]]
        for (i in seq_along(vec2)) {
          lagvec = historical_dat$data[historical_dat$time == (t - (i%%12))]
          if (i%%12 == 0) {
            yt = yt + coef_vec2[i]*lagvec[length(lagvec) - (i/12)]
          }
          else {
            yt = yt + coef_vec2[i]*lagvec[length(lagvec)]
          }
        }
      }
    }

    # adding the differencing terms
    if(!is.na(d_vec[[index]])) {
      dvec = d_vec[[index]]
      for(i in dvec) {
        yt  = yt + lagvec[length(lagvec) - i]
      }
    }

    # adding the moving average terms
    if (!is.na(q_vec[[index]])) {
      qvec = q_vec[[index]]
      coeff_vec = q_coeff[[index]]
      for (i in qvec) {
        yt = yt + coeff_vec[i]*(datvec[pred_index - i] - yt_vec[pred_index - i])
      }
    }

    # adding external variables, In Progress

    yt_vec[pred_index] = yt
  }

  return (yt_vec)
}

model_vec = function(model_string) {
  # split the model passed as a string into individual characters in a list and then take the first elem of the list
  model_list = strsplit(model_string, "")
  model_list = model_list[[1]]

  #drop all the non numeric values in the vector and then convert vector into an integer vector
  model_list = model_list[!is.na(as.numeric(model_list))]
  model_list = as.integer(model_list)
  return (model_list)
}

data_pull = function(filename) {
  library(readxl)
  dat = read_excel(filename)
  return(dat)
}


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(ggrepel))
suppressPackageStartupMessages(library(cowplot))

viz_file <- file.path("..", "scripts", "visualization_utils.R")
source(viz_file)

util_file <- file.path("..", "scripts", "processing_utils.R")
source(util_file)

doses <- c(0.7, 7)

axis_title_size <- 10
axis_text_size <- 9
strip_text_size <- 8
ggrepel_label_size <- 1.9
title_text_size <- 10
ymax <- 9

file <- file.path("..", "data", "merged_intersected_variable_selected.csv")
data_df <- load_data(file)

print(dim(data_df))
head(data_df, 3)

tstat_dose <- c()
pval_dose <- c()

tstat_cell <- c()
pval_cell <- c()

all_features <- c()
for (feature in colnames(data_df)) {
    if (!grepl("Metadata_", feature)) {
        # Perform Dose Experiment
        doseA <- data_df %>%
            dplyr::filter(Metadata_Dosage == doses[1],
                          Metadata_CellLine != "WT") %>%
            dplyr::pull(!!feature)

        doseB <- data_df %>%
            dplyr::filter(Metadata_Dosage == doses[2],
                          Metadata_CellLine != "WT") %>%
            dplyr::pull(!!feature)

        result <- t.test(doseA, doseB, var.equal = FALSE)

        tstat_dose <- c(tstat_dose, as.numeric(paste(result$statistic)))
        pval_dose <- c(pval_dose, result$p.value)

        # Perform Cell Line Experiment at 0.7uM Dose
        resistant_clones <- data_df %>%
            dplyr::filter(Metadata_Dosage == 0.7,
                          Metadata_CellLine != "WT") %>%
            dplyr::pull(!!feature)

        wt_cells <- data_df %>%
            dplyr::filter(Metadata_Dosage == 0.7,
                          Metadata_CellLine == "WT") %>%
            dplyr::pull(!!feature)

        result <- t.test(resistant_clones, wt_cells, var.equal = FALSE)

        tstat_cell <- c(tstat_cell, as.numeric(paste(result$statistic)))
        pval_cell <- c(pval_cell, result$p.value)

        # Track which feature is being tested
        all_features <- c(all_features, feature)
    }
}

# Obtain Results for Dose Differences
result_dose_df <- as.data.frame(cbind(tstat_dose, pval_dose))
result_dose_df$neglog10p <- -log10(result_dose_df$pval_dose)
result_dose_df$feature <- all_features
result_dose_df <- result_dose_df %>% dplyr::arrange(desc(neglog10p))

dim(result_dose_df)
head(result_dose_df, 3)

# Obtain Results for Cell Line Differences
result_cell_df <- as.data.frame(cbind(tstat_cell, pval_cell))
result_cell_df$neglog10p <- -log10(result_cell_df$pval_cell)
result_cell_df$feature <- all_features
result_cell_df <- result_cell_df %>% dplyr::arrange(desc(neglog10p))

dim(result_cell_df)
head(result_cell_df, 3)

alpha_correction <- -log10(0.05 / dim(result_dose_df)[1])
repel_logic <- result_dose_df$neglog10p > alpha_correction * 1.5

ttest_dose_gg <- ttest_volcano(
    df = result_dose_df,
    x_string = "tstat_dose",
    title = "0.7nM vs. 7nM Dose (Resistant Clones)",
    title_text_size = title_text_size,
    yintercept = alpha_correction,
    repel_logic = repel_logic,
    ggrepel_label_size = ggrepel_label_size,
    axis_text_size = axis_text_size,
    axis_title_size = axis_title_size,
    ymax = ymax
)

alpha_correction <- -log10(0.05 / dim(result_cell_df)[1])
repel_logic <- result_cell_df$neglog10p > alpha_correction * 1.1

ttest_cell_gg <- ttest_volcano(
    df = result_cell_df,
    x_string = "tstat_cell",
    title = "Resistant vs. Wildtype Cells (0.7nM)",
    title_text_size = title_text_size,
    yintercept = alpha_correction,
    repel_logic = repel_logic,
    ggrepel_label_size = ggrepel_label_size,
    axis_text_size = axis_text_size,
    axis_title_size = axis_title_size,
    ymax = ymax
)

# The top feature is something to do with nuclear area
top_feature <- paste(result_dose_df$feature[1])

append_batch <- function(string) paste("Batch:", string)
append_dose <- function(string) paste0("Dose: ", string, "nM")

distrib_gg <- ggplot(data_df, aes_string(x = `top_feature`)) +
    geom_density(aes(fill = Metadata_CellLine),
                 alpha = 0.6) +
    geom_rug(aes(color = Metadata_CellLine),
             alpha = 0.8,
             size = 0.5) +
    facet_grid(Metadata_Dosage ~ Metadata_Batch_Number,
               scales = "fixed",
               labeller = labeller(Metadata_Batch_Number = as_labeller(append_batch),
                                   Metadata_Dosage = as_labeller(append_dose))) +
    scale_color_manual(name = "Cell Line",
                      labels = c("CloneA" = "Clone A",
                                 "CloneE" = "Clone E",
                                 "WT" = "Wild type"),
                      values = c("CloneA" = "#1b9e77",
                                 "CloneE" = "#d95f02",
                                 "WT" = "#7570b3")) +
    scale_fill_manual(name = "Cell Line",
                      labels = c("CloneA" = "Clone A",
                                 "CloneE" = "Clone E",
                                 "WT" = "Wild type"),
                      values = c("CloneA" = "#1b9e77",
                                 "CloneE" = "#d95f02",
                                 "WT" = "#7570b3")) +
    theme_bw() +
    theme(axis.text = element_text(size = axis_text_size),
          axis.title = element_text(size = axis_title_size),
          strip.text = element_text(size = strip_text_size),
          strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4"))

table(data_df$Metadata_CellLine,
      data_df$Metadata_Dosage,
      data_df$Metadata_Batch_Number)

feature_plot <- (
    cowplot::plot_grid(
        ttest_cell_gg,
        ttest_dose_gg,
        labels = c("a", "b"),
        ncol = 1,
        nrow = 2
    )
)

main_plot <- (
    cowplot::plot_grid(
        feature_plot,
        distrib_gg,
        labels = c("", "c"),
        ncol = 2,
        nrow = 1,
        rel_widths = c(0.7, 1)
    )
)

main_plot

file_base <- file.path("figures", "dosage_feature_figure")
save_figure(main_plot, file_base, height = 6, width = 8)

batch <- "2019_06_25_Batch3"
file <- file.path("..", "data", paste0(batch, "_merged_intersected_variable_selected.csv"))

data_df <- load_data(file)

print(dim(data_df))
head(data_df, 3)

tstat_cell <- c()
pval_cell <- c()

all_features <- c()
for (feature in colnames(data_df)) {
    if (!grepl("Metadata_", feature)) {

        # Perform Cell Line Experiment at 0.7uM Dose
        resistant_clones <- data_df %>%
            dplyr::filter(Metadata_Plate == "MutClones") %>%
            dplyr::pull(!!feature)

        wt_cells <- data_df %>%
            dplyr::filter(Metadata_Plate == "WTClones") %>%
            dplyr::pull(!!feature)

        result <- t.test(resistant_clones, wt_cells, var.equal = FALSE)

        tstat_cell <- c(tstat_cell, as.numeric(paste(result$statistic)))
        pval_cell <- c(pval_cell, result$p.value)

        # Track which feature is being tested
        all_features <- c(all_features, feature)
    }
}

# Obtain Results for Cell Line Differences
result_cell_df <- as.data.frame(cbind(tstat_cell, pval_cell))
result_cell_df$neglog10p <- -log10(result_cell_df$pval_cell)
result_cell_df$feature <- all_features
result_cell_df <- result_cell_df %>% dplyr::arrange(desc(neglog10p))

dim(result_cell_df)
head(result_cell_df, 3)

alpha_correction <- -log10(0.05 / dim(result_cell_df)[1])
repel_logic <- (
    result_cell_df$neglog10p > alpha_correction |
    result_cell_df$tstat_cell > 2.65 |
    result_cell_df$tstat_cell < -2.4
    )

ttest_cell_gg <- ttest_volcano(
    df = result_cell_df,
    x_string = "tstat_cell",
    title = "Resistant vs. Wildtype Cells",
    title_text_size = title_text_size,
    yintercept = alpha_correction,
    repel_logic = repel_logic,
    ggrepel_label_size = ggrepel_label_size,
    axis_text_size = axis_text_size,
    axis_title_size = axis_title_size,
    ymax = ymax
)

# The top feature is something to do with nuclear area
top_feature <- paste(result_cell_df$feature[1])

distrib_gg <- ggplot(data_df,
                     aes_string(x = `top_feature`)) +
    geom_density(aes(fill = Metadata_Plate_Map_Name),
                 alpha = 0.6) +
    geom_rug(aes(color = Metadata_Plate_Map_Name),
             alpha = 0.8,
             size = 0.5) +
    scale_color_manual(name = "Cell Line",
                      labels = c("MutClones" = "Mutant",
                                 "WTClones" = "Wild-type"),
                      values = c("MutClones" = "#1b9e77",
                                 "WTClones" = "#d95f02")) +
    scale_fill_manual(name = "Cell Line",
                      labels = c("MutClones" = "Mutant",
                                 "WTClones" = "Wild-type"),
                      values = c("MutClones" = "#1b9e77",
                                 "WTClones" = "#d95f02")) +
    theme_bw() +
    theme(axis.text = element_text(size = axis_text_size),
          axis.title = element_text(size = axis_title_size),
          strip.text = element_text(size = strip_text_size),
          strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4"))

top_neg <- result_cell_df %>%
    dplyr::arrange(tstat_cell) %>%
    select(feature)

top_feature = top_neg$feature[1]

distrib_neg_gg <- ggplot(data_df,
                         aes_string(x = `top_feature`)) +
    geom_density(aes(fill = Metadata_Plate_Map_Name),
                 alpha = 0.6) +
    geom_rug(aes(color = Metadata_Plate_Map_Name),
             alpha = 0.8,
             size = 0.5) +
    scale_color_manual(name = "Cell Line",
                      labels = c("MutClones" = "Mutant",
                                 "WTClones" = "Wild-type"),
                      values = c("MutClones" = "#1b9e77",
                                 "WTClones" = "#d95f02")) +
    scale_fill_manual(name = "Cell Line",
                      labels = c("MutClones" = "Mutant",
                                 "WTClones" = "Wild-type"),
                      values = c("MutClones" = "#1b9e77",
                                 "WTClones" = "#d95f02")) +
    theme_bw() +
    theme(axis.text = element_text(size = axis_text_size),
          axis.title = element_text(size = axis_title_size),
          strip.text = element_text(size = strip_text_size),
          strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4"))

full_distrib_gg <- (
    cowplot::plot_grid(
        distrib_gg,
        distrib_neg_gg,
        labels = c("b", "c"),
        nrow = 2
    )
)

main_plot <- (
    cowplot::plot_grid(
        ttest_cell_gg,
        full_distrib_gg,
        labels = c("a", ""),
        ncol = 2,
        nrow = 1,
        rel_widths = c(1, 1)
    )
)

main_plot

file_base <- file.path("figures", paste0(batch, "_feature_figure"))
save_figure(main_plot, file_base, height = 6, width = 8.5)


library(zoo)
library("ggplot2")
library(gridExtra)
library(grid)
library(qdapTools)

setwd("C:/Code/climData/glaser2019")

#hhi <- read.csv("csv/hhi_summer_1000_2019.csv", sep=",", na = "NA")

#half  <- read.csv("csv/tmb_folgen_5_10.csv", sep=",")

piNew <- read.csv("csv/pm0_4.csv", sep=",")  # 1500
quart <- read.csv("csv/tmb_folgen_6_8.csv", sep=",")
quart <- subset(quart, quart$count>0)
quart <- quart[,c('year','davg', 'dext')]
quart$dmod <- (quart$davg + quart$dext) / 2.0

piAll <- read.csv("csv/p_1000_2018.csv", sep=",", na = "NA")
piSummer <- rollapply(piAll$precipitation, width=3, by=1, FUN=sum)
piAll$piSummer <- piAll$precipitation
piAll$piSummer[3:length(piAll$precipitation)] <- piSummer/3.0
piAllSummer <- subset(piAll, piAll$month==8)

piOld <- subset(piAllSummer, piAllSummer$year<1500)
piOld <- piOld[,c('year', 'piSummer')]

old <- merge(quart,piOld, by=c("year"))
old <- old[,c('davg', 'dext', 'dmod', 'piSummer')]
new <- merge(quart,piNew, by=c("year"))
new <- new[,c('davg', 'dext', 'dmod', 'pavg', 'pext', 'pm2')]

library(psych)
pairs.panels(new)
pairs.panels(old)


paper<-F                   # output on paper (=TRUE) or screen (=FALSE)
file.name<-'ICES stock summary'             # graphical output file if paper<-TRUE
Portrait<-F                 # graphical output orientation
include.terminal.year <- F          # plot terminal year as well?
first.year<- 1963                #first year on plot, negative value means value defined by data
last.year<- 2007                 #last year on plot
incl.M2.plot<-T

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

cleanup()

if (paper) dev<-"wmf" else dev<-"screen"
nox<-1; noy<-1;
noxy<-nox*noy

ref<-Read.reference.points()

Init.function()

dat<-Read.summary.data(extend=include.terminal.year,read.init.function=F)

# by length
d<-subset(dat, Lsea>0 &Lsea<600 & Species %in% c('Cod','Haddock','Whiting','Herring','Sandeel','Nor. pout'))
sort(unique(d$Lsea))
step<-3
d$size<-trunc(d$Lsea/step/10)*step
sort(unique(d$Lsea))

a<-tapply(d$BIO,list(d$Species,d$size),sum,na.r=T)/sum(d$BIO,na.rm=T)*100
a[is.na(a)]<-0
rs<-rowSums(a,na.rm=T)
b<-a[rs>0,]
barplot(b,main='Biomass, all years, all quarters combined',ylab='%',xlab='Length(cm)',col=rainbow(10), legend = rownames(b), )

# by weight
d<-subset(dat, west>0  & Species %in% c('Cod','Haddock','Whiting','Herring','Sandeel','Nor. pout'))

step<-1
d$size<-trunc(log(d$west)/step)*step

a<-tapply(d$BIO,list(d$Species,d$size),sum,na.r=T)/sum(d$BIO,na.rm=T)*100
a[is.na(a)]<-0
rs<-rowSums(a,na.rm=T)
b<-a[rs>0,]
barplot(b,main='Biomass, all years, all quarters combined',ylab='%',xlab='log(weight)',col=rainbow(10), legend = rownames(b), )

# by weight all species
d<-subset(dat, west>0 )

step<-1
d$size<-trunc(log(d$west)/step)*step

a<-tapply(d$BIO,list(d$Species,d$size),sum,na.r=T)/sum(d$BIO,na.rm=T)*100
a[is.na(a)]<-0
rs<-rowSums(a,na.rm=T)
b<-a[rs>0,]
barplot(b,main='Biomass, all years, all quarters combined',ylab='%',xlab='log(weight)',col=rainbow(10), legend = rownames(b), )


  convert.degmin2degdec = function (x, y=NULL, vnames=c("lon", "lat") ) {
    xlon = x[,vnames[1]]
    xlat = x[,vnames[2]]
    if (is.null(y)) {
      x[,vnames[1]] = trunc(xlon) + round((xlon - trunc(xlon)) /60 * 100, 6)
      x[,vnames[2]] = trunc(xlat) + round((xlat - trunc(xlat)) /60 * 100, 6)
    } else {
      if (y=="lon") x = - (trunc(x/100)+(x-100*trunc(x/100))/60)
      if (y=="lat") x = trunc(x /100)+(x - 100*trunc(x /100))/60
    }
    return (x)
  }


# loading DIFSLIKAx.TXT files
DIFSLIKA <- vector("list", 251)

for (i in 1:100) {
  str_path = paste("Desktop/master/input", i, "/DIFSLIKA.TXT", sep = "")
  temp_data_frame <- read.table(str_path, quote="\"", comment.char="")
  DIFSLIKA[[i]] <- temp_data_frame
}

for (i in 1:151) {
  str_path = paste0("Desktop/new_cluster/input", i, "/DIFSLIKA.TXT")
  temp_data_frame <- read.table(str_path, quote = "\"", comment.char = "")
  DIFSLIKA[[i + 100]] <- temp_data_frame
}

# normalization
for (i in 1:251) {
  max_val <- max(DIFSLIKA[[i]]$V3)
  DIFSLIKA[[i]]$V3 <- DIFSLIKA[[i]]$V3 / max_val
}

# transforming indexes
for (i in 1:251) {
  DIFSLIKA[[i]]$V1 <- (DIFSLIKA[[i]]$V1 + 10000) / 100 + 1
  DIFSLIKA[[i]]$V2 <- (DIFSLIKA[[i]]$V2 + 10000) / 100 + 1
}

# creating matrices
IMG_MAT <- vector("list", 251)

for (i in 1:251) {
  IMG_MAT[[i]] <- matrix(, 201, 201)
  for (j in 1:nrow(DIFSLIKA[[i]])) {
    IMG_MAT[[i]][DIFSLIKA[[i]][j, 1], DIFSLIKA[[i]][j, 2]] <- DIFSLIKA[[i]][j, 3]
  }
}

# load images
data_images <- array(, dim = c(251, 201, 201))

for (i in 1:251) {
  data_images[i, , ] <- IMG_MAT[[i]]
}

data_x <- array(, dim = c(251, 102))
for (i in 1:251) {
  data_x[i, 1:101] <- data_images[i, 101, 101:201]
}

for (i in 1:251) {

  if (data_x[i, 1] > data_x[i, 2])
    count_zero_diff <- 1
  else
    count_zero_diff <- 0

  for (j in 2:100) {
    if (data_x[i, j] > data_x[i, j - 1] && data_x[i, j] > data_x[i, j + 1])
      count_zero_diff <- count_zero_diff + 1
  }

  data_x[i, 102] <- count_zero_diff
}


# load in useful packages
library(tidyverse)
library(forcats)
library(lubridate)
library(stringr)
library(patchwork)
library(scales)
library(ggrepel)
setwd('/Users/Yaxuan/Github/stat-215-final/csi-pecarn-rule-vetting/rulevetting/projects/csi_pecarn/')
rm(list = ls())

data_0 = read.csv('notebooks/figs/nonsense.csv')

data <- read.csv('notebooks/figs/2-5vlist.csv') %>%
  filter(TPR < 0.96) %>%
  bind_rows(data_0)
p = data %>%
  ggplot(aes(x = FPR, y = TPR)) +
  geom_point() +
  geom_line() +
  geom_text_repel(aes(label = variable)) +
  geom_hline(yintercept = 0.95, linetype = 'dashed', color = 'red')+
  xlim(0,1) + ylim(0,1) +
  xlab('Fasle Possitive Rate (1 - Specificity)') +
  ylab('True Possitive Rate (Sensitivity)') +
  ggtitle("2 <= Age < 5")+
  theme_bw()
p
ggsave(p, filename = 'notebooks/figs/2-5vlist.pdf', height = 3, width = 4)

data <- read.csv('notebooks/figs/2-vlist.csv') %>%
  filter(FPR < 0.86) %>%
  bind_rows(data_0)
p = data %>%
  ggplot(aes(x = FPR, y = TPR)) +
  geom_point() +
  geom_line() +
  geom_text_repel(aes(label = variable)) +
  geom_hline(yintercept = 0.95, linetype = 'dashed', color = 'red')+
  xlim(0,1) + ylim(0,1) +
  xlab('Fasle Possitive Rate (1 - Specificity)') +
  ylab('True Possitive Rate (Sensitivity)') +
  ggtitle("Age < 2")+
  theme_bw()
ggsave(p, filename = 'notebooks/figs/2-vlist.pdf', height = 3, width = 4)

data <- read.csv('notebooks/figs/5-12vlist.csv') %>%
  filter(TPR < 0.96) %>%
  bind_rows(data_0)
p = data %>%
  ggplot(aes(x = FPR, y = TPR)) +
  geom_point() +
  geom_line() +
  geom_text_repel(aes(label = variable)) +
  geom_hline(yintercept = 0.95, linetype = 'dashed', color = 'red')+
  xlim(0,1) + ylim(0,1) +
  xlab('Fasle Possitive Rate (1 - Specificity)') +
  ylab('True Possitive Rate (Sensitivity)') +
  ggtitle("5 <= Age < 12")+
  theme_bw()
ggsave(p, filename = 'notebooks/figs/5-12vlist.pdf', height = 3, width = 4)

data <- read.csv('notebooks/figs/12+vlist.csv') %>%
  filter(TPR < 0.98) %>%
  bind_rows(data_0)
p = data %>%
  ggplot(aes(x = FPR, y = TPR)) +
  geom_point() +
  geom_line() +
  geom_text_repel(aes(label = variable)) +
  geom_hline(yintercept = 0.95, linetype = 'dashed', color = 'red')+
  xlim(0,1) + ylim(0,1) +
  xlab('Fasle Possitive Rate (1 - Specificity)') +
  ylab('True Possitive Rate (Sensitivity)') +
  ggtitle(" Age >= 12")+
  theme_bw()
ggsave(p, filename = 'notebooks/figs/12+vlist.pdf', height = 3, width = 4)


## Eduwin Pakpahan <epakpahan@gmail.com>

if(require(haven)) {
  require(rms)

  d <- read_dta("pakpahan.dta")

  fit <- cph(Surv(data_dftime, data_demfu) ~ data_age, method="breslow", data=d,
             surv=TRUE, x=T, y=T, time.inc=1200)
  print(fit)

  cal <- calibrate(fit, u=1200, B=120)
  plot(cal, subtitles=FALSE)

  cal_KM <- calibrate(fit, cmethod='KM', u=1200, m=10, B=40)

  plot(cal_KM, add=TRUE)
}


####----This code works for replicate 1 under scenario II, lines that need to be
####----modified to run another replicate/scenario are commented accordingly

#setwd("")

#--To read genotypes

#replace "Pop1_qtl_001.txt" by "Pop1_qtl_00j.txt", j=2,3,4 to run another replicate

QTL1=read.table("Pop1_qtl_001.txt",header=FALSE)
QTL1=as.matrix(QTL1[,-1])
QTL.Matrix=function(QTL){
	template=seq(1,ncol(QTL)-1,2)
	A=matrix(0,nrow=nrow(QTL),ncol=ncol(QTL))
	for(i in 1:nrow(QTL)){
		for(j in template){
			A[i,j]=QTL[i,j]+QTL[i,j+1]-3
			        }
			     }
	A=A[,template]
	return(A)
				}

#replace "Pop1_data_001.txt" by "Pop1_data_00j.txt", j=2,3,4 to run another replicate
data1=read.table("Pop1_data_001.txt",header=T)

W=QTL.Matrix(QTL=QTL1)
nloci=ncol(W)

#########################################################
###-----Create training and testing population-----######
#########################################################

data1.Training=data1[-which(data1$G==3), ]
W.Train=W[-which(data1$G==3), ]
n.train=nrow(W.Train)

data1.Test=data1[which(data1$G==3),]

###############################################################
########---Functions to build the adjacency matrices----#######
###############################################################

Adj=function(Nodes,nloci){
	library(Matrix)
	Adj=as(matrix(0,nrow=nloci,ncol=nloci),"dgTMatrix")
	for(i in 1:nrow(Nodes)){
		Adj[Nodes[i,1],Nodes[i,2]]=1
                              }
	return(Adj)
			       }

######################################################################
####----------Auxiliary function to be used later----------------#####
######################################################################

Def.Graph.Band=function(band.size,nloci){
      win.size=band.size-1
	size=band.size*(nloci-band.size+1)+sum(seq(2,max(band.size-1,2),1))-nloci+1
	Connect.nodes=matrix(nrow=size,ncol=2)
      template=sort(rep(seq(1,nloci-win.size,1),win.size))
      for(i in 0:(nloci-win.size-1)){
      	Connect.nodes[which(template==i+1),2]=seq(2+i,2+i+win.size-1,1)
      	seq(2+i,2+i+win.size-1,1)
                                     }
      Connect.nodes[1:length(template),1]=template
      counter=seq(2,max(2,win.size-1),1)
      links=list(rep(NA,win.size-1))
      for(i in 1:(win.size-1)){
		links[[i]]=rep(nloci-i,i)
                             }
	Connect.nodes[(length(template)+1):size,1]=sort(do.call(c,links),decreasing=FALSE)
	links2=list(rep(NA,win.size-1))
      for(i in 1:(win.size-1)){
		links2[[i]]=seq(nloci-win.size+i+1,nloci,1)
                             }
	Connect.nodes[(length(template)+1):size,2]=do.call(c,links2)
      return(list(Connect.nodes,size))
                                        }

#######################################
###---Grouping data by families----####
#######################################

Sires.Order=matrix(sort(data1.Training$Sire))
Number.Sires=1 ##Stars in 1 to count 0, i.e., unknown sire
Temp=matrix(-1,nrow=nrow(Sires.Order))
for(i in 1:(nrow(Sires.Order)-1)){
                         if(Sires.Order[i]!=Sires.Order[i+1]){
                                            Number.Sires=Number.Sires+1
                                            Temp[i]=Sires.Order[i+1]
                                                              }
                                  }

f=Number.Sires

Sires.List=matrix(c(0,Temp[which(Temp!=-1)])) ##Does include 0 which means unknown sire, these are grouped as founders
length(Sires.List)

templ=list(rep(NA,f))
for(i in 1:f){
            templ[[i]]=matrix(which(data1.Training$Sire==Sires.List[i]))
              }

sizes=matrix(0,nrow=f)
for(i in 1:f){sizes[i]=length(templ[[i]])}

column=list(rep(NA,f))
for(i in 1:f){column[[i]]=matrix(rep(i,sizes[i]))}
column=do.call(rbind,column)

#-Col1=Family member position, Col2=Original Family code, Col3=Consecutive family code
template=cbind(do.call(rbind,templ),Sires.Order,column)

#################################
#####----Define Omega0-----######
#################################

####-----Randomly setting  zeros------####

library(BDgraph)

Rand.Sparse=function(nloci,thrsld,delta,U,seed){
      Nodes=Def.Graph.Band(band.size=nloci,nloci=nloci)[[1]]
       set.seed(250)
	  matrix=rwish(n=1,p=nloci,b=nloci+1,D=diag(nloci))
	   matrix=matrix(matrix,nrow=nloci,byrow=TRUE)
	    tmp1=cbind(Nodes,as.matrix(matrix[lower.tri(matrix)]))
	     nonzeros=tmp1[which(abs(tmp1[,3])>thrsld),1:2] ##--Nodes
	     sparsity.pct=100*(nrow(nonzeros)/(nloci*(nloci-1)/2))
	     Adja=Adj(Nodes=nonzeros,nloci=nloci)
	   set.seed(seed)
	  Omega=round(rgwish(n=1,adj.g=Adja,b=delta,D=U),8)
	 Omega=matrix(Omega,nrow=nloci,byrow=TRUE)
      return(list(Omega,nonzeros,sparsity.pct))
                                              }

thrsld=35
U=diag(nloci)

SparseSample=Rand.Sparse(nloci=nloci,thrsld=thrsld,delta=10,U=U,seed=40)
Omega0=SparseSample[[1]]
Init.sparse=SparseSample[[3]]

#####################################
#####---Function to run CSCS---######
#####################################

CSCS2 = function(S, n, lambda, L=NULL, maxitr=100, tol=1e-4, warmstart=FALSE) {

  #### inputs
  ## Y: n by p matrix of data
  ## lambda: l1-penalty parameter
  ## maxitr: maximum number of iterations allowed (diagonal/off-diagonal optimization)
  ## tol: if maximum difference of iterates is less than tol, consider converged
  ## warmstart: warmstarting actually made the runs slower (overhead may be too expensive)

  #### outputs
  ## L: lower triangular matrix of cholesky factor computed with CSCS algorithm
  ## itr_log: (p-1)-vector of number of iterations
  ## eps_log: (p-1)-vector of number maximum difference for considering convergence

  p = ncol(S)

  if (is.null(L)) L = diag(p)

  itr_log = eps_log = NULL

  L[1, 1] = 1/sqrt(S[1,1])
  for (k in 2:p){ ## Loop in Algorithm 2

    ## nu_k vector (equation 2.5)
    nuk_old = nuk_new = c(rep(0, k-1), 1)
    r = 0

    repeat {      ## Loop in Algorithm 1

      r = r + 1

      km1_ = 1:(k-1)    ## 1, ..., k-1 is off-diagonal elements indices

      ## Update off-diagonal terms
      hk = lassoshooting(XtX    =  S[km1_, km1_, drop=FALSE],
			 Xty    = -nuk_old[k] * S[km1_, k],
			 lambda =  0.5*lambda)
      nuk_new[km1_] = hk$coefficients

      ## Update diagonal term
      sumterm = sum(nuk_new[km1_] * S[k, km1_])
      nuk_new[k] = (-sumterm + sqrt(sumterm^2 + 4*S[k, k]))/(2*S[k, k])

      ## Check convergence
      maxdiff = max(abs(nuk_new - nuk_old))
      if (maxdiff < tol || r >= maxitr){
	L[k, 1:k] = nuk_new
	eps_log = c(eps_log, maxdiff)
	itr_log = c(itr_log, r)
	break
      } else {
	nuk_old = nuk_new
      }
    }
  }

  list(L=L, itr=itr_log, eps=eps_log)

}

####################################################################################
########---Function implementing the combination of EM algorithm and CSCS----#######
####################################################################################

Bibi.GEMDAG=function(y,W,Omega0,res.var0,epsilon=1e-04,Maxiter=100,template,sizes,rho=0.01,thr=0.001){
	library(glasso)
      library(Matrix)
      library(lassoshooting)
	N=length(y)
      f=max(template[ ,3])
	nloci=ncol(W)
      npos=nloci*(nloci+1)*0.5
	iter=0

	Omega=as.matrix(Omega0)
      SIGMA=chol2inv(chol(Omega))
	res.var=res.var0
      delta=epsilon*2
      Im=diag(nloci)

    while(epsilon<delta && iter< Maxiter){
      Oldres.var = res.var
      OldOmega=Omega
	Sg.sum=matrix(0,nrow=nloci,ncol=nloci)
	trace=0
      inner=0
	    Block=list(rep(NA,f))

###---Expectation step, Using Formula 1

	for(i in 1:f){
		indices = template[which(template[,3]==i),1]
            WindSig = W[indices, ]%*%SIGMA
		Vinv=chol2inv(chol((WindSig)%*%t(W[indices, ])+(diag(sizes[i])*res.var)))
            Block[[i]]=Vinv
		summand=SIGMA%*%(Im - (t(W[indices, ])%*%(Vinv-crossprod(t(y[indices])%*%Vinv)))%*%WindSig)
		Sg.sum=Sg.sum+summand
		       }

	Sg.expect=Sg.sum/f
      Vin=as.matrix(bdiag(Block))
	inner.res.expect=as.numeric(res.var*(N-res.var*(sum(diag(Vin))-crossprod(Vin%*%y))))

##---Maximization step

	res.var=inner.res.expect/N
	run=CSCS2(S=Sg.expect, n=N, lambda=rho, L=NULL, maxitr=50, tol=thr)
      Omega=crossprod(run$L)
      SIGMA=tcrossprod(solve(run$L))

##---Evaluate convergence

	delta=(npos*mean(abs(Omega-OldOmega))+abs(Oldres.var-res.var))/(npos+1)

	iter=iter+1

                                     } #end of the while loop

      print(iter)
	if(delta>epsilon){print("Convergence criteria was not met")}
      Omega=as.matrix(Omega)
      SIGMA=as.matrix(SIGMA)
      L=as.matrix(run$L)
      Nodes=Def.Graph.Band(band.size=nloci,nloci=nloci)[[1]]
      tmp1=cbind(Nodes,as.matrix(Omega[lower.tri(Omega)]))
	nonzeros=tmp1[which(abs(tmp1[,3])>0),1:2] ##--i.e.Nodes
	sparsity.pct=100*(nrow(nonzeros)/(nloci*(nloci-1)/2))

	 	return(list(Omega,res.var,iter,delta,sparsity.pct,nonzeros,SIGMA,L))

}

###################################################################################################
###################################################################################################
####----------------------------SOLVING MME TO GET g_hat---------------------------------##########
###################################################################################################
###################################################################################################

Solve.MME=function(y,W,OMEGA,Resvar){
	RHS=crossprod(W,y)
	LHS=crossprod(W)+Resvar*OMEGA
	ghat=solve(LHS)%*%RHS
	return(ghat)
                                   }

lambda.grid=matrix(seq(0.002,0.004,length.out=15))
#lambda.grid=matrix(seq(0.0028,0.0045,length.out=15)) #use this for scenario 2

library(mvtnorm)
n.Train=nrow(W.Train)
Wt=t(W.Train)
W.Test=W[which(data1$G==4), ]

F=function(lambda){
 Run=Bibi.GEMDAG(y=data1.Training$Phen,W=W.Train,Omega0=Omega0,res.var0=93.23,epsilon=0.001,Maxiter=50,template=template,
  sizes=sizes,rho=lambda,thr=0.001)
   OMEGA=Run[[1]]
    SIGMA=Run[[7]]
     ghat=Solve.MME(y=data1.Training$Phen,W=W.Train,OMEGA=OMEGA,Resvar=Run[[2]])
      PredBVTrainGEMB=W.Train%*%ghat
       PredBVTestGEMB=W.Test%*%ghat
        Predabil.GB=cor(data1.Test$Phen,as.numeric(PredBVTestGEMB),method="pearson")
         corrBVGB=cor(data1.Test$QTL,as.numeric(PredBVTestGEMB),method="pearson")
         corrBVTrainGB=cor(data1.Training$QTL,as.numeric(PredBVTrainGEMB),method="pearson")
        V=as.matrix(forceSymmetric(W.Train%*%(SIGMA%*%Wt)+diag(Run[[2]],n.Train)))
       tuning.criteriaLIK=dmvnorm(data1.Training$Phen, mean = rep(0, n.Train), sigma = V, log = TRUE)
      tuning.criteriaBIC=-2*tuning.criteriaLIK+log(n.Train)*nrow(Run[[6]])
     tuning.criteriaRES=sum((data1.Test$Phen-as.numeric(PredBVTestGEMB))^2)
   PAR1=matrix(c(tuning.criteriaBIC,tuning.criteriaLIK,tuning.criteriaRES,Predabil.GB,
  corrBVGB,corrBVTrainGB,as.numeric(Run[[5]])))
 return(list(PAR1,Run[[6]],Run[[8]]))
}

Out=apply(lambda.grid,1,F)

summary.tune=matrix(nrow=length(lambda.grid),ncol=8)
summary.tune[,1]=lambda.grid
for(i in 1:length(lambda.grid)){summary.tune[i,2:8]=Out[[i]][[1]]}
selected.graphLIK=Out[[which.max(summary.tune[,3])]][[2]]
selected.graphSPARSITY=Out[[8]][[2]]
selected.graphBIC=Out[[which.min(summary.tune[,2])]][[2]]
selected.graphRES=Out[[which.min(summary.tune[,4])]][[2]]
selected.graphPA=Out[[which.max(summary.tune[,5])]][[2]]

#################################################################################################
#############-------------------------Saving outputs---------------------########################
#################################################################################################

#-In the following lines replace "1" by "j", j=2,3,4 when runninganother replicate
#-In addition, add "II" at the end of each file's name when running scenario 2.

write.table(summary.tune,row.names=FALSE,col.names=c("Lambda","BIC","LIK","RES","PA","ACCV","ACCT","SPARSITY"),
file="Tuning1IIDAG.csv",sep=",")

write.table(selected.graphBIC,row.names=FALSE,col.names=FALSE,file="EdgesBICDAG1.csv",sep=",")

write.table(selected.graphLIK,row.names=FALSE,col.names=FALSE,file="EdgesLIKDAG1.csv",sep=",")

write.table(selected.graphRES,row.names=FALSE,col.names=FALSE,file="EdgesRESDAG1.csv",sep=",")

write.table(selected.graphSPARSITY,row.names=FALSE,col.names=FALSE,file="EdgesSPADAG1.csv",sep=",")

write.table(selected.graphPA,row.names=FALSE,col.names=FALSE,file="EdgesPADAG1.csv",sep=",")

###################################################################################################
############-----Save the 15 DAGS (only in scenario 2)---------####################################
###################################################################################################

#-Saving these 15 files is only necessary for scenario 2 because Bayes DAG-Sel only works when n>m
#-In the following line, replace "GRAPH1" by "GRAPHj", j=2,3,4 when analyzing another replicate.

# for(i in 1:length(Out)){
#   write.table(as.matrix(Out[[i]][[3]]),row.names=FALSE,col.names=FALSE,file=paste("DAG1II",toString(i),".txt",sep=" "))
# }

################################################################
################################################################
######---Evaluating the performance of graph selection-----#####
################################################################
################################################################

####-----Randomly setting  zeros------####

Rand.Sparse=function(nloci,thrsld,delta,U,seed1,seed2){
      Nodes=Def.Graph.Band(band.size=nloci,nloci=nloci)[[1]]
       set.seed(seed2)
	  matrix=rwish(n=1,p=nloci,b=nloci+1,D=diag(nloci))
	   matrix=matrix(matrix,nrow=nloci,byrow=TRUE)
	    tmp1=cbind(Nodes,as.matrix(matrix[lower.tri(matrix)]))
	     nonzeros=tmp1[which(abs(tmp1[,3])>thrsld),1:2] ##--Nodes1
	      Adja=Adj(Nodes=nonzeros,nloci=nloci)
	      set.seed(seed1)
	     Omega=round(rgwish(n=1,adj.g=Adja,b=delta,D=U),4)
          Omega=matrix(Omega,nrow=nloci,byrow=TRUE)
         tmp2=cbind(Nodes,as.matrix(Omega[lower.tri(Omega)]))
        nonzeros2=tmp2[which(abs(tmp2[,3])>0),1:2] ##--Nodes2
       sparsity.pct=100*(nrow(nonzeros2)/(nloci*(nloci-1)/2))
      return(list(Omega,nonzeros2,sparsity.pct))
}

nloci=300
thrsld=35
U=diag(nloci)

##--In the following line

##--For scenario 1 use:
##--seed1=40, seed2=250 for replicate 1
##--seed1=20, seed2=250 for replicate 2
##--seed1=10, seed2=250 for replicate 3
##--seed1=50, seed2=250 for replicate 4

##--For scenario 2 use:
##--seed1=500, seed2=2500 for replicate 1
##--seed1=501, seed2=2500 for replicate 2
##--seed1=502, seed2=2500 for replicate 3
##--seed1=600, seed2=2500 for replicate 4

Om1=Rand.Sparse(nloci=nloci,thrsld=thrsld,delta=10,U=U,seed1=40,seed2=250)

############################################
####---Get true adjacency matrices----######
############################################

Adj1=Adj(Nodes=Om1[[2]],nloci)
Adj1=as.matrix(Adj1[upper.tri(Adj1)])

####--The following lines have to be run each time tha Adj.hat is defined

############################################
##---Get estimated adjacency matrices---####
############################################

Adj.hat=Adj(selected.graphLIK,nloci)
Adj.hat=as.matrix(Adj.hat[upper.tri(Adj.hat)])

Adj.hat=Adj(selected.graphSPARSITY,nloci)
Adj.hat=as.matrix(Adj.hat[upper.tri(Adj.hat)])

Adj.hat=Adj(selected.graphPA,nloci)
Adj.hat=as.matrix(Adj.hat[upper.tri(Adj.hat)])

Adj.hat=Adj(selected.graphBIC,nloci)
Adj.hat=as.matrix(Adj.hat[upper.tri(Adj.hat)])

Adj.hat=Adj(selected.graphRES,nloci)
Adj.hat=as.matrix(Adj.hat[upper.tri(Adj.hat)])

###----Differences---#####

Dif=as.matrix(Adj1-Adj.hat)

####----Computing measures of performance----#######
P.template=which(Adj1==1)
P=length(P.template)
N.template=which(Adj1==0)
N=length(N.template)
TN=length(which(Adj.hat[N.template]==0))
N=nrow(Adj1)-P
TP=length(which(Adj.hat[P.template]==1))
FP=N-TN
FN=P-TP
Sensitivity=TP/P
Specificity=TN/N
FPR=FP/N
RCCCP=length(which(Dif==0))/length(Dif)

####---The following part requires setting the tuned values of the penalty parameter "rho"
####---which correspond to objects selected.graphLIK, selected.graphSPARSITY,
####---selected.graphBIC, selected.graphRES and selected.graphPA defined above.

#############################################################
####---Comparisson with true concentration matrix------######
#############################################################

SPA=Bibi.GEMDAG(y=data1.Training$Phen,W=W.Train,Omega0=Omega0,res.var0=83.36,epsilon=0.001,Maxiter=50,template=template,
sizes=sizes,rho=0.0027,thr=0.001)

PA=Bibi.GEMDAG(y=data1.Training$Phen,W=W.Train,Omega0=Omega0,res.var0=83.36,epsilon=0.001,Maxiter=50,template=template,
sizes=sizes,rho=0.004,thr=0.001)

RES=LIK=PA #--This is so because in this particular case the three approaches selected the same graph.

NORM.DIFFSPA=norm(SPA[[1]]-Om1[[1]],type="F")/norm(Om1[[1]],type="F")
NORM.DIFFPA=norm(PA[[1]]-Om1[[1]],type="F")/norm(Om1[[1]],type="F")

##################################################
############----Save estimated Omega-----#########
##################################################

write.table(SPA[[1]],row.names=FALSE,col.names=FALSE,file="OmegaHatSPA1.csv",sep=",")
write.table(PA[[1]],row.names=FALSE,col.names=FALSE,file="OmegaHatPA1.csv",sep=",")