###### multiple response LARS (single combined)
##TODO: Need to make # of folds a parameter exposed to used
library(lars)

lars.multi.optimize <- function(tdata,rdata,pert,prior,allowed)
{
	cat(as.character(Sys.time()),"\n")
	lars.paths.cv <- lars.multi.cv(tdata,rdata,pert,prior,allowed,10)

	lars.paths <- lars.multi(tdata,rdata,pert,prior,allowed)
	B <- lars.multi.path.step(lars.paths,lars.paths.cv[[2]])

	B.adj <- matrix(0,nrow=dim(rdata)[1],ncol=dim(tdata)[1])

	for (i in seq(dim(tdata)[1]))
	{
		#Scale B.adj according to prior
		B.adj[,i] <- B[[i]] * prior[,i]
	}
	rval <- list()
	rval[[1]] <- B.adj
	rval[[2]] <- lars.paths
	rval[[3]] <- lars.paths.cv
	cat(as.character(Sys.time()),"\n")
	rval
}

lars.multi.cv <- function(tdata,rdata,pert,prior,allowed,fold)
{
	all.folds <- cv.folds(dim(tdata)[2], fold)
	lars.cv.paths <- list()
	cMax <- 0;
	for (f in 1:fold)
	{
		cat("Building path for cv",f,"of",fold,"\n")
		omit <- all.folds[[f]]
		lars.cv.paths[[f]] <- lars.multi(tdata[,-omit], rdata[,-omit], pert[,-omit],prior,allowed)
		if (lars.cv.paths[[f]]$R[1,1]>cMax)
		{
			cMax <- lars.cv.paths[[f]]$R[1,1]
		}

	}

	cSteps <- c()
	mse <- c()
	bnorm <- c()

	converged <- FALSE
	P <- c(cMax/10,0)
	FP <- c(lars.multi.cv.eval(P[1],fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed),lars.multi.cv.eval(P[2],fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed))

	while (!converged)
	{
		Imin <- which.min(FP)
		Imax <- which.max(FP)
		if (Imin==Imax)
			converged=TRUE

		cat("P:",P,"F(P):",FP,"Max/Min",Imax,Imin,"\n")
		Phat <- P[Imin]
		Pref <- 2*Phat - P[Imax]

		if (Pref>cMax)
			FPref <- max(FP) + (Pref-cMax)^2
		else if (Pref<0)
			FPref <- max(FP) + Pref^2
		else
			FPref <- lars.multi.cv.eval(Pref,fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed)

			if (FPref < FP[Imin])
			{
				#Attempt expansion
				Pexp <- 2*Pref - Phat
				FPexp <- lars.multi.cv.eval(Pexp,fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed)
				if (FPexp < FPref) #Expand
				{
					cat("Expand\n")
					P[Imax] <- Pexp
					FP[Imax] <- FPexp
				}
				else #Reflect
				{
					cat("Reflect\n")
					P[Imax] <- Pref
					FP[Imax] <- FPref
				}
			}
			else
			{
				#Contract
				if (FP[Imax] < FPref)
				{
					cat("Contract (1)\n")
					P[Imax] <- (P[Imax] + Phat)/2
					FP[Imax] <- lars.multi.cv.eval(P[Imax],fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed)
				}
				else
				{
					cat("Contract (2)\n")
					P[Imax] <- (Pref + Phat)/2
					FP[Imax] <- lars.multi.cv.eval(P[Imax],fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed)
				}
			}
	}
	rval <- list()
	rval[[1]] <- lars.cv.paths
	rval[[2]] <- P[which.min(FP)]
	rval[[3]] <- min(FP)
	rval[[4]] <- all.folds
	rval
}

lars.multi.cv.eval <- function(cVal,fold,lars.cv.paths,all.folds,tdata,rdata,pert,prior,allowed,targets=NULL)
{
		if (is.null(targets))
			targets <- seq(dim(tdata)[1])
		mse <- rep(0,times=fold)
		for (f in 1:fold)
		{
			B <- lars.multi.path.step(lars.cv.paths[[f]],cVal)
			for (i in targets)
			{
				omit <- all.folds[[f]]
				omit <- setdiff(omit,which(pert[i,]!=0))

				testx <- rdata[,omit]
				testy <- tdata[i,omit]
				testx[which(allowed[,i]==0),] <- 0
				testx <- testx * prior[,i]

				testp <- scale(t(testx) , lars.cv.paths[[f]][[i]]$meanx, FALSE) %*% matrix(B[[i]]) + lars.cv.paths[[f]][[i]]$mu
				testr <- apply((testp - testy)^2,2,mean)
				mse[f] <- mse[f] + testr
			}
			mse[f] <- mse[f]/length(targets)
		}
		totalmse <- sum(mse) / fold
		totalmse
}

lars.multi <- function(tdata,rdata,pert,prior,allowed)
{
	lars.paths <- list()
	targets <- seq(dim(tdata)[1])

	cat("Building path for target: ")
	for (i in targets)
	{
		cat(i,"")
		mindices <- which(pert[i,]==0)

		x <- rdata[,mindices] * prior[,i]
		x[which(allowed[,i]==0),]<-0;

		##### YK patch 05-23-2017
		# results.lars <- lars(t(x),tdata[i,mindices],trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,use.Gram=FALSE);
		y <- tdata[i,mindices];
		results.lars.flag <- TRUE;
		sample.indx <- length(y);
		while (results.lars.flag) {
			results.lars <- try(lars(t(x[,1:sample.indx]),y[1:sample.indx],trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,use.Gram=FALSE));
			results.lars.flag <- class(results.lars) =='try-error';
			if (results.lars.flag) { cat(' *no soln* '); }
			sample.indx <- sample.indx-1;
		}
		#####
		lars.paths[[i]] <- list(beta=results.lars$beta, mu=results.lars$mu, meanx=results.lars$meanx, C.Max=c(results.lars$C.Max,0))
	}
	cat("\n")

	cat("Building combined C.Max ranking\n")
	all.C.lars <- c()
	for (i in targets)
	{
		all.C.lars <- rbind(all.C.lars, cbind(lars.paths[[i]]$C.Max,rep(i,times=length(lars.paths[[i]]$C.Max)),1:length(lars.paths[[i]]$C.Max)))
	}
	R <- all.C.lars[sort.list(all.C.lars[,1],decreasing=TRUE),]
	lars.paths$R <- R
	lars.paths$targets <- targets
	lars.paths
}

lars.multi.path.step <- function(lars.paths,stepC)
{
	k <- 1
	if (length(which(lars.paths$R[,1]>stepC))>0)
	{
		k<-max(which(lars.paths$R[,1]>stepC))
	}

	B <- list()
	A <- c()
	Ai <- unique(lars.paths$R[1:k,2])
	for (i in Ai)
	{
		A <- rbind(A,c(i,lars.paths$R[max(which(lars.paths$R[1:k,2]==i)),3]))
	}

	for (i in lars.paths$targets)
	{
		indx <- which(A[,1]==i)
		if (length(indx)==0)
		{
			B[[i]] <- rep(0,times=dim(lars.paths[[i]]$beta)[2])
		}
		else
		{
			plen <- dim(lars.paths[[i]]$beta)[1]
			if (A[indx,2]==plen)
			{
				B[[i]] <- lars.paths[[i]]$beta[plen,]
			}
			else
			{
				if ( lars.paths$R[k,1] < lars.paths[[i]]$C.Max[A[indx,2]+1] )
				{
					if (A[indx,2] < plen)
						A[indx,2] <- A[indx,2] + 1
				}
				gamma <- (lars.paths[[i]]$C.Max[A[indx,2]] - lars.paths$R[k,1]) / (lars.paths[[i]]$C.Max[A[indx,2]] - lars.paths[[i]]$C.Max[A[indx,2]+1])
				u <- (lars.paths[[i]]$beta[A[indx,2]+1,] - lars.paths[[i]]$beta[A[indx,2],])
				B[[i]] <- lars.paths[[i]]$beta[A[indx,2],] + u * gamma
			}
		}
	}
	B
}

###

lars.multi.cv.singlefold <- function(tdata,rdata,pert,prior,allowed,fold,seed,f)
{
	set.seed(seed)
	all.folds <- cv.folds(dim(tdata)[2], fold)
	cat("Building path for cv",f,"of",fold,"\n")
	omit <- all.folds[[f]]
	lars.cv.paths <- lars.multi(tdata[,-omit], rdata[,-omit], pert[,-omit],prior,allowed)
	lars.cv.paths
}

lars.single.cv <- function(tdata,rdata,pert,prior,allowed,fold,seed)
{
	targets <- seq(dim(tdata)[1])
	lars.paths.cv <- list()
	lars.paths <- list()
	B <- matrix(0,nrow=dim(rdata)[1],ncol=dim(tdata))

	minFrac <- c()
  cat("Building path for target: ")
  for (i in targets)
  {
    cat(i,"")
    mindices <- which(pert[i,]==0)
    x <- rdata[,mindices] * prior[,i]
    x[which(allowed[,i]==0),]<-0;
    set.seed(seed)
    lars.paths.cv[[i]] <-  cv.lars(t(x),tdata[i,mindices],K=fold,plot.it=FALSE,trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,se=FALSE);
		minFrac[i] <- lars.paths.cv[[i]]$index[which.min(lars.paths.cv[[i]]$cv)]
		lars.paths[[i]] <- lars(t(x),tdata[i,mindices],trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE);
		B[,i] <- predict(lars.paths[[i]],s=minFrac[i],type="coefficients",mode="fraction")$coefficients
  }
	cat("\n")
	B
}

## Parallel functionality
lars.multi.cv.eval.parallel <- function(cVal)
{
	mse <- 0;
	B <- lars.multi.path.step(cv.obj,cVal)
	for (i in targets)
	{
		omit <- all.folds[[f]]
		omit <- setdiff(omit,which(pert[i,]!=0))

		testx <- rdata[,omit]
		testy <- tdata[i,omit]
		testx[which(allowed[,i]==0),] <- 0
		testx <- testx * prior[,i]

		testp <- scale(t(testx) , cv.obj[[i]]$meanx, FALSE) %*% matrix(B[[i]]) + cv.obj[[i]]$mu
		testr <- apply((testp - testy)^2,2,mean)
		mse <- mse + testr
	}
	mse <- mse/length(targets)
	mse
}

lars.multi.cv.cmax.parallel <- function()
{
	cat(cv.obj$R[1,1],"\n")
	cv.obj$R[1,1]
}

lars.multi.cv.parallel <- function()
{
	cMax <- max(as.numeric(mpi.remote.exec(lars.multi.cv.cmax.parallel())))
	cat("cMax: ", cMax, "\n")
	converged <- FALSE
	P <- c(cMax/10,0)

	FP <- c(mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,P[1]))),mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,P[2]))))

	while (!converged)
	{
		Imin <- which.min(FP)
		Imax <- which.max(FP)
		if (Imin==Imax)
			converged=TRUE

		cat("P:",P,"F(P):",FP,"Max/Min",Imax,Imin,"\n")
		Phat <- P[Imin]
		Pref <- 2*Phat - P[Imax]

		if (Pref>cMax)
			FPref <- max(FP) + (Pref-cMax)^2
		else if (Pref<0)
			FPref <- max(FP) + Pref^2
		else
			FPref <- mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,Pref)))

			if (FPref < FP[Imin])
			{
				#Attempt expansion
				Pexp <- 2*Pref - Phat
				FPexp <- mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,Pexp)))
				if (FPexp < FPref) #Expand
				{
					cat("Expand\n")
					P[Imax] <- Pexp
					FP[Imax] <- FPexp
				}
				else #Reflect
				{
					cat("Reflect\n")
					P[Imax] <- Pref
					FP[Imax] <- FPref
				}
			}
			else
			{
				#Contract
				if (FP[Imax] < FPref)
				{
					cat("Contract (1)\n")
					P[Imax] <- (P[Imax] + Phat)/2
					FP[Imax] <- mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,P[Imax])))
				}
				else
				{
					cat("Contract (2)\n")
					P[Imax] <- (Pref + Phat)/2
					FP[Imax] <- mean(as.numeric(mpi.remote.exec(cmd=lars.multi.cv.eval.parallel,P[Imax])))
				}
			}
	}

	cat(P[which.min(FP)],min(FP),"\n")

	P[which.min(FP)]
}

lars.multi.optimize.parallel <- function()
{
	cat(as.character(Sys.time()),"\n")
	c.cvmin <- lars.multi.cv.parallel()

	lars.paths <- lars.multi(tdata,rdata,pert,prior,allowed)
	B <- lars.multi.path.step(lars.paths,c.cvmin)

	B.adj <- matrix(0,nrow=dim(rdata)[1],ncol=dim(tdata)[1])

	for (i in seq(dim(tdata)[1]))
	{
		#Scale B.adj according to prior
		B.adj[,i] <- B[[i]] * prior[,i]
	}
	rval <- list()
	rval[[1]] <- B.adj
	rval[[2]] <- lars.paths
	cat(as.character(Sys.time()),"\n")
	rval
}

lars.local <- function(tdata,rdata,pert,prior,allowed,skip_reg,skip_gen)
{
  cat(as.character(Sys.time()),"\n")
  B.adj <- matrix(0,nrow=dim(rdata)[1],ncol=dim(tdata)[1])

  cat("Working on Gene:")
	for(i in 1:dim(tdata)[1]) {
		if (skip_gen[i] == 0) {
		 	cat(i,",")
			mindices <- which(pert[i,]==0)
			x <- rdata[,mindices] * prior[,i]
			x[which(allowed[,i]==0),]<-0;
			nindices <- which(skip_reg==0)
			x <- x[nindices,]
			lars.paths.cv <-  cv.lars(t(x),tdata[i,mindices],K=3,trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,se=FALSE, plot.it=FALSE,use.Gram=FALSE);
			minFrac <- lars.paths.cv$index[which.min(lars.paths.cv$cv)]
			lars.paths <- lars(t(x),tdata[i,mindices],trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,use.Gram=FALSE);
			# lars.paths <- lars(t(x),tdata[i,mindices],trace=FALSE,max.steps=600,type="lasso",normalize=FALSE,intercept=TRUE,use.Gram=TRUE);
			tempVec <- predict(lars.paths,s=minFrac,type="coefficients",mode="fraction")$coefficients
			# tempVec <- lars.paths$beta
			# print(tempVec)
			nindices <- which(skip_reg==1)
      tempCol <- c(tempVec, rep(0,length(nindices)))
      tempIndices <- c(seq_along(tempVec), nindices+.5)
      B.adj[,i] <- tempCol[order(tempIndices)]
      #Scale B.adj according to prior
			B.adj[,i] <- B.adj[,i] * prior[,i]
		}
	}
	cat("\n")

	rval <- list()
  rval[[1]] <- B.adj
  rval
}


###### 19. COMPARE MAFS ACROSS STRATEGIES (COMPLETE ONLY) ########
#### DO STEPS 1-4, IRRESPECTIVE OF TREE, THEN PROCEED
iden <- which(rowSums(prPAM_g2[,-c(1:2)]) > 5)
ssp<-coordinates(prPAM_g2[iden,1:2])
f <- clean_coordinates(as.data.frame(ssp), lon = "LON",lat = "LAT",
                       tests="seas",species=NULL,value="flagged",seas_scale = 110)

#### NULL 2 #####
load("~/Desktop/NATURE_rev/RES_SAcomplete_v3/WeightedMAFS.RData")
MAFcrown_SA <- MDT_crown
MAFstem_SA <- MDT_stem
MAFfuse_SA <- MDT_fuse_non
load("~/Desktop/NATURE_rev/RES_SAcomplete_v3/ MDT_crown_NULL2.Rdata")
null_crown <- MDT_crown_NULL2
SES_crownMAF_SA <- (MAFcrown_SA - apply(null_crown[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_crown[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SAcomplete_v3/ MDT_stem_NULL2.Rdata")
null_stem <- MDT_stem_NULL2
SES_stemMAF_SA <- (MAFstem_SA - apply(null_stem[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_stem[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SAcomplete_v3/ MDT_fuse_non_NULL2.Rdata")
null_fuse <- MDT_fuse_non_NULL2
SES_fuseMAF_SA <- (MAFfuse_SA - apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))

load("~/Desktop/NATURE_rev/RES_SBcomplete_v3/WeightedMAFS.RData")
MAFcrown_SB <- MDT_crown
MAFstem_SB <- MDT_stem
MAFfuse_SB <- MDT_fuse_non
load("~/Desktop/NATURE_rev/RES_SBcomplete_v3/ MDT_crown_NULL2.Rdata")
null_crown <- MDT_crown_NULL2
SES_crownMAF_SB <- (MAFcrown_SB - apply(null_crown[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_crown[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SBcomplete_v3/ MDT_stem_NULL2.Rdata")
null_stem <- MDT_stem_NULL2
SES_stemMAF_SB <- (MAFstem_SB - apply(null_stem[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_stem[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SBcomplete_v3/ MDT_fuse_non_NULL2.Rdata")
null_fuse <- MDT_fuse_non_NULL2
SES_fuseMAF_SB <- (MAFfuse_SB - apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))

load("~/Desktop/NATURE_rev/RES_SDcomplete_v3/WeightedMAFS.RData")
MAFcrown_SD <- MDT_crown
MAFstem_SD <- MDT_stem
MAFfuse_SD <- MDT_fuse_non
load("~/Desktop/NATURE_rev/RES_SDcomplete_v3/ MDT_crown_NULL2.Rdata")
null_crown <- MDT_crown_NULL2
SES_crownMAF_SD <- (MAFcrown_SD - apply(null_crown[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_crown[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SDcomplete_v3/ MDT_stem_NULL2.Rdata")
null_stem <- MDT_stem_NULL2
SES_stemMAF_SD <- (MAFstem_SD - apply(null_stem[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_stem[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SDcomplete_v3/ MDT_fuse_non_NULL2.Rdata")
null_fuse <- MDT_fuse_non_NULL2
SES_fuseMAF_SD <- (MAFfuse_SD - apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))

pdf("~/Desktop/NATURE_rev/2.MAF_null2_comparison_strategies.pdf",useDingbats = F)
plot(MAFcrown_SB[f],MAFcrown_SA[f],xlim=c(30,120),ylim=c(30,120),type="n",xlab="Relaxed Calibration (RC)",ylab="Constrained Calibration (CC)")
abline(a=0,b=1)
points(MAFcrown_SB[f],MAFcrown_SA[f],pch=21,bg="blue",cex=0.8)
title("MAF crown")
plot(MAFcrown_SB[f],MAFcrown_SD[f],xlim=c(30,120),ylim=c(30,120),type="n",xlab="Relaxed Calibration (RC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(MAFcrown_SB[f],MAFcrown_SD[f],pch=21,bg="blue",cex=0.8)
title("MAF crown")
plot(MAFcrown_SA[f],MAFcrown_SD[f],xlim=c(30,120),ylim=c(30,120),type="n",xlab="Constrained Calibration (CC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(MAFcrown_SA[f],MAFcrown_SD[f],pch=21,bg="blue",cex=0.8)
title("MAF crown")

plot(MAFstem_SB[f],MAFstem_SA[f],xlim=c(60,180),ylim=c(60,180),type="n",xlab="Relaxed Calibration (RC)",ylab="Constrained Calibration (CC)")
abline(a=0,b=1)
points(MAFstem_SB[f],MAFstem_SA[f],pch=21,bg="red",cex=0.8)
title("MAF stem")
plot(MAFstem_SB[f],MAFstem_SD[f],xlim=c(60,180),ylim=c(60,180),type="n",xlab="Relaxed Calibration (RC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(MAFstem_SB[f],MAFstem_SD[f],pch=21,bg="red",cex=0.8)
title("MAF stem")
plot(MAFstem_SA[f],MAFstem_SD[f],xlim=c(60,180),ylim=c(60,180),type="n",xlab="Constrained Calibration (CC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(MAFstem_SA[f],MAFstem_SD[f],pch=21,bg="red",cex=0.8)
title("MAF stem")

plot(SES_crownMAF_SB[f],SES_crownMAF_SA[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Relaxed Calibration (RC)",ylab="Constrained Calibration (CC)")
abline(a=0,b=1)
points(SES_crownMAF_SB[f],SES_crownMAF_SA[f],pch=21,bg="blue",cex=0.8)
title("SES MAF crown (NULL 2)")
plot(SES_crownMAF_SB[f],SES_crownMAF_SD[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Relaxed Calibration (RC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_crownMAF_SB[f],SES_crownMAF_SD[f],pch=21,bg="blue",cex=0.8)
title("SES MAF crown (NULL 2)")
plot(SES_crownMAF_SA[f],SES_crownMAF_SD[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Constrained Calibration (CC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_crownMAF_SA[f],SES_crownMAF_SD[f],pch=21,bg="blue",cex=0.8)
title("SES MAF crown (NULL 2)")

plot(SES_stemMAF_SB[f],SES_stemMAF_SA[f],xlim=c(-10,5),ylim=c(-10,5),type="n",xlab="Relaxed Calibration (RC)",ylab="Constrained Calibration (CC)")
abline(a=0,b=1)
points(SES_stemMAF_SB[f],SES_stemMAF_SA[f],pch=21,bg="red",cex=0.8)
title("SES MAF stem (NULL 2)")
plot(SES_stemMAF_SB[f],SES_stemMAF_SD[f],xlim=c(-10,5),ylim=c(-10,5),type="n",xlab="Relaxed Calibration (RC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_stemMAF_SB[f],SES_stemMAF_SD[f],pch=21,bg="red",cex=0.8)
title("SES MAF stem (NULL 2)")
plot(SES_stemMAF_SA[f],SES_stemMAF_SD[f],xlim=c(-10,5),ylim=c(-10,5),type="n",xlab="Constrained Calibration (CC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_stemMAF_SA[f],SES_stemMAF_SD[f],pch=21,bg="red",cex=0.8)
title("SES MAF stem (NULL 2)")

plot(SES_fuseMAF_SB[f],SES_fuseMAF_SA[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Relaxed Calibration (RC)",ylab="Constrained Calibration (CC)")
abline(a=0,b=1)
points(SES_fuseMAF_SB[f],SES_fuseMAF_SA[f],pch=21,bg="green",cex=0.8)
title("SES fuse (NULL 2)")
plot(SES_fuseMAF_SB[f],SES_fuseMAF_SD[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Relaxed Calibration (RC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_fuseMAF_SB[f],SES_fuseMAF_SD[f],pch=21,bg="green",cex=0.8)
title("SES fuse (NULL 2)")
plot(SES_fuseMAF_SA[f],SES_fuseMAF_SD[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Constrained Calibration (CC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_fuseMAF_SA[f],SES_fuseMAF_SD[f],pch=21,bg="green",cex=0.8)
title("SES fuse (NULL 2)")

dev.off()
###########

##### NULL 1 ######
load("~/Desktop/NATURE_rev/RES_SAcomplete_v3/WeightedMAFS.RData")
MAFcrown_SA <- MDT_crown
MAFstem_SA <- MDT_stem
MAFfuse_SA <- MDT_fuse_non
load("~/Desktop/NATURE_rev/RES_SAcomplete_v3/ MDT_crown_NULL1.Rdata")
null_crown <- MDT_crown_NULL2
SES_crownMAF_SA <- (MAFcrown_SA - apply(null_crown[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_crown[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SAcomplete_v3/ MDT_stem_NULL1.Rdata")
null_stem <- MDT_stem_NULL2
SES_stemMAF_SA <- (MAFstem_SA - apply(null_stem[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_stem[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SAcomplete_v3/ MDT_fuse_non_NULL1.Rdata")
null_fuse <- MDT_fuse_non_NULL2
SES_fuseMAF_SA <- (MAFfuse_SA - apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))

load("~/Desktop/NATURE_rev/RES_SBcomplete_v3/WeightedMAFS.RData")
MAFcrown_SB <- MDT_crown
MAFstem_SB <- MDT_stem
MAFfuse_SB <- MDT_fuse_non
load("~/Desktop/NATURE_rev/RES_SBcomplete_v3/ MDT_crown_NULL1.Rdata")
null_crown <- MDT_crown_NULL2
SES_crownMAF_SB <- (MAFcrown_SB - apply(null_crown[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_crown[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SBcomplete_v3/ MDT_stem_NULL1.Rdata")
null_stem <- MDT_stem_NULL2
SES_stemMAF_SB <- (MAFstem_SB - apply(null_stem[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_stem[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SBcomplete_v3/ MDT_fuse_non_NULL1.Rdata")
null_fuse <- MDT_fuse_non_NULL2
SES_fuseMAF_SB <- (MAFfuse_SB - apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))

load("~/Desktop/NATURE_rev/RES_SDcomplete_v3/WeightedMAFS.RData")
MAFcrown_SD <- MDT_crown
MAFstem_SD <- MDT_stem
MAFfuse_SD <- MDT_fuse_non
load("~/Desktop/NATURE_rev/RES_SDcomplete_v3/ MDT_crown_NULL1.Rdata")
null_crown <- MDT_crown_NULL2
SES_crownMAF_SD <- (MAFcrown_SD - apply(null_crown[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_crown[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SDcomplete_v3/ MDT_stem_NULL1.Rdata")
null_stem <- MDT_stem_NULL2
SES_stemMAF_SD <- (MAFstem_SD - apply(null_stem[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_stem[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))
load("~/Desktop/NATURE_rev/RES_SDcomplete_v3/ MDT_fuse_non_NULL1.Rdata")
null_fuse <- MDT_fuse_non_NULL2
SES_fuseMAF_SD <- (MAFfuse_SD - apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=mean,na.rm=T))/(apply(null_fuse[,-c(1:2)],MARGIN=1,FUN=sd,na.rm=T))

pdf("~/Desktop/NATURE_rev/2.MAF_null1_comparison_strategies.pdf",useDingbats = F)
plot(MAFcrown_SB[f],MAFcrown_SA[f],xlim=c(30,120),ylim=c(30,120),type="n",xlab="Relaxed Calibration (RC)",ylab="Constrained Calibration (CC)")
abline(a=0,b=1)
points(MAFcrown_SB[f],MAFcrown_SA[f],pch=21,bg="blue",cex=0.8)
title("MAF crown")
plot(MAFcrown_SB[f],MAFcrown_SD[f],xlim=c(30,120),ylim=c(30,120),type="n",xlab="Relaxed Calibration (RC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(MAFcrown_SB[f],MAFcrown_SD[f],pch=21,bg="blue",cex=0.8)
title("MAF crown")
plot(MAFcrown_SA[f],MAFcrown_SD[f],xlim=c(30,120),ylim=c(30,120),type="n",xlab="Constrained Calibration (CC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(MAFcrown_SA[f],MAFcrown_SD[f],pch=21,bg="blue",cex=0.8)
title("MAF crown")

plot(MAFstem_SB[f],MAFstem_SA[f],xlim=c(60,180),ylim=c(60,180),type="n",xlab="Relaxed Calibration (RC)",ylab="Constrained Calibration (CC)")
abline(a=0,b=1)
points(MAFstem_SB[f],MAFstem_SA[f],pch=21,bg="red",cex=0.8)
title("MAF stem")
plot(MAFstem_SB[f],MAFstem_SD[f],xlim=c(60,180),ylim=c(60,180),type="n",xlab="Relaxed Calibration (RC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(MAFstem_SB[f],MAFstem_SD[f],pch=21,bg="red",cex=0.8)
title("MAF stem")
plot(MAFstem_SA[f],MAFstem_SD[f],xlim=c(60,180),ylim=c(60,180),type="n",xlab="Constrained Calibration (CC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(MAFstem_SA[f],MAFstem_SD[f],pch=21,bg="red",cex=0.8)
title("MAF stem")

plot(SES_crownMAF_SB[f],SES_crownMAF_SA[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Relaxed Calibration (RC)",ylab="Constrained Calibration (CC)")
abline(a=0,b=1)
points(SES_crownMAF_SB[f],SES_crownMAF_SA[f],pch=21,bg="blue",cex=0.8)
title("SES MAF crown (NULL 1)")
plot(SES_crownMAF_SB[f],SES_crownMAF_SD[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Relaxed Calibration (RC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_crownMAF_SB[f],SES_crownMAF_SD[f],pch=21,bg="blue",cex=0.8)
title("SES MAF crown (NULL 1)")
plot(SES_crownMAF_SA[f],SES_crownMAF_SD[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Constrained Calibration (CC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_crownMAF_SA[f],SES_crownMAF_SD[f],pch=21,bg="blue",cex=0.8)
title("SES MAF crown (NULL 1)")

plot(SES_stemMAF_SB[f],SES_stemMAF_SA[f],xlim=c(-10,5),ylim=c(-10,5),type="n",xlab="Relaxed Calibration (RC)",ylab="Constrained Calibration (CC)")
abline(a=0,b=1)
points(SES_stemMAF_SB[f],SES_stemMAF_SA[f],pch=21,bg="red",cex=0.8)
title("SES MAF stem (NULL 1)")
plot(SES_stemMAF_SB[f],SES_stemMAF_SD[f],xlim=c(-10,5),ylim=c(-10,5),type="n",xlab="Relaxed Calibration (RC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_stemMAF_SB[f],SES_stemMAF_SD[f],pch=21,bg="red",cex=0.8)
title("SES MAF stem (NULL 1)")
plot(SES_stemMAF_SA[f],SES_stemMAF_SD[f],xlim=c(-10,5),ylim=c(-10,5),type="n",xlab="Constrained Calibration (CC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_stemMAF_SA[f],SES_stemMAF_SD[f],pch=21,bg="red",cex=0.8)
title("SES MAF stem (NULL 1)")

plot(SES_fuseMAF_SB[f],SES_fuseMAF_SA[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Relaxed Calibration (RC)",ylab="Constrained Calibration (CC)")
abline(a=0,b=1)
points(SES_fuseMAF_SB[f],SES_fuseMAF_SA[f],pch=21,bg="green",cex=0.8)
title("SES fuse (NULL 1)")
plot(SES_fuseMAF_SB[f],SES_fuseMAF_SD[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Relaxed Calibration (RC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_fuseMAF_SB[f],SES_fuseMAF_SD[f],pch=21,bg="green",cex=0.8)
title("SES fuse (NULL 1)")
plot(SES_fuseMAF_SA[f],SES_fuseMAF_SD[f],xlim=c(-5,10),ylim=c(-5,10),type="n",xlab="Constrained Calibration (CC)",ylab="Unconstrained Calibration (UC)")
abline(a=0,b=1)
points(SES_fuseMAF_SA[f],SES_fuseMAF_SD[f],pch=21,bg="green",cex=0.8)
title("SES fuse (NULL 1)")

dev.off()


#load environment
library(reshape2)
library(plyr)
options("scipen" = 10)

# functions
seq_order_fun  <- function(x) {
  seq_along(x)
}
to_numeric <- function(data, feature){
  data[[feature]] <- as.factor(data[[feature]])
  data[[feature]]<- mapvalues(data[[feature]], from=levels(data[[feature]]),
                              to = 1:length(levels(data[[feature]])))
  return(data)
}

dynamic_dt_prep <- function(data, seq_length, nm=nms){
  length_dst <- as.data.frame(table(data$sessionId))
  sequences_long <- subset(length_dst, Freq>=seq_length)$Var1
  dt_long <- subset(data, sessionId %in% sequences_long)
  dt_longg <- dt_long[,-c('accountId',nm[-1],'gcName'),with=F]
  dt_long <- ddply(dt_longg, .(sessionId), mutate, seq_order = seq_order_fun(sessionId))
  dt_long_frst <- subset(dt_long, seq_order<=seq_length)
  dt_long_frst <- as.data.table(dt_long_frst)
  for(i in c("gcCause", "gcAction")){
    dt_long_frst <- to_numeric(dt_long_frst, i)
  }
  suppressWarnings(for (i in seq_along(dt_long_frst)) set(dt_long_frst, i=which(dt_long_frst[[i]]==-1), j=i, value=0))
  dt_wide <- dcast.data.table(dt_long_frst, sessionId ~ seq_order, value.var=colnames(dt_long_frst)[-c(1,2,21)], fill=NaN)
  return(dt_wide)
}
#---------------------------------------------------------------------------------#

# gcoverhead calculation
dt$duration <- as.numeric(dt$duration)
dt$sessionId <- as.factor(dt$sessionId)
dt$timestamp <- as.numeric(dt$timestamp)
gc_overhead <- ddply(dt, .(sessionId), summarize, gc_overhead=sum(duration)/(max(timestamp)-min(timestamp)))
gc_overhead$gc_overhead <- ifelse(is.finite(gc_overhead$gc_overhead)!=T, 0, gc_overhead$gc_overhead)
gc_overhead <- subset(gc_overhead, gc_overhead<=1)

#  0     1
# 70597  9299

# labels
gc_overhead$label <- ifelse(gc_overhead$gc_overhead>=0.0065,1,0)
gc_overhead$index <- c(1:nrow(gc_overhead))
table(gc_overhead$label)

# static
sds <- aggregate(data=dt_sample, .~sessionId, sd)
colSums(sds[,-c(1)])
nms <- as.character(c("sessionId, javaVersion, cpuCoreCount, maxAvailableMemory, PSPermGenmaxbefore, PSOldGenmaxbefore, PSPermGenmaxafter, PSOldGenmaxafter"))
nms <- strsplit(nms, split = ", ")[[1]]

dt_static <- dt[,nms, with=F]
dt_static_agg <- dt_static[!duplicated(dt_static$sessionId), ]
dt_static <- merge(dt_static_agg, gc_overhead[,c(1,4)], by="sessionId")
dt_static$javaVersion <- ifelse(dt_static$javaVersion==1.7,1,2)
dt_static$PSPermGenmaxbefore <- ifelse(dt_static$PSPermGenmaxbefore==-1,0,dt_static$PSPermGenmaxbefore)
dt_static$PSPermGenmaxafter <- ifelse(dt_static$PSPermGenmaxafter==-1,0,dt_static$PSPermGenmaxafter)
dt_static_final <- dt_static[,-c(1,9),with=F]

# ToDO:
# labels based on gc_overhead for each session
# for each session data: all numeric?
# static and dynamic separate
# how many events to take?
# each session - one line, list all features for one timestamp, then for another timestamp, etc
dt_wide <- dynamic_dt_prep(dt, seq_length=10)
dt_wide <- merge(dt_wide, gc_overhead[,c(1,4)], by="sessionId")
dt_dynamic <- dt_wide[order(dt_wide$index, decreasing=F),]

# writing results
# check consistency
dim(as.data.frame(gc_overhead$label))
dim(dt_static_final)
dim(dt_dynamic)

write.table(as.data.frame(gc_overhead$label), "/Users/annaleontjeva/Desktop/My_files/Generative-Models-in-Classification/Data/labels_piper.txt",
            col.names=F, row.names=F, sep=',',quote=F)

write.table(dt_static_final, "/Users/annaleontjeva/Desktop/My_files/Generative-Models-in-Classification/Data/static_piper.txt",
            col.names=F, row.names=F, sep=',',quote=F)

write.table(dt_wide_filtered, "/Users/annaleontjeva/Desktop/My_files/Generative-Models-in-Classification/Data/dynamic_piper.txt",
            col.names=F, row.names=F, sep=',',quote=F)

#------------------------#
# Plots and figures
# Gc overhead
ggplot(gc_overhead, aes(x=gc_overhead)) + geom_histogram() + theme_bw(base_size=24)
ggplot(gc_overhead, aes(x=log(gc_overhead+0.000001, base=10))) + geom_density() + theme_bw(base_size=24)

tmp <- subset(length_dst, Freq>=10)
gc_overhead_tmp <- subset(gc_overhead, sessionId %in% tmp$Var1)
table(gc_overhead_tmp$label)

ggplot(gc_overhead_tmp, aes(x=log(gc_overhead+0.000001, base=10))) + geom_density() + theme_bw(base_size=24)

# 0    1
# 34 8451

# dynamic dataset
length_dst <- as.data.frame(table(dt$sessionId))
ggplot(length_dst, aes(x=log(Freq, base=10)))+geom_density()+theme_bw(base_size=24)
ggplot(gc_overhead_tmp, aes(x=gc_overhead)) + geom_histogram() + theme_bw(base_size=24)


'

The file "figure1_mortality.r" creates a figure, plotting
expropriation risk against settler mortality respectively.
It accounts for campaign/laborer indicators and distinguishes between
countries with original data and countries with conjectured mortality data.

'

rm(list=ls())

args = commandArgs(trailingOnly=TRUE)

library(foreign)

data <- read.csv(args[1])

## Rebuilding of Figures 2A and 2B

datacamp <- data[grep(1,data$campaign),] #mortality from campaign

data2 <- data[grep(0,data$campaign),]

databar <- data2[grep(0,data2$slave),] #mortality from barrack
datalab <- data2[grep(1,data2$slave),] #mortality from laborer

## Plot that data first against risk
datacamphome <- datacamp[grep(1,datacamp$source0),]
datacampcon <- datacamp[grep(0,datacamp$source0),]

databarhome <- databar[grep(1,databar$source0),]
databarcon <- databar[grep(0,databar$source0),]

datalabhome <- datalab[grep(1,datalab$source0),]
datalabcon <- datalab[grep(0,datalab$source0),]

png(filename=args[2])
plot(
     datacamphome$logmort0, datacamphome$risk, pch=15,
     xlab="Logarithm of settler mortality", ylab="Expropriation risk",
     ylim=c(3,10), xlim=c(2,8), bty="L"
)
lines(datacampcon$logmort0, datacampcon$risk, pch=22, type="p")

lines(databarhome$logmort0, databarhome$risk, pch=16, type="p")
lines(databarcon$logmort0, databarcon$risk, pch=21, type="p")

lines(datalabhome$logmort0, datalabhome$risk, pch=17, type="p")
lines(datalabcon$logmort0, datalabcon$risk, pch=2, type="p")

dev.off()


#' @export
bib_invert = function(x)
{
  storage.mode(x) = "double"
  .Call("bib_invert_", x)
}


#' Plots a given data.frame as a boxplot with optional subsets
#'
#' @param df         data.frame holding at least the columns specified by x, y, and label
#' @param x          Column to be plotted on the horizontal axis
#' @param y          Column to be plotted on the vertical axis
#' @param label      Column of label to be used for each sample; indicates subsets
#' @param quantiles  If `x="group"` quantiles will eb used to assign `up`, `down`, and `null`
#' @param drop       Whether to drop unused factor levels in `label`
box = function(df, x="group", y="y", label="label", quantiles=c(0.2,0.8), drop=TRUE) {
    df$group = st$map.quantiles(score, quantiles, c('down', 'null', 'up'))

    ggplot(df, aes_string(x="group", y="y")) +
        geom_point(aes_string(fill=label), position=position_jitter(width=.25),
            pch=21, size=3, colour="black") +
        geom_boxplot(fill="grey", outlier.shape = NA) +
        scale_fill_discrete(drop=drop) +
        scale_colour_discrete(drop=drop)
}


# Version info: R 2.14.1, Biobase 2.15.3, GEOquery 2.23.2, limma 3.10.1

################################################################
#   Differential expression analysis with limma
library(Biobase)
library(GEOquery)
library(limma)

# load series and platform data from GEO

gset <- getGEO("GSE15573", GSEMatrix =TRUE)
if (length(gset) > 1) idx <- grep("GPL6102", attr(gset, "names")) else idx <- 1
gset <- gset[[idx]]

# make proper column names to match toptable
fvarLabels(gset) <- make.names(fvarLabels(gset))

# group names for all samples
sml <- c("G1","G1","G0","G1","G0","G1","G0","G0","G1","G0","G0","G1","G0","G1","G1","G0","G1","G0","G1","G1","G0","G1","G0","G1","G1","G0","G0","G1","G1","G0","G1","G0","G1");

# log2 transform
ex <- exprs(gset)
qx <- as.numeric(quantile(ex, c(0., 0.25, 0.5, 0.75, 0.99, 1.0), na.rm=T))
LogC <- (qx[5] > 100) ||
          (qx[6]-qx[1] > 50 && qx[2] > 0) ||
          (qx[2] > 0 && qx[2] < 1 && qx[4] > 1 && qx[4] < 2)
if (LogC) { ex[which(ex <= 0)] <- NaN
  exprs(gset) <- log2(ex) }

# set up the data and proceed with analysis
fl <- as.factor(sml)
gset$description <- fl
design <- model.matrix(~ description + 0, gset)
colnames(design) <- levels(fl)
fit <- lmFit(gset, design)
cont.matrix <- makeContrasts(G1-G0, levels=design)
fit2 <- contrasts.fit(fit, cont.matrix)
fit2 <- eBayes(fit2, 0.01)
tT <- topTable(fit2, adjust="fdr", sort.by="B", number=250)

# load NCBI platform annotation
gpl <- annotation(gset)
platf <- getGEO(gpl, AnnotGPL=TRUE)
ncbifd <- data.frame(attr(dataTable(platf), "table"))

# replace original platform annotation
tT <- tT[setdiff(colnames(tT), setdiff(fvarLabels(gset), "ID"))]
tT <- merge(tT, ncbifd, by="ID")
tT <- tT[order(tT$P.Value), ]  # restore correct order

tT <- subset(tT, select=c("ID","adj.P.Val","P.Value","t","B","logFC","Gene.symbol","Gene.title"))
write.table(tT, file=stdout(), row.names=F, sep="\t")

################################################################
#   Boxplot for selected GEO samples
library(Biobase)
library(GEOquery)

# load series and platform data from GEO

gset <- getGEO("GSE15573", GSEMatrix =TRUE)
if (length(gset) > 1) idx <- grep("GPL6102", attr(gset, "names")) else idx <- 1
gset <- gset[[idx]]

# group names for all samples in a series
sml <- c("G1","G1","G0","G1","G0","G1","G0","G0","G1","G0","G0","G1","G0","G1","G1","G0","G1","G0","G1","G1","G0","G1","G0","G1","G1","G0","G0","G1","G1","G0","G1","G0","G1")

# order samples by group
ex <- exprs(gset)[ , order(sml)]
sml <- sml[order(sml)]
fl <- as.factor(sml)
labels <- c("control","case")

# set parameters and draw the plot
palette(c("#dfeaf4","#f4dfdf", "#AABBCC"))
dev.new(width=4+dim(gset)[[2]]/5, height=6)
par(mar=c(2+round(max(nchar(sampleNames(gset)))/2),4,2,1))
title <- paste ("GSE15573", '/', annotation(gset), " selected samples", sep ='')
boxplot(ex, boxwex=0.6, notch=T, main=title, outline=FALSE, las=2, col=fl)
legend("topleft", labels, fill=palette(), bty="n")


subFunc <- function(data.train=NULL, data.valid=NULL, data.eval=NULL,
                    method=NULL, meta=NULL, base=NULL,
                    yname.numeric=NULL, yname.nominal=NULL, xnames=NULL, xname=NULL, model_control=NULL) {
  if (is.null(method)) {
    if (!is.null(meta)) { method <- paste(meta, base, sep="+") } else { method <- base }
  } else {
    base <- method
  }

  pred.train <- pred.valid <- NULL

  if (grepl("UP", method)) {
    tryCatch({
      data.train[, xname]

    }, error = function(err){
      print(err)
      print(xname)
      browser()
    }
    )
    pred.train <- 10000/(data.train[, xname]+1) # why 10000?
    pred.valid <- 10000/(data.valid[, xname]+1)
  } else if (grepl("EALR",method)) {
    formula <- as.formula(paste(yname.numeric, paste(xnames, collapse="+"), sep="~"))
    # browser()
    model <- glm(formula=formula, data=data.train, family=gaussian)
    try(model <- step(model, k=log(nrow(data.train)), trace=FALSE), silent=TRUE)

    if (length(attr(model$terms, "term.labels"))>=2) {
      err <- try(model.vif <- max(car::vif(model)), silent=TRUE)
      if (class(err)!="try-error") {
        if (!is.na(model.vif)) {
          if (model.vif > 10) { cat("VIF of EALR model is larger than 10.\n") }
        }
      }
    }

    pred.train <- predict(model, new=data.train)
    tryCatch({
      pred.valid <- predict(model, new=data.valid)
    }, error = function(err){
      print(err)
      browser()
    }
    )

    step.xnames <- attr(model$terms, "term.labels")
    for (aname in step.xnames) {
      data.train[, aname] <- (data.train[, aname]-min(data.train[, aname]))/(max(data.train[, aname])-min(data.train[, aname]))
      data.valid[, aname] <- (data.valid[, aname]-min(data.valid[, aname]))/(max(data.valid[, aname])-min(data.valid[, aname]))
    }
  } else if (!is.null(meta)) {
    data.train[, yname.nominal] <- as.factor(data.train[, yname.nominal])
    formula <- as.formula(paste(yname.nominal, paste(xnames, collapse="+"), sep="~"))
    ########################################
    ### Ensemble methods
    ########################################
    WC <- getWekaClassifier(meta)
    BC <- getWekaClassifier(base)
    model <- WC(formula=formula, data=data.train, control=RWeka::Weka_control(W=BC))

    if (is.null(yname.numeric)) {
      pred.train <- predict(model, new=data.train, type="probability")[, "1"]
      pred.valid <- predict(model, new=data.valid, type="probability")[, "1"]
    } else {
      pred.train <- predict(model, new=data.train)
      pred.valid <- predict(model, new=data.valid)
    }
  } else {
    data.train[, yname.nominal] <- as.factor(data.train[, yname.nominal])
    formula <- as.formula(paste(yname.nominal, paste(xnames, collapse="+"), sep="~"))

    WC <- getWekaClassifier(base)
    model <- NULL
    if (method=="IBk") {
      model <- WC(formula=formula, data=data.train, control=RWeka::Weka_control(K=8))
    } else {
      model <- WC(formula=formula, data=data.train, control=model_control)
    }

    if (is.null(yname.numeric)) {
      pred.train <- predict(model, new=data.train, type="probability")[, "1"]
      pred.valid <- predict(model, new=data.valid, type="probability")[, "1"]
      # pred.train <- predict(model, new=data.train)
      # pred.valid <- predict(model, new=data.valid)
      # levels(pred.valid) <- c(0,1)
    } else {
      pred.train <- predict(model, new=data.train)
      pred.valid <- predict(model, new=data.valid)
    }
  }

  pred.train <- as.vector(pred.train)
  pred.valid <- as.vector(pred.valid)
  train.dt <- valid.dt <- NULL
  if (grepl("UP", method)) { # why "UP" method use different datasets than others.
    train.dt <- data.frame(NUM=data.eval$fbug.old, REL=data.eval$fbug.old, LOC=data.eval$churn.fit.old, PRE=pred.train)
    valid.dt <- data.frame(NUM=data.eval$ebug.old, REL=data.eval$ebug.old, LOC=data.eval$churn.est.old, PRE=pred.valid)
  } else {
    train.dt <- data.frame(NUM=data.eval$fbug, REL=data.eval$fbug, LOC=data.eval$churn.fit, PRE=pred.train)
    valid.dt <- data.frame(NUM=data.eval$ebug, REL=data.eval$ebug, LOC=data.eval$churn.est, PRE=pred.valid)
  }

  sorted           <- FALSE
  worstcase        <- TRUE  ### compute the worst performance for unsupervised models
  bestcase         <- FALSE
  LOCUP            <- FALSE
  allpercentcutoff <- TRUE
  sub.Popt <- sub.ACC <-sub.Prec.F1<- NULL
  if (grepl("UP", method)) {
    sub.Popt <- ComputePopt(sorted=sorted, data=valid.dt, worstcase=worstcase, bestcase=bestcase, LOCUP=LOCUP)
    sub.ACC <- ComputeACC(sorted=sorted, data=valid.dt, worstcase=worstcase, bestcase=bestcase, LOCUP=LOCUP)
    sub.Prec.F1 <- ComputePrecF1(sorted=sorted, data=valid.dt, worstcase=worstcase, bestcase=bestcase, LOCUP=LOCUP)
  } else {

    sub.Popt <- ComputePopt(sorted=sorted, data=valid.dt)
    sub.ACC <- ComputeACC(sorted=sorted, data=valid.dt)
    sub.Prec.F1 <- ComputePrecF1(sorted=sorted, data=valid.dt)
  }

  sub.Prec <- sub.Prec.F1$Prec
  sub.F1 <- sub.Prec.F1$F1
  if(grepl("_Sup",method)){
    method <- "OneR.UP"
  }
  names(sub.Popt) <- paste(method, "Popt", sep=".")
  names(sub.ACC) <- paste(method, "ACC", sep=".")
  names(sub.Prec) <-paste(method,"Prec", sep=".")
  names(sub.F1) <-paste(method,"F1", sep=".")
  return (list(Popt= sub.Popt, ACC=sub.ACC, Prec=sub.Prec, F1=sub.F1))

}


library(tidyr)
library(ggplot2)
library(shiny)
library(shinydashboard)
library(heatmaply)
library(GGally)
source("cleandata.r")
source("graphics.r")

title = tags$span(tags$img(src="favicon.png",
                        height = '50',
                        width = '50'),
              'Easy Viz')

header <- dashboardHeader(title = title, dropdownMenuOutput(outputId = "menu"))

sidebar <- dashboardSidebar(
  sidebarMenu(
    fileInput(inputId = "file", "Upload", multiple = TRUE),
    menuItem("Data", tabName = "data", icon = icon("database")),
    menuItem("Scatter Matrix", tabName = "scat", icon = icon("cloud")),
    menuItem("Heatmap", tabName = "heat", icon = icon("chess-board")),
    menuItem("Density", tabName = "dens", icon = icon("chart-line")),
    menuItem("Network", tabName = "net", icon = icon("sitemap")),
    menuItem("Built By", tabName = "bb", icon = icon("tools"))

  )
)

body <- dashboardBody(
  fluidRow(
    tabItems(

      tabItem(tabName = "data",
              fluidRow(infoBoxOutput(outputId = "IBdata", width = 10)),
              fluidRow(box(tableOutput(outputId = "tabledata"), width = 10))),
      tabItem(tabName = "scat",
              fluidRow(infoBoxOutput(outputId = "IBscat", width = 10)),
              fluidRow(box(plotOutput(outputId = "scatt"), width = 10))),
      tabItem(tabName = "heat",
              fluidRow(infoBoxOutput(outputId = "IBheat", width = 10)),
              fluidRow(box(plotOutput(outputId = "heatm2"), width = 10))),
      tabItem(tabName = "dens",
              fluidRow(infoBoxOutput(outputId = "IBdens", width = 10)),
              fluidRow(box(plotOutput(outputId = "densi"), width = 10))),
      tabItem(tabName = "net",
              fluidRow(infoBoxOutput(outputId = "IBnet", width = 10)),
              fluidRow(box(plotOutput(outputId = "netw"), width = 10))),
      tabItem(tabName = "bb",
              fluidRow(infoBoxOutput(outputId = "IBbb", width = 10)))

      )
    )
  )

ui <- dashboardPage(header, sidebar, body, skin = "black")

server <- function(input, output) {

  output$tabledata <- renderTable({
    file_to_read = input$file
    if(is.null(file_to_read)){
      return()
    }
    c = read.csv(file_to_read$datapath)
    cleanData(c)

  })

  output$scatt <- renderPlot({
    file_to_read = input$file
    if(is.null(file_to_read)){
      return()
    }
    df = read.csv(file_to_read$datapath)
    scattermatrix(df)
      })

  output$heatm2 <- renderPlot({
    file_to_read = input$file
    if(is.null(file_to_read)){
      return()
    }
    df = read.csv(file_to_read$datapath)
    df = cleanData(df)
    heatgraph(df)
  })

  output$densi <- renderPlot({
    file_to_read = input$file
    if(is.null(file_to_read)){
      return()
    }
    df = read.csv(file_to_read$datapath)
    densgraph(df)
  })

  output$netw <- renderPlot({
    file_to_read = input$file
    if(is.null(file_to_read)){
      return()
    }
    df = read.csv(file_to_read$datapath)
    net(df)
  })

  output$IBdata <- renderInfoBox({
    infoBox(title = "Data InfoBox",
            value = "Processing",
            subtitle = "Your cleaned Data. Keep all the numeric variables.",
            icon = shiny::icon("database"),
            fill = TRUE)
  })

  output$IBheat <- renderInfoBox({
    infoBox(title = "Heatmap InfoBox",
            value = "Correlation",
            subtitle = "Heatmap plot. Clearest cases shows the positive correlation between variables. Darkest cases shows negative correlation.",
            icon = shiny::icon("chess-board"),
            fill = TRUE)
  })

  output$IBscat <- renderInfoBox({
    infoBox(title = "Scatter InfoBox",
            value = "Distribution",
            subtitle = "Scatter Matrix plot. Visualise scatter plots of all your features.",
            icon = shiny::icon("cloud"),
            fill = TRUE)
  })

  output$IBdens <- renderInfoBox({
    infoBox(title = "Histogram InfoBox",
            value = "Distribution",
            subtitle = "Density plot. All your densities are plots one by one.",
            icon = shiny::icon("chart-line"),
            fill = TRUE)
  })

  output$IBnet <- renderInfoBox({
    infoBox(title = "Network InfoBox",
            value = "Connexion",
            subtitle = "Visualise the network and connexions of your variables in your data",
            icon = shiny::icon("sitemap"),
            color = 'orange',
            fill = TRUE)
  })

  output$IBbb <- renderInfoBox({
    infoBox(title = "Built By",
            value = "Issam Merikhi - 2021 - All right reserved",
            subtitle = "UDS - University of Strasbourg",
            icon = shiny::icon("tools"),
            color = 'green',
            href = "https://github.com/IssamMerikhi",
            fill = TRUE)
  })

}

shinyApp(ui, server)


#---------
#Title
#---------
#Respiratory control and thermal sensibility in benthic
#life stages of porcelain crab (Petrolisthes laevigatus).
#-----------------------------------------------

#---------
#Cleaning working space
rm(list=ls())
#Creator: 20160817 FPL
#Modifications: 20170408 CG
today<-format(Sys.Date(),"%Y%m%d")
#--------------------------------------------
#From Linux
# get working directory
setwd("D:/Dropbox/FL+WB/PELA/data")
# Cristóbal
#setwd("~/Insync/Laboratorio.Poblaciones.Marinas/Publicaciones/Plasticidad pela/analisis/datos")
getwd()     #verifico directorio
#----------------------------------------------

#-----------------------------------------------
#Libraries
#-----------------------------------------------
library(plotrix);library(ggplot2);library(nlme);
library(car);library(multcomp)
#-----------------------------------------------

#------------------------------------------------
#reading my data
#------------------------------------------------
pela<-read.csv("data.pela.csv", header=TRUE,
               sep=",",dec=".", strip.white=TRUE)
names(pela)
summary(pela)
str(pela)
#------------------------------------------------

#---------------------------------------------------------------------------
#Units for each explicative variable
#---------------------------------------------------------------------------
#dry_weight_g: individual dry weight,expressed in grams
#mo2: metabolic rate, expressed as mg O2 por hour per individual
#mo2.1: metabolic rate, expressed as mg O2 per hour per gram dry weight
#mo2.2: metabolic rate, expressed as mmol O2 per hour per gram dry weight
#mo2.3: metabolic rate, expressed as umol O2 per hour per gram dry weight
#mo2.4: metabolic rate, expressed as umol O2 por hour per individual
#---------------------------------------------------------------------------

#--------------------------------------------------------
#Transformation of variables wrongly assigned to numeric
#--------------------------------------------------------
pela$stage=as.factor(pela$stage)
pela$oxygen_mg=as.numeric(pela$oxygen_mg)
pela$saturation=as.numeric(pela$saturation)
pela$mo2=as.numeric(pela$mo2)
pela$temperature=as.factor(pela$temperature)
#--------------------------------------------------------

#--------------------------------------------------------
# Mean and standard deviation
#--------------------------------------------------------
mean1<-aggregate(cbind(mo2,mo2.1, mo2.2,mo2.3,mo2.4)~stage+oxygen_mg+saturation+kpa+temperature,data=pela, mean)
ds1<-aggregate(cbind(mo2,mo2.1, mo2.2,mo2.3,mo2.4)~stage+oxygen_mg+saturation+kpa+temperature,data=pela, sd)
datos<-merge(mean1,ds1,by=c("stage","oxygen_mg","saturation","kpa","temperature"))
names(datos)[6:15]<-c("mo2","mo2.1","mo2.2","mo2.3","mo2.4","mo2.sd","mo2.1.sd",
                      "mo2.2.sd","mo2.3.sd","mo2.4.sd")
#--------------------------------------------------------

#--------------------------------------------------------
# subset by stage
#--------------------------------------------------------
unique(pela$stage)
embrio<-subset(datos,datos$stage=="Embryo")
adult<-subset(datos,datos$stage=="Adult")
juvenil<-subset(datos,datos$stage=="Juvenile")
megalopa<-subset(datos,datos$stage=="Megalopae")
#--------------------------------------------------------

#--------------------------------------------------------
# Calculation of Q10 =(MR2/MR1)^(10/(T2-T1))
#--------------------------------------------------------
# Eggs
#--------------------------------------------------------
embq10<-with(embrio,data.frame(t6.12= (mo2.4[temperature==12]/mo2.4[temperature==6])^(10/(12-6)),
                               t6.18= (mo2.4[temperature==18]/mo2.4[temperature==6])^(10/(18-6)),
                               t12.18=(mo2.4[temperature==18]/mo2.4[temperature==12])^(10/(18-12)),
                               kpa6=kpa[temperature==6],
                               kpa12=kpa[temperature==12],
                               kpa18=kpa[temperature==18])
)
embq10$kpa.mean<- rowMeans(embq10[,c(4,5,6)], na.rm=TRUE)

#--------------------------------------------------------
#Megalopae
#--------------------------------------------------------
megaq10<-with(megalopa,data.frame(t6.12= (mo2.4[temperature==12]/mo2.4[temperature==6])^(10/(12-6)),
                                  t6.18= (mo2.4[temperature==18]/mo2.4[temperature==6])^(10/(18-6)),
                                  t12.18=(mo2.4[temperature==18]/mo2.4[temperature==12])^(10/(18-12)),
                                  kpa6=kpa[temperature==6],
                                  kpa12=kpa[temperature==12],
                                  kpa18=kpa[temperature==18])
)
megaq10$kpa.mean<- rowMeans(megaq10[,c(4,5,6)], na.rm=T)

#--------------------------------------------------------
#Juveniles
#--------------------------------------------------------
juvq10<-with(juvenil,data.frame(t6.12= (mo2.4[temperature==12]/mo2.4[temperature==6])^(10/(12-6)),
                                t6.18= (mo2.4[temperature==18]/mo2.4[temperature==6])^(10/(18-6)),
                                t12.18=(mo2.4[temperature==18]/mo2.4[temperature==12])^(10/(18-12)),
                                kpa6=kpa[temperature==6],
                                kpa12=kpa[temperature==12],
                                kpa18=kpa[temperature==18])
)
juvq10$kpa.mean<- rowMeans(juvq10[,c(4,5,6)], na.rm=TRUE)

#--------------------------------------------------------
# Adults at each oxygen level
#--------------------------------------------------------
aduq10<-with(adult,data.frame(t6.12= (mo2.4[temperature==12]/mo2.4[temperature==6])^(10/(12-6)),
                              t6.18= (mo2.4[temperature==18]/mo2.4[temperature==6])^(10/(18-6)),
                              t12.18=(mo2.4[temperature==18]/mo2.4[temperature==12])^(10/(18-12)),
                              kpa6=kpa[temperature==6],
                              kpa12=kpa[temperature==12],
                              kpa18=kpa[temperature==18])
)
aduq10$kpa.mean<- rowMeans(aduq10[,c(4,5,6)], na.rm=T)

#---------------------------------------------------------------------------------------------
# Q10 by stages, oxygen (kpa.mean) and delta temperature (DTemp)
#---------------------------------------------------------------------------------------------
Q10<-data.frame(stage= rep(c("Embryo", "Megalopae", "Juvenile", "Adult"),1,each=15),
                DTemp=rep(c(names(embq10)[1:3]),4,each=5),
                kpa.mean= rep(c(2.36, 4.72, 9.4, 14.2, 21.2),12,each=1),
                Q10= c(embq10[1:5,1], embq10[1:5,2], embq10[1:5,3],
                       megaq10[1:5,1], megaq10[1:5,2] ,megaq10[1:5,3],
                       juvq10[1:5,1], juvq10[1:5,2], juvq10[1:5,3],
                       aduq10[1:5,1], aduq10[1:5,2], aduq10[1:5,3])
)

Q10$stage<-as.factor(Q10$stage)
Q10$DTemp<-as.factor(Q10$DTemp)
#Q10$kpa.mean<-as.factor(Q10$kpa.mean)
#Full model
q10<-subset(Q10, !round(Q10,1)==20.4)
lcu<-with(q10,powerTransform(Q10~kpa.mean*DTemp,family="bcPower")$lambda)
q10=cbind(q10,bcPower(q10$Q10,lcu))
names(q10)[5]<-"bc"
# modelos
###############
lm1.1<-lm(bc~as.factor(kpa.mean)*stage, data=q10)
summary(lm1.1)
Anova(lm1.1)
AIC(lm1.1)
################
lm1<-lm(bc~kpa.mean*stage, data=q10)
summary(lm1)
Anova(lm1)
AIC(lm1)
################
lm.r<-lm(bc~kpa.mean*stage*DTemp, data=q10)
summary(lm.r)
AIC(lm1.1,lm1,lm.r)
Anova(lm.r)
# para respuesta a revisor
res1<-residuals(lm.r, type="pearson")
qqPlot(res1); shapiro.test(res1)
leveneTest(res1~stage*DTemp,data=q10)
# Los datos presentan distribución normal, el unico ruido lo provoca el outlier Q10=20 en adulto
# observo  dentro de etapas
lm.e<-lm(bc~kpa.mean*DTemp, data=subset(q10,stage=="Embryo"));
lm.m<-lm(bc~kpa.mean*DTemp, data=subset(q10,stage=="Megalopae"));
lm.j<-lm(bc~kpa.mean*DTemp, data=subset(q10,stage=="Juvenile"));
lm.a<-lm(bc~kpa.mean*DTemp, data=subset(q10,stage=="Adult"));
# anova embryos
res.e<-residuals(lm.e, type="pearson")
qqPlot(res.e); shapiro.test(res.e)
leveneTest(res.e~DTemp,data=subset(q10,stage=="Embryo"))
Anova(lm.e)
# anova megalopae
res.m<-residuals(lm.m, type="pearson")
qqPlot(res.m); shapiro.test(res.m)
leveneTest(res.m~DTemp,data=subset(q10,stage=="Megalopae"))
Anova(lm.m)
# anova juvenile
res.j<-residuals(lm.j, type="pearson")
qqPlot(res.j); shapiro.test(res.j)
leveneTest(res.j~DTemp,data=subset(q10,stage=="Juvenile"))
Anova(lm.j)
# anova adultos
res.a<-residuals(lm.a, type="pearson")
qqPlot(res.a); shapiro.test(res.a)
leveneTest(res.a~DTemp,data=subset(q10,stage=="Adult"))
Anova(lm.a)
library(lsmeans)
leastsquare = lsmeans(lm.a,pairwise ~ DTemp:kpa.mean)
leastsquare$contrasts
cld(leastsquare)

# observamos medias y medianas (no sensibles a outliers) por variables
# tensión de oxigeno
aggregate(Q10~kpa.mean,data=Q10,mean)
aggregate(Q10~kpa.mean,data=Q10,median)
# etapa
aggregate(Q10~stage,data=Q10,mean)
aggregate(Q10~stage,data=Q10,median)
#--------------------------------------------------------
#Graphics
#--------------------------------------------------------

################################
#END OF SCRIPT
################################
png(filename="Figure 4.png",width=5.8,height=5.5,units="in",res=600)

par(mfrow=c(2,2), tcl=-0.3, family="Arial", oma=c(2,2.2,0,0),frame.plot=FALSE)
omi=c(0.1,0.1,0,0)
# Embryos
par(mai=c(0.2,0.2,0.2,0.2))
# embryos
plot(t6.12~kpa.mean,data=embq10, pch=21,cex=1.4, xlab="",ylab=expression(paste(Q)[10]),
     xlim=c(0,25), ylim=c(0,5),yaxs="i",xaxs="i",xaxt="n",las=1,frame.plot=FALSE)
points(t6.18~kpa.mean,data=embq10, pch=21,bg="black", cex=1.4, ylim=c(0,5), xaxt="n")
points(t12.18~kpa.mean,data=embq10,pch=21,bg="gray", cex=1.4, ylim=c(0,5), xaxt="n")
axis(1, labels=F)
legend("topleft","Eggs",bty="n")
#Megalopae
plot(t6.12~kpa.mean,data=megaq10, pch=21, cex=1.4, xlab="",ylab=expression(paste(Q)[10]),
     xlim=c(0,25), ylim=c(0,5),yaxs="i",xaxs="i",xaxt="n",las=1,frame.plot=FALSE)
points(t6.18~kpa.mean,data=megaq10, pch=21,bg="black", cex=1.4, ylim=c(0,5), xaxt="n")
points(t12.18~kpa.mean,data=megaq10, pch=21, bg="gray",cex=1.4, ylim=c(0,5), xaxt="n")
axis(1, labels=F)
legend("topleft","Megalopae",bty="n")
#Juveniles
plot(t6.12~kpa.mean,data=juvq10, pch=21, cex=1.4, ylab=expression(paste(Q)[10]),
     xlim=c(0,25), ylim=c(0,5),yaxs="i",xaxs="i",las=1,frame.plot=FALSE)
points(t6.18~kpa.mean,data=juvq10, pch=21,bg="black", cex=1.4, ylim=c(0,5), xaxt="n")
points(t12.18~kpa.mean,data=juvq10, pch=21, bg="gray",cex=1.4, ylim=c(0,5), xaxt="n")
axis(1, labels=F)
legend("topleft","Juveniles",bty="n")
#Adults
# showing a X axis break
aduq10$t6.12.2<- ifelse(aduq10$t6.12< 8, aduq10$t6.12+10, aduq10$t6.12) #+1
yat<-pretty(aduq10$t6.12.2)
ylab <- ifelse(yat< 19, yat-10, yat) #-17 Y -1
plot(t6.12.2~kpa.mean,data=aduq10, cex=1.4,yaxt="n", ylim=c(10,24),xlim=c(0,25), yaxs="i",xaxs="i",ylab="", xlab="",frame.plot=FALSE)
axis(2, las=1, at=yat, labels=ylab)
axis.break(axis=2,breakpos=19,bgcol="white",breakcol="black", # 17
           style="slash",brw=0.02)
points(t6.18+10~kpa.mean,data=aduq10,cex=1.4,pch=21,bg="black",xaxt="n", ylim=c(20,30))
points(t12.18+10~kpa.mean,data=aduq10,cex=1.4,pch=21,bg="gray",xaxt="n", ylim=c(20,30))
axis(1, labels=F)
mtext("Oxygen tension (kPa)", side=1, outer=T, at=0.5,cex=1,line=1)
mtext(expression(paste(Q)[10]), side=2, outer=T, at=0.5,cex=1,line = 1)
legend("topleft","Adults",bty="n")
dev.off()
#------------------------------------
# plot version 2
#-----------------------------------
setwd("~/Insync/Laboratorio.Poblaciones.Marinas/Publicaciones/Plasticidad pela/analisis/Submission")
#png(filename="3.1.Thermal quotient V2 .png",width=7,height=7,units="in",res=600)

# panel 1  (Embriones)
par(mar=c(3,2,2,1), oma=c(2,2,1,2))
par(fig=c(0,5,6.6,9.9)/10)
plot(t6.12~kpa.mean,data=embq10, pch=21,cex=1.4, xlab="",ylab=expression(paste(Q)[10]),
     xlim=c(0,25), ylim=c(0,5),yaxs="i",xaxs="i",xaxt="n",las=1,frame.plot=FALSE)
points(t6.18~kpa.mean,data=embq10, pch=21,bg="black", cex=1.4, ylim=c(0,5), xaxt="n")
points(t12.18~kpa.mean,data=embq10,pch=21,bg="gray", cex=1.4, ylim=c(0,5), xaxt="n")
axis(1, labels=F)
mtext(expression(paste( italic("(a)"))), side=2, line=1,at=6, las=2)
mtext(expression(paste(Q)[10]), side=2, las=2, line=2)
# panel 2 (Megalopas)
par(fig=c(0,5,3.3,6.6)/10)
par(new=T)
plot(t6.12~kpa.mean,data=megaq10, pch=21, cex=1.4, xlab="",ylab=expression(paste(Q)[10]),
     xlim=c(0,25), ylim=c(0,5),yaxs="i",xaxs="i",xaxt="n",las=1,frame.plot=FALSE)
points(t6.18~kpa.mean,data=megaq10, pch=21,bg="black", cex=1.4, ylim=c(0,5), xaxt="n")
points(t12.18~kpa.mean,data=megaq10, pch=21, bg="gray",cex=1.4, ylim=c(0,5), xaxt="n")
axis(1, labels=F)
mtext(expression(paste( italic("(b)"))), side=2, line=1,at=6, las=2)
mtext(expression(paste(Q)[10]), side=2, las=2, line=2)
# panel 3 (juveniles)
par(fig=c(0,5,0,3.3)/10)
par(new=T)
plot(t6.12~kpa.mean,data=juvq10, pch=21, cex=1.4, ylab=expression(paste(Q)[10]),
     xlim=c(0,25), ylim=c(0,5),yaxs="i",xaxs="i",las=1,frame.plot=FALSE)
points(t6.18~kpa.mean,data=juvq10, pch=21,bg="black", cex=1.4, ylim=c(0,5), xaxt="n")
points(t12.18~kpa.mean,data=juvq10, pch=21, bg="gray",cex=1.4, ylim=c(0,5), xaxt="n")
axis(1, labels=F)
mtext(expression(paste( italic("(c)"))), side=2, line=1,at=6, las=2)
mtext(expression(paste(Q)[10]), side=2, las=2, line=2)
mtext("Oxygen tension (kPa)", side=1, line=2, las=1)
# panel 4 (Adultos)
par(fig=c(5,10,0,9.9)/10)
par(new=T)
plot(t6.12~kpa.mean,data=aduq10, pch=21, cex=1.4, ylab=expression(paste(Q)[10]),
     xlim=c(0,25), ylim=c(0,25),yaxs="i",xaxs="i",las=1,frame.plot=FALSE)
points(t6.18~kpa.mean,data=aduq10, pch=21,bg="black", cex=1.4, ylim=c(0,5), xaxt="n")
points(t12.18~kpa.mean,data=aduq10, pch=21, bg="gray",cex=1.4, ylim=c(0,5), xaxt="n")
axis(1, labels=F)
mtext(expression(paste( italic("(d)"))), side=2, line=1,at=26, las=2)
mtext(expression(paste(Q)[10]), side=2, line=1.5, las=2)
mtext("Oxygen tension (kPa)", side=1, line=2, las=1)
#dev.off()


library(ggplot2)
library(viridis)

df <- read.csv("importances.csv")

#Attempt to aggregate feature importances
#library(reshape2)
#mdata <- aggregate(formula = . ~ feature_pos, data = df, FUN = sum)
#Todo, alter size of circle based on # of features.... maybe rbind to prior df?
#mdata2 <- aggregate(formula = . ~ feature_pos, data = df, FUN = length)

#With dplyr
library(dplyr)
dCount <- df %>%
  count(feature_pos)

dImp <- df %>%
  group_by(feature_pos) %>%
  summarise(Imp=sum(importance)) %>%
  select(feature_pos,Imp)
merged <- merge(dCount, dImp, by = "feature_pos")

#Set identity row to 0, convert to factor, resort array, convert identity back to 1
identityRow <- df  %>%
  dplyr::filter(feature_pos %in% c("identity"))
merged <- merged[-c(which(merged$feature_pos == "identity")),]

#Convert to numeric and sort
merged$feature_pos <- as.numeric(as.character(merged$feature_pos))

#Bubbles
tiff("test.tiff", units="mm", width=178, height=133.5, res=300, compression='lzw')
ggplot(merged, aes(x=feature_pos, y=Imp, size=n, fill=Imp)) +
  geom_point(alpha=0.7, shape = 21) +
  geom_text(aes(label=ifelse(Imp>0.008, feature_pos,'')),hjust=0.5,vjust=-1, size=4) +
  # ggtitle("Cumulative GINI feature importance") +
  labs(x = "Amino acid position", y = "Importance") +
  scale_fill_viridis(option="magma") +
  scale_size_continuous(range = c(2,10)) +
  scale_x_continuous(minor_breaks = seq(0, 350, 25), breaks = seq(0, 350, 50)) +
  theme_minimal()

# insert ggplot code
dev.off()

#Backmap to protein
#install.packages("colourvalues")
library(colourvalues)
merged$col <- colour_values(merged$Imp, palette = "magma", include_alpha = FALSE)
write.csv(merged,"colors.csv")

#PRINT SELE and COLOR statements
for (row in 1:nrow(merged)) {
  print(paste("select resi", merged$feature_pos,";"))
}


Ghuber <- function (u, k = 30, deriv = 0)
{
    if (!deriv)
    {
        return(pmin(1, k/abs(u)))
    } else {
        return(abs(u) <= k)
    }
}

#' Univariate LDSC
#'
#' Imported here to help estimate sample overlap between studies
#'
#' @param Z summary Z-statistics for M variants
#' @param r2 average reference LD scores for M variants
#' @param N GWAS sample size for each variant (could be different across variants)
#' @param W variant weight
#'
#' @keywords internal
#' @return model fit
ldsc_h2_internal <- function(Z, r2, N, W=NULL)
{
    if (is.null(W))
    {
        W <- rep(1, length(Z))
    }
    tau <- (mean(Z^2) - 1) / mean(N * r2)
    Wv <- 1 / (1 + tau * N * r2)^2
    id <- which(Z^2 > 30)
    if (length(id) > 0)
    {
        Wv[id] <- sqrt(Wv[id])
    }
    mod <- MASS::rlm(I(Z^2) ~ I(N * r2), weight = W * Wv,
        psi = Ghuber, k = 30)
    return(summary(mod))
}

#' Bivariate LDSC
#'
#' Imported here to help estimate sample overlap between studies
#'
#' @param Zs Mx2 matrix of summary Z-statistics for M variants from two GWAS
#' @param r2 average reference LD scores for M variants
#' @param N1 sample size for the 1st GWAS
#' @param N2 sample size for the 2nd GWAS
#' @param Nc overlapped sample size between the two GWAS
#' @param W variant weight
#' @param h1 hsq for trait 1
#' @param h2 hsq for trait 2
#'
#' @return List of models
#' @references
#' Bulik-Sullivan,B.K. et al. (2015) An atlas of genetic correlations across human diseases and traits. Nat. Genet. 47, 1236–1241.
#'
#' Guo,B. and Wu,B. (2018) Principal component based adaptive association test of multiple traits using GWAS summary statistics. bioRxiv 269597; doi: 10.1101/269597
#'
#' Gua,B. and Wu,B. (2019) Integrate multiple traits to detect novel trait-gene association using GWAS summary data with an adaptive test approach. Bioinformatics. 2019 Jul 1;35(13):2251-2257. doi: 10.1093/bioinformatics/bty961.
#'
#' https://github.com/baolinwu/MTAR
#' @keywords internal
ldsc_rg_internal <- function(Zs, r2, h1, h2, N1, N2, Nc=0, W=NULL)
{
    if(is.null(W))
    {
        W = rep(1,length(r2))
    }

    Y <- Zs[,1] * Zs[,2]

    X <- (sqrt(N1) * sqrt(N2) + sqrt(Nc/N1 * N2)) * r2
    N1r2 <- N1 * r2
    N2r2 <- N2 * r2
    r0 <- 0

    ## 1st round
    if(any(Nc > 0))
    {
        rcf <- as.vector(MASS::rlm(Y ~ X, psi = Ghuber)$coef)
        r0 <- rcf[1]
        gv <- rcf[-1]
    } else {
        gv <- as.vector(MASS::rlm(Y ~ X-1, psi = Ghuber)$coef)
    }

    ## 2nd round
    Wv <- 1 / ((h1 * N1r2 + 1) * (h2 * N2r2 + 1) + (X * gv + r0)^2)
    id <- which(abs(Zs[,1] * Zs[,2]) > 30)
    if(length(id) > 0)
    {
        Wv[id] <- sqrt(Wv[id])
    }

    if(any(Nc > 0))
    {
        rcf <- MASS::rlm(Y ~ X, weight = W * Wv, psi = Ghuber, k = 30)
    } else {
        rcf <- MASS::rlm(Y ~ X - 1, weight = W * Wv, psi = Ghuber, k = 30)
    }
    return(summary(rcf))
}

#' Univariate LDSC
#'
#' Imported here to help estimate sample overlap between studies
#'
#' @param id ID to analyse
#' @param ancestry ancestry of traits 1 and 2 (AFR, AMR, EAS, EUR, SAS) or 'infer' (default) in which case it will try to guess based on allele frequencies
#' @param snpinfo Output from ieugwasr::afl2_list("hapmap3"), or NULL for it to be done automatically
#' @param splitsize How many SNPs to extract at one time. Default=20000
#'
#' @export
#' @return model fit
#' @references
#' Bulik-Sullivan,B.K. et al. (2015) An atlas of genetic correlations across human diseases and traits. Nat. Genet. 47, 1236–1241.
#'
#' Guo,B. and Wu,B. (2018) Principal component based adaptive association test of multiple traits using GWAS summary statistics. bioRxiv 269597; doi: 10.1101/269597
#'
#' Gua,B. and Wu,B. (2019) Integrate multiple traits to detect novel trait-gene association using GWAS summary data with an adaptive test approach. Bioinformatics. 2019 Jul 1;35(13):2251-2257. doi: 10.1093/bioinformatics/bty961.
#'
#' https://github.com/baolinwu/MTAR
ldsc_h2 <- function(id, ancestry="infer", snpinfo = NULL, splitsize=20000)
{
    if(is.null(snpinfo))
    {
        snpinfo <- ieugwasr::afl2_list("hapmap3")
    }

    snpinfo <- snpinfo %>%
        dplyr::filter(complete.cases(.))

    d <- extract_split(snpinfo$rsid, id, splitsize) %>%
        ieugwasr::fill_n() %>%
        dplyr::mutate(z = beta / se) %>%
        dplyr::select(rsid, z = z, n = n, eaf) %>%
        dplyr::filter(complete.cases(.))

    stopifnot(nrow(d) > 0)

    if(ancestry == "infer")
    {
        ancestry <- ieugwasr::infer_ancestry(d, snpinfo)$pop[1]
    }

    d <- snpinfo %>%
        dplyr::select(rsid, l2=paste0("L2.", ancestry)) %>%
        dplyr::inner_join(., d, by="rsid") %>%
        dplyr::filter(complete.cases(.))

    return(ldsc_h2_internal(d$z, d$l2, d$n))
}

#' Bivariate LDSC
#'
#' Imported here to help estimate sample overlap between studies
#'
#' @param id1 ID 1 to analyse
#' @param id2 ID 2 to analyse
#' @param ancestry ancestry of traits 1 and 2 (AFR, AMR, EAS, EUR, SAS) or 'infer' (default) in which case it will try to guess based on allele frequencies
#' @param snpinfo Output from ieugwasr::afl2_list("hapmap3"), or NULL for it to be done automatically
#' @param splitsize How many SNPs to extract at one time. Default=20000
#'
#' @export
#' @return model fit
ldsc_rg <- function(id1, id2, ancestry="infer", snpinfo = NULL, splitsize=20000)
{
    if(is.null(snpinfo))
    {
        snpinfo <- ieugwasr::afl2_list("hapmap3")
    }

    x <- extract_split(snpinfo$rsid, c(id1, id2), splitsize)
    d1 <- subset(x, id == id1) %>%
        ieugwasr::fill_n() %>%
        dplyr::mutate(z = beta / se) %>%
        dplyr::select(rsid, z1 = z, n1 = n, eaf) %>%
        dplyr::filter(complete.cases(.))

    stopifnot(nrow(d1) > 0)

    d2 <- subset(x, id == id2) %>%
        ieugwasr::fill_n() %>%
        dplyr::mutate(z = beta / se) %>%
        dplyr::select(rsid, z2 = z, n2 = n, eaf) %>%
        dplyr::filter(complete.cases(.))

    stopifnot(nrow(d2) > 0)

    if(ancestry == "infer")
    {
        ancestry1 <- ieugwasr::infer_ancestry(d1, snpinfo)
        ancestry2 <- ieugwasr::infer_ancestry(d2, snpinfo)
        if(ancestry1$pop[1] != ancestry2$pop[1])
        {
            stop("d1 ancestry is ", ancestry1$pop[1], " and d2 ancestry is ", ancestry2$pop[1])
        }
        ancestry <- ancestry1$pop[1]
    }

    d1 <- snpinfo %>%
        dplyr::select(rsid, l2=paste0("L2.", ancestry)) %>%
        dplyr::inner_join(., d1, by="rsid")

    d2 <- snpinfo %>%
        dplyr::select(rsid, l2=paste0("L2.", ancestry)) %>%
        dplyr::inner_join(., d2, by="rsid")

    h1 <- ldsc_h2_internal(d1$z1, d1$l2, d1$n1, d1$l2)
    h2 <- ldsc_h2_internal(d2$z2, d2$l2, d2$n2, d1$l2)

    dat <- dplyr::inner_join(d1, d2, by="rsid") %>%
        dplyr::mutate(
            l2 = l2.x,
            n1 = as.numeric(n1),
            n2 = as.numeric(n2),
            rhs = l2 * sqrt(n1 * n2)
        )

    gcov <- dat %>%
        {
            ldsc_rg_internal(
                Zs = cbind(.$z1, .$z2),
                r2 = .$l2,
                h1 = h1$coefficients[2,1] * nrow(d1),
                h2 = h2$coefficients[2,1] * nrow(d2),
                N1 = .$n1,
                N2 = .$n2,
                W = .$l2
            )
        }
    return(list(
        gcov = gcov,
        h1=h1,
        h2=h2,
        rg = (gcov$coefficients[1,1] * nrow(dat)) / sqrt(h1$coefficients[2,1] * nrow(d1) * h2$coefficients[2,1] * nrow(d2))
    ))
}

extract_split <- function(snplist, id, splitsize=20000)
{
    nsplit <- round(length(snplist)/splitsize)
    split(snplist, 1:nsplit) %>%
        pbapply::pblapply(., function(x)
        {
            ieugwasr::associations(x, id, proxies=FALSE)
        }) %>% dplyr::bind_rows()
}


# to run on saga

require(data.table)

#accept arguments
args<-commandArgs(TRUE)

gt <- fread(args[1]) # takes 45 sec or so
ad <- fread(args[2]) # takes 45 sec or so

dim(gt)
dim(ad)

setnames(gt, 3:ncol(gt), paste(names(gt)[3:ncol(gt)], '_gt', sep=''))

setkey(gt, CHROM, POS)
setkey(ad, CHROM, POS)
ad2 <- merge(ad, gt)

# mask uncalled or homozygote individuals (set to NA)
indivs <- setdiff(names(ad), c('CHROM', 'POS'))
for(i in indivs){
	ad2[get(paste(i, '_gt', sep='')) %in% c('0/0', './.', '1/1'), eval(i):=NA]
}

	# check that it worked
#	ad2[1:10, .(BM_026_gt, BM_026)]
#	ad2[BM_026_gt=='0/1', .(BM_026_gt, BM_026)]
#
#	ad2[1:10, .(BM_027_gt, BM_027)]
#	ad2[BM_027_gt=='0/1', .(BM_027_gt, BM_027)]

# remove gt columns (to clean up)
for(i in indivs){
	ad2[, eval(paste(i, '_gt', sep='')):=NULL]
}

# extract ref and alt alleles for het individuals (slow: takes 30? min or so)
for(i in indivs){
	cat(paste(i, ' ', sep=''))
	ad2[, eval(paste(i, '_ref', sep='')) := as.numeric(sapply(strsplit(get(i), split=','), '[', 1))]
	ad2[, eval(paste(i, '_alt', sep='')) := as.numeric(sapply(strsplit(get(i), split=','), '[', 2))]
}

# sum ref and alt alleles across het individuals
ad2[, sumRef := rowSums(.SD, na.rm=TRUE), .SDcol = grep('_ref', names(ad2))]
ad2[, sumAlt := rowSums(.SD, na.rm=TRUE), .SDcol = grep('_alt', names(ad2))]

# binomial test for allele balance == 0.5
ad2[,r:=1:.N] # row number
ad2[sumAlt>0 & sumRef>0 & !is.na(sumAlt) & !is.na(sumRef),binomp := binom.test(sumRef, sumRef+sumAlt, p=0.5, alternative='two.sided')$p.value, by=r]

	# ad2[,.(sumAlt, sumRef, binomp)]

# calc FDR
ad2[,binompFDR := p.adjust(binomp, method='fdr')]

# write out
#write.table(ad2[,.(CHROM, POS, sumRef, sumAlt)], file='Allele_balance/Allele_balance.binomp.tsv', row.names=FALSE, sep='/t')

x=paste0(c(args[3]),c(".tsv"))

write.table(ad2[,.(CHROM, POS, sumRef, sumAlt, binomp, binompFDR)], file=x, row.names=FALSE, sep='\t', quote=FALSE)


#
# Example R program
#

library(gmp)

# Integers are differents
urand.bigz()
urand.bigz()
urand.bigz()
# Integers are the same
urand.bigz(seed="234234234324323")
urand.bigz(seed="234234234324323")
# Vector
urand.bigz(nb=50,size=30)