#' Bubble plots of catch age comp resids
#'
#' Pearson residuals for age composition for all years in bubble plot.
#' @param asap name of the variable that read in the asap.rdat file
#' @param fleet.names names of fleets
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param scale.catch.bubble.resid larger values increase size of catch age comp bubbles (defaults to 2)
#' @param orig.bubble.colors logical TRUE = red, white, FALSE = red, blue (defaults to FALSE)
#' @param is.catch.flag true means only catch plotted, false also plots discards (defaults to TRUE)
#' @export

PlotCatchAgeCompResids <- function(asap,fleet.names,save.plots,od,plotf,
                                   scale.catch.bubble.resid=2,
                                   orig.bubble.colors=FALSE,is.catch.flag=TRUE){
  par(mar=c(4,4,2,2), oma=c(1,1,1,1), mfrow=c(1,1))

  if (orig.bubble.colors == TRUE) {
    pos.resid.col <- "#ffffffaa"
    neg.resid.col <- "#ff1111aa"
  } else {
    pos.resid.col <- rgb(0, 0, 1, alpha = 0.5)
    neg.resid.col <- rgb(1, 0, 0, alpha = 0.5)
  }

  years=seq(asap$parms$styr, asap$parms$endyr)
  nyrs=asap$parms$nyears

  for (i in 1:asap$parms$nfleets) {
    # fix for fleet selectivity start age > 1 or end age < nages (thanks Kiersten!)
    # ages = seq(1, asap$parms$nages)
    ages=seq(asap$fleet.sel.start.age[i], asap$fleet.sel.end.age[i])
    nages=length(ages)

    acomp.obs <- as.data.frame(asap$catch.comp.mats[4*(i-1)+1])
    acomp.pred <- as.data.frame(asap$catch.comp.mats[4*(i-1)+2])
    catch.yrs <- which(asap$fleet.catch.Neff.init[i,]>0)
    my.title <- "Age Comp Residuals for Catch by Fleet "
    my.save <- "catch.resid.bubble.plots."
    if (!is.catch.flag){
      acomp.obs <- as.data.frame(asap$catch.comp.mats[4*(i-1)+3])
      acomp.pred <- as.data.frame(asap$catch.comp.mats[4*(i-1)+4])
      catch.yrs <- which(asap$fleet.discard.Neff.init[i,]>0)
      my.title <- "Age Comp Residuals for Discards by Fleet "
      my.save <- "discard.resid.bubble.plots."
    }
    acomp.catch.resids <- matrix(NA, nrow=nyrs, ncol=nages)
    ###NEW
    acomp.sd <- matrix(NA, nrow=nyrs, ncol=nages)
    if (length(catch.yrs)>0){
      for (j in 1:length(catch.yrs)){
        resids <- as.numeric(acomp.obs[catch.yrs[j], ] - acomp.pred[catch.yrs[j],])  # NOTE obs-pred
        acomp.catch.resids[as.numeric(catch.yrs[j]), ] <- resids
        ###NEW
        tmp.sd <- as.numeric(sqrt(acomp.pred[catch.yrs[j],]*(1-acomp.pred[catch.yrs[j],])/asap$fleet.catch.Neff.init[i, catch.yrs[j]] ) )
        acomp.sd[as.numeric(catch.yrs[j]), ] <- tmp.sd
      }
      z1 <- acomp.catch.resids
      range.resids<-range(abs((as.vector(z1))), na.rm=T)
      scale.resid.bubble.catch <- 25

      z3 <- z1 * scale.resid.bubble.catch *scale.catch.bubble.resid
      resid.col=matrix(NA, nrow=nyrs, ncol=nages)   # set color for residual bubbles
      resid.col <- ifelse(z3 > 0.0,pos.resid.col, neg.resid.col)

      ###NEW
      ##   calculate age comp bubble resids as pearson standardized resids
      zr <- z1/acomp.sd

      ###NEW
      par(mar=c(5,4,2,2), oma=c(1,1,1,1), mfrow=c(1,1))
      ##   plot age comp bubble resids as pearson standardized resids
      plot(ages, rev(ages),  xlim = range(ages), ylim = c(years[nyrs],(years[1]-2)),
           xlab = "Age", ylab = "Pearson Residuals (Obs-Pred)/SQRT(Pred*(1-Pred)/NESS)", type = "n", axes=F)
      axis(1, at= ages, lab=ages)
      axis(2, at = rev(years), lab = rev(years), cex.axis=0.75, las=1)
      box()
      abline(h=years, col="lightgray")
      segments(x0=ages, y0=rep(years[1],nages),
               x1=ages, y1=rep(years[nyrs],nages), col = "lightgray", lty = 1)

      for (j in 1:nyrs){
        ## New  - use triangle instead of circle for resids where Obs=0
        #pch.resid <- ifelse(acomp.obs[j,]>0, 21, 24)  #use diff symbol
        pch.resid <- ifelse(acomp.obs[j,]>0, 21, 21)   #use same symbol

        points(ages, rep((years[1]+j-1), nages), cex=abs(zr[j,])* scale.catch.bubble.resid,
               col="black", bg = resid.col[j,],  pch = pch.resid )
      }

      tmp.zr <- matrix((abs(zr)),nrow=1, ncol=length(zr[,1])*length(zr[1,])  )
      tmp.zr1 <- tmp.zr[1,]
      bubble.legend.pearson<- summary(tmp.zr1, na.rm=T) [c(2,3,5)]

      legend("topright", xpd=T, legend=round(bubble.legend.pearson,2), pch=rep(1, 3),
             pt.cex=as.numeric(bubble.legend.pearson)*  scale.catch.bubble.resid,
             horiz=T , col='black'  )
      legend("topleft", xpd=T, legend=c("Neg.", "Pos."), pch=rep(21, 2), pt.cex=3,
             horiz=T , pt.bg=c(neg.resid.col, pos.resid.col), col="black"  )
      text(x= trunc(nages/2), y=(years[1]-1),   cex=0.8,
           label=paste0("Max(resid)=",round(max(abs(zr), na.rm=T),2)) )

      title (paste0(my.title,i, " (", fleet.names[i], ")"), outer=T, line=-1 )
      title(sub=paste0("Mean resid = ", round(mean(zr, na.rm=T ),2), "   SD(resid) = ",
                      round(sd(as.vector(zr), na.rm=T ),2)), col.sub='blue', cex.sub=0.8)

      if (save.plots) savePlot(paste0(od, "Pearson.", my.save, i, ".", plotf), type=plotf)

    } # end catch.yrs test
  }   #end loop nfleets
  return()
}


reshape_res = function(out, nn = names(inits),
		       cl = dimnames(Y)$country,
		       n_years = hyp$Time,
		       n_countries = hyp$N_countries,
		       n_clust = hyp$H,  pG = 2) {

	# I primi sono a posto così. Gli altri serve un po' di reshape manuale
	# prendiamo quelli bidimensionali
	nn_red = grep("^drift_|s_", nn,invert=T,value=T)
	res = list()

	# actual Parameters, [nit x countries x years] format
	for(i in 1:length(nn_red)) {
		tmp = out[,grep(paste0("^",nn_red[i],"\\["), colnames(out) )]
		res[[nn_red[i]]] = drop(array(tmp, dim = c(NROW(tmp), ncol(tmp)/n_years,n_years )))
	}

	# multivariate components: drift
	nn_dr = grep("drift", nn,value=T)
	for(i in 1:length(nn_dr)){
		tmp = out[,grep(paste0("^",nn_dr[i],"\\["), colnames(out) )]
		res[[nn_dr[i]]] = drop(array(tmp, dim = c(NROW(tmp), ncol(tmp)/n_countries,n_countries )))
	}
	nn_s = grep("s_", nn,value=T)
	for(i in 1:length(nn_dr)){
		tmp = out[,grep(paste0("^",nn_s[i],"\\["), colnames(out) )]
		res[[nn_s[i]]] = drop(array(tmp, dim = c(NROW(tmp), ncol(tmp)/n_countries,n_countries )))
	}

	return(res)
}

## We use a different parametrisation
add_w = function(pl) {
	w0=w1=w2=array(NA, dim = dim(pl$eta1))
	for(j in 1:dim(pl$eta1)[2]){
	for(k in 1:dim(pl$eta1)[3]){
		tmp = t(apply(cbind(pl$eta1[,j,k], pl$eta2[,j,k]), 1, function(r) eta_to_w(eta1 = r[1], eta2 = r[2])))
		w2[,j,k] = tmp[,3]
		w1[,j,k] = tmp[,2]
		w0[,j,k] = tmp[,1]
	}
	}
	return(c(pl, list("w0" = w0,"w1" = w1,"w2" = w2)))
}

add_skew_moments = function(pl) {
	# computes sn moments
	a2d = function(a) a / sqrt( 1 + a^2 )
	m = function(xi, omega, d) xi + omega * d * sqrt(2/pi)
	v = function(omega, d) omega^2 * (1 - 2 * d^2 / pi )

	sn_mean=sn_sd=array(NA, dim = dim(pl$xi))
	for(j in 1:dim(pl$xi)[2]){
	for(k in 1:dim(pl$xi)[3]){
		sn_mean[,j,k] = m(pl$xi[,j,k],sqrt(exp(pl$lomega[,j,k])), a2d(pl$alpha[,j,k]))
		sn_sd[,j,k] = sqrt(v(sqrt(exp(pl$lomega[,j,k])), a2d(pl$alpha[,j,k])))
	}}
	return(c(pl, list("sn_mean"  = sn_mean, "sn_sd" = sn_sd)))

}

eta_to_w = function(eta1,eta2) {
	expit = function(x) exp(x) / (1 + exp(x) )
		c(expit(-eta1) * expit(-eta2), expit(eta2) * expit(-eta1), expit(eta1))
}

# This function obtains predictions recursively
get_rec_pred = function(nyears = 10,  pl, hyp)
{
	obj_size = c(NROW(pl$xi),hyp$N_countries, nyears)

	tmp = list()
	tmp$xi     =  array(NA, dim = obj_size)
	tmp$lomega =  array(NA, dim = obj_size)
	tmp$alpha =  array(NA, dim = obj_size)

	tmp$mu     =  array(NA, dim = obj_size)
	tmp$lsigma =  array(NA, dim = obj_size)

	tmp$eta1   =  array(NA, dim = obj_size)
	tmp$eta2   =  array(NA, dim = obj_size)

	for(it in 1:NROW(pl$mu)){
		for(nc in 1:obj_size[2]) { # loop across countries

			tmp$xi[it,nc,1]     = pl$xi[it,nc,hyp$Time] + pl$drift_xi[it,nc]
			tmp$lomega[it,nc,1] = pl$lomega[it,nc,hyp$Time] + pl$drift_lomega[it,nc]
			tmp$alpha[it,nc,1]  = pl$alpha[it,nc,hyp$Time] + pl$drift_alpha[it,nc]

			tmp$mu[it,nc,1]     = pl$mu[it,nc,hyp$Time] + pl$drift_mu[it,nc]
			tmp$lsigma[it,nc,1] = pl$lsigma[it,nc,hyp$Time] + pl$drift_lsigma[it,nc]

			tmp$eta1[it,nc,1]   = pl$eta1[it,nc,hyp$Time] + pl$drift_eta1[it,nc]
			tmp$eta2[it,nc,1]   = pl$eta2[it,nc,hyp$Time] + pl$drift_eta2[it,nc]

			# Now loop in time
			for(tt in 2:obj_size[3]) { # loop in time and get recursive predictions
				tmp$xi[it,nc,tt]     = tmp$xi[it,nc,tt-1] + pl$drift_xi[it,nc]
				tmp$lomega[it,nc,tt] = tmp$lomega[it,nc,tt-1] + pl$drift_lomega[it,nc]
				tmp$alpha[it,nc,tt]  = tmp$alpha[it,nc,tt-1] + pl$drift_alpha[it,nc]

				tmp$mu[it,nc,tt]     = tmp$mu[it,nc,tt-1] + pl$drift_mu[it,nc]
				tmp$lsigma[it,nc,tt] = tmp$lsigma[it,nc,tt-1] + pl$drift_lsigma[it,nc]

				tmp$eta1[it,nc,tt]   = tmp$eta1[it,nc,tt-1] + pl$drift_eta1[it,nc]
				tmp$eta2[it,nc,tt]   = tmp$eta2[it,nc,tt-1] + pl$drift_eta2[it,nc]
			}
			}

		if(it %% 50 == 0) cat(it, " over ", obj_size[1], "\n")
	}
	return(tmp)
}

# This function obtains predictions recursively
get_pred_ppd = function(nyears = 10,  pl, hyp, seed = 1)
{
	set.seed(seed)
	obj_size = c(NROW(pl$xi),hyp$N_countries, nyears)

	tmp = list()
	tmp$xi     =  array(NA, dim = obj_size)
	tmp$lomega =  array(NA, dim = obj_size)
	tmp$alpha =  array(NA, dim = obj_size)

	tmp$mu     =  array(NA, dim = obj_size)
	tmp$lsigma =  array(NA, dim = obj_size)

	tmp$eta1   =  array(NA, dim = obj_size)
	tmp$eta2   =  array(NA, dim = obj_size)

	for(it in 1:NROW(pl$mu)){
		for(nc in 1:obj_size[2]) { # loop across countries
			tmp$xi[it,nc,1]     = rnorm(1, mean = pl$xi[it,nc,hyp$Time] + pl$drift_xi[it,nc], sd         = sqrt(pl$s_xi[it,nc]))
			tmp$lomega[it,nc,1] = rnorm(1, mean = pl$lomega[it,nc,hyp$Time] + pl$drift_lomega[it,nc], sd = sqrt(pl$s_lomega[it,nc]))
			tmp$alpha[it,nc,1]  = rnorm(1, mean = pl$alpha[it,nc,hyp$Time] + pl$drift_alpha[it,nc], sd   = sqrt(pl$s_alpha[it,nc]))

			tmp$mu[it,nc,1]     = rnorm(1, mean = pl$mu[it,nc,hyp$Time] + pl$drift_mu[it,nc], sd         = sqrt(pl$s_mu[it,nc]))
			tmp$lsigma[it,nc,1] = rnorm(1, mean = pl$lsigma[it,nc,hyp$Time] + pl$drift_lsigma[it,nc], sd = sqrt(pl$s_lsigma[it,nc]))

			tmp$eta1[it,nc,1]   = rnorm(1, mean = pl$eta1[it,nc,hyp$Time] + pl$drift_eta1[it,nc], sd     = sqrt(pl$s_eta1[it,nc]))
			tmp$eta2[it,nc,1]   = rnorm(1, mean = pl$eta2[it,nc,hyp$Time] + pl$drift_eta2[it,nc], sd     = sqrt(pl$s_eta2[it,nc]))

			# Now loop in time
			for(tt in 2:obj_size[3]) { # loop in time and get recursive predictions
				tmp$xi[it,nc,tt]     = rnorm(1, mean = tmp$xi[it,nc,tt-1] + pl$drift_xi[it,nc], sd         = sqrt(pl$s_xi[it,nc]))
				tmp$lomega[it,nc,tt] = rnorm(1, mean = tmp$lomega[it,nc,tt-1] + pl$drift_lomega[it,nc], sd = sqrt(pl$s_lomega[it,nc]))
				tmp$alpha[it,nc,tt]  = rnorm(1, mean = tmp$alpha[it,nc,tt-1] + pl$drift_alpha[it,nc], sd   = sqrt(pl$s_alpha[it,nc]))

				tmp$mu[it,nc,tt]     = rnorm(1, mean = tmp$mu[it,nc,tt-1] + pl$drift_mu[it,nc], sd         = sqrt(pl$s_mu[it,nc]))
				tmp$lsigma[it,nc,tt] = rnorm(1, mean = tmp$lsigma[it,nc,tt-1] + pl$drift_lsigma[it,nc], sd = sqrt(pl$s_lsigma[it,nc]))

				tmp$eta1[it,nc,tt]   = rnorm(1, mean = tmp$eta1[it,nc,tt-1] + pl$drift_eta1[it,nc], sd     = sqrt(pl$s_eta1[it,nc]))
				tmp$eta2[it,nc,tt]   = rnorm(1, mean = tmp$eta2[it,nc,tt-1] + pl$drift_eta2[it,nc], sd     = sqrt(pl$s_eta2[it,nc]))
			}

		}
		if(it %% 50 == 0) cat(it, " over ", obj_size[1], "\n")
	}
	return(tmp)
}

get_df_summ = function(pl,pred, countries = dimnames(dd$y)[[1]],
		       log_scale = T, w = F,
		       moments = F,
		       func = "mean", ...) {
	df_pl = list()

	for(p in 1:length(countries)){
		cur_c = countries[p]
		tmp = data.frame(x=1:(hyp$Time+dim(pred$xi)[3]))

		if(w) {
			tmp$w0 = c(apply(pl$w0[,p,],2,get(func), ...), apply(pred$w0[,p,],2,get(func), ...))
			tmp$w1 = c(apply(pl$w1[,p,],2,get(func), ...), apply(pred$w1[,p,],2,get(func), ...))
			tmp$w2 = c(apply(pl$w2[,p,],2,get(func), ...), apply(pred$w2[,p,],2,get(func), ...))
		} else {
			tmp$eta1 = c(apply(pl$eta1[,p,],2,get(func), ...), apply(pred$eta1[,p,],2,get(func), ...))
			tmp$eta2 =c( apply(pl$eta2[,p,],2,get(func), ...),  apply(pred$eta2[,p,],2,get(func), ...))
		}

		tmp$mu =c( apply(pl$mu[,p,],2,get(func), ...),  apply(pred$mu[,p,],2,get(func), ...))

		if(log_scale){
			tmp$sigma =c( apply((pl$lsigma[,p,]),2,get(func), ...),  apply((pred$lsigma[,p,]),2,get(func), ...))
			tmp$omega =c( apply((pl$lomega[,p,]),2,get(func), ...),  apply((pred$lomega[,p,]),2,get(func), ...))
		} else {
			tmp$sigma =c( apply(exp(pl$lsigma[,p,]),2,get(func), ...),  apply(exp(pred$lsigma[,p,]),2,get(func), ...))
			tmp$omega =c( apply(exp(pl$lomega[,p,]),2,get(func), ...),  apply(exp(pred$lomega[,p,]),2,get(func), ...))
		}

		tmp$xi =c( apply(pl$xi[,p,],2,get(func), ...),  apply(pred$xi[,p,],2,get(func), ...))
		tmp$alpha =c( apply(pl$alpha[,p,],2,get(func), ...),  apply(pred$alpha[,p,],2,get(func), ...))

		if(moments) {
			tmp$sn_mean =c( apply(pl$sn_mean[,p,],2,get(func), ...),  apply(pred$sn_mean[,p,],2,get(func), ...))
			tmp$sn_sd =c( apply(pl$sn_sd[,p,],2,get(func), ...),  apply(pred$sn_sd[,p,],2,get(func), ...))
			tmp$xi = NULL
			tmp$omega = NULL
		}

		df_pl[[cur_c]] = tmp

	}
	return(df_pl)
}

get_df_ic = function(pl,pred,
		     countries = dimnames(dd$y)[[1]],
		     log_scale = T,
		     w = F,
		     moments = F,
		     level = 0.05) {
	df_pl = list()

	for(p in 1:length(countries)){
		cur_c = countries[p]
		tmp = data.frame(x=1:(hyp$Time+dim(pred$xi)[3]))

		if(w) {
			tmp$w0 = c(apply(pl$w0[,p,],2,quantile, level), apply(pred$w0[,p,],2,quantile, level))
			tmp$w1 = c(apply(pl$w1[,p,],2,quantile, level), apply(pred$w1[,p,],2,quantile, level))
			tmp$w2 = c(apply(pl$w2[,p,],2,quantile, level), apply(pred$w2[,p,],2,quantile, level))
		} else {
			tmp$eta1 = c(apply(pl$eta1[,p,],2,quantile, level), apply(pred$eta1[,p,],2,quantile, level))
			tmp$eta2 = c(apply(pl$eta2[,p,],2,quantile, level),  apply(pred$eta2[,p,],2,quantile, level))
		}

		tmp$mu =c( apply(pl$mu[,p,],2,quantile, level),  apply(pred$mu[,p,],2,quantile, level))

		if(log_scale){
			tmp$sigma =c( apply((pl$lsigma[,p,]),2,quantile, level),  apply((pred$lsigma[,p,]),2,quantile, level))
			tmp$omega =c( apply((pl$lomega[,p,]),2,quantile, level),  apply((pred$lomega[,p,]),2,quantile, level))
		} else {
			tmp$sigma =c( apply(exp(pl$lsigma[,p,]),2,quantile, level),  apply(exp(pred$lsigma[,p,]),2,quantile, level))
			tmp$omega =c( apply(exp(pl$lomega[,p,]),2,quantile, level),  apply(exp(pred$lomega[,p,]),2,quantile, level))
		}

		tmp$xi =c( apply(pl$xi[,p,],2,quantile, level),  apply(pred$xi[,p,],2,quantile, level))
		tmp$alpha =c( apply(pl$alpha[,p,],2,quantile, level),  apply(pred$alpha[,p,],2,quantile, level))
		if(moments) {
			tmp$sn_mean =c( apply(pl$sn_mean[,p,],2,quantile, level),  apply(pred$sn_mean[,p,],2,quantile, level))
			tmp$sn_sd =c( apply(pl$sn_sd[,p,],2,quantile, level),  apply(pred$sn_sd[,p,],2,quantile, level))
			tmp$xi = NULL
			tmp$omega = NULL
		}

		df_pl[[cur_c]] = tmp
	}
	return(df_pl)
}

get_df_ic_h = function(pl,pred,
		       countries = dimnames(dd$y)[[1]],
		       log_scale = T, w = F, moments = F,
		       level = 0.95, upper = T){
	df_pl = list()

	emp_hpd = function(x, level) TeachingDemos::emp.hpd(x, level)[ifelse(upper,2,1)]

	for(p in 1:length(countries)){
		cur_c = countries[p]
		tmp = data.frame(x=1:(hyp$Time+dim(pred$xi)[3]))

		if(w) {
			tmp$w0 = c(apply(pl$w0[,p,],2,emp_hpd, level), apply(pred$w0[,p,],2,emp_hpd, level))
			tmp$w1 = c(apply(pl$w1[,p,],2,emp_hpd, level), apply(pred$w1[,p,],2,emp_hpd, level))
			tmp$w2 = c(apply(pl$w2[,p,],2,emp_hpd, level), apply(pred$w2[,p,],2,emp_hpd, level))
		} else {
			tmp$eta1 = c(apply(pl$eta1[,p,],2,emp_hpd, level), apply(pred$eta1[,p,],2,emp_hpd, level))
			tmp$eta2 = c(apply(pl$eta2[,p,],2,emp_hpd, level),  apply(pred$eta2[,p,],2,emp_hpd, level))
		}

		tmp$mu =c( apply(pl$mu[,p,],2,emp_hpd, level),  apply(pred$mu[,p,],2,emp_hpd, level))

		if(log_scale){
			tmp$sigma =c( apply((pl$lsigma[,p,]),2,emp_hpd, level),  apply((pred$lsigma[,p,]),2,emp_hpd, level))
			tmp$omega =c( apply((pl$lomega[,p,]),2,emp_hpd, level),  apply((pred$lomega[,p,]),2,emp_hpd, level))
		} else {
			tmp$sigma =c( apply(exp(pl$lsigma[,p,]),2,emp_hpd, level),  apply(exp(pred$lsigma[,p,]),2,emp_hpd, level))
			tmp$omega =c( apply(exp(pl$lomega[,p,]),2,emp_hpd, level),  apply(exp(pred$lomega[,p,]),2,emp_hpd, level))
		}

		tmp$xi =c( apply(pl$xi[,p,],2,emp_hpd, level),  apply(pred$xi[,p,],2,emp_hpd, level))
		tmp$alpha =c( apply(pl$alpha[,p,],2,emp_hpd, level),  apply(pred$alpha[,p,],2,emp_hpd, level))

		if(moments) {
			tmp$sn_mean =c( apply(pl$sn_mean[,p,],2,emp_hpd, level),  apply(pred$sn_mean[,p,],2,emp_hpd, level))
			tmp$sn_sd =c( apply(pl$sn_sd[,p,],2,emp_hpd, level),  apply(pred$sn_sd[,p,],2,emp_hpd, level))
			tmp$xi = NULL
			tmp$omega = NULL
		}

		df_pl[[cur_c]] = tmp
	}
	return(df_pl)
}


#' @title windrose
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
windrose <- function (frec, fnum = 4, fint = 5, flab = 2, ang = 3 * pi/16,
    col = rainbow(10, 0.5, 0.92, start = 0.33, end = 0.2), margen = c(0,
        0, 4, 0), key = TRUE, uni = "m/s", ...)
{
    if (is.matrix(frec))
        frec <- as.data.frame(frec)
    if (is.vector(frec)) {
        ndir <- length(frec)
        nr <- 1
    }
    else {
        ndir <- length(frec[1, ])
        nr <- nrow(frec)
    }
    fmax <- fnum * fint
    tot <- sum(frec)
    fr <- 100 * frec/tot
    key <- (nr > 1) && key
    if (key)
        mlf <- 3
    else mlf <- 1
    fx <- cos(pi/2 - (2 * pi/ndir * 0:(ndir - 1)))
    fy <- sin(pi/2 - (2 * pi/ndir * 0:(ndir - 1)))
    plot(fx, fy, xlim = c(-fmax - mlf * fint, fmax + fint), ylim = c(-fmax -
        fint, fmax + fint), xaxt = "n", yaxt = "n", xlab = "",
        ylab = "", bty = "n", asp = 1, type = "n", ...)
    if (nr == 1) {
        cx <- fx * fr
        cy <- fy * fr
    }
    else {
        f <- apply(fr, 2, sum)
        cx <- fx * f
        cy <- fy * f
        for (i in nr:2) {
            f <- f - fr[i, ]
            cx <- c(cx, NA, fx * f)
            cy <- c(cy, NA, fy * f)
        }
    }
    polygon(cx, cy, col = col[nr:1])
    symbols(c(0 * 1:fnum), c(0 * 1:fnum), circles = c(fint *
        1:fnum), inches = FALSE, add = TRUE)
    segments(0 * 1:ndir, 0 * 1:ndir, fmax * fx, fmax * fy)
    fmaxi <- fmax + fint/4
    text(0, fmaxi, "N")
    text(0, -fmaxi, "S")
    text(fmaxi, 0, "E")
    text(-fmaxi, 0, "W")
    if (flab == 2)
        for (i in 1:fnum) text(i * fint * cos(ang), i * fint *
            sin(ang), paste(i * fint, "%"))
    else if (flab == 1)
        text(fmax * cos(ang), fmax * sin(ang), paste(fmax, "%"))
    if (key) {
        legend(-fmaxi - 2.3 * fint, fmaxi + 2, fill = col, legend = attr(frec,
            "row.names"))
        text(-fmaxi - 1.4 * fint, fmaxi + 0.9 * fint, uni)
    }
    invisible()
}


#' Plot and Print Solver Maximum Head-Change Values
#'
#' This function reads in the list files and plots the head-change values. It assumes that
#' the solver is unit 19 in the .nam file. The slvrplt is currently working for GMG but as the
#' need arises other solvers will be added. Make sure that the solver is printing all information to the list file.
#' For the GMG solver this means setting ioutgmg to 2. This function will create a plot showing the head change over successive iterations.
#' It will also generate a .csv file indicating the cell location of the cell with the maximum head value.
#'
#' @param PATH This is the path to the directory that contains model files. The directory needs to include the .in file, .nam file, and .lst file.
#' If PATH is not specified set the working directory to the directory containing the model files.
#' @param HCLOSE This is the head-change close criterion.
#' @param slvUNIT This is the solver unit number in the MODFLOW .nam file. This defaults to 19.
#' @export

slvrplt <- function(PATH = NA, HCLOSE = 0.001, slvUNIT = 19){
    if(is.na(PATH)){
        rtPATH <- getwd()
        }else{
        rtPATH <- PATH
        }
    MFIN_FILES <- c("mf2k.in", "mf2005.in", "mf6.in")
    infl <- list.files(rtPATH, full.names = TRUE)[list.files(rtPATH) %in% MFIN_FILES]
    nmfl <- readr::read_lines(infl) %>% paste(rtPATH, ., sep = "\\")
    rnm  <- nmfl %>%
            stringr::str_split(".nam") %>%
            unlist() %>%
            .[[1]]

    pckg <- read.table(nmfl, stringsAsFactors = FALSE) %>%
            tibble::as_tibble() %>%
            dplyr::rename(PACKAGE = V1,
                          UNIT = V2,
                          FILE = V3)

    slvr <- pckg %>%
            dplyr::filter(UNIT == slvUNIT) %>%
            .[[1]]

    lstfl <- pckg %>%
             dplyr::filter(PACKAGE == "LIST") %>%
             .[[3]] %>%
             paste(rtPATH, ., sep = "\\")

    if(slvr == "GMG"){
        HDCHNG <- MFtools::read_gmg_lst(lstfl)
    }else if(slvr == "PCG"){
        HDCHNG <- MFtools::read_pcg_lst(lstfl)
    }else if(slvr == "NWT"){
        HDCHNG <- tryCatch(MFtools::read_nwt_lst(lstfl), error=function(e) print("Headchange has not been printed in .lst file yet"))
    }

    HDCHNG %>% readr::write_csv(paste(rtPATH, "HDCHNG.csv", sep = "\\"))
    print(HDCHNG)

    PLOT <- HDCHNG %>% ggplot2::ggplot(ggplot2::aes(x = ITER, abs(HDCHNG))) +
                       ggplot2::geom_point(shape = 21,
                                           size = 2,
                                           colour = "black",
                                           fill = "blue",
                                           alpha = 0.5) +
                       ggplot2::geom_hline(yintercept = HCLOSE,
                                           size = 1,
                                           colour = "red",
                                           linetype = "dashed") +
                       ggplot2::scale_y_log10(name = "Maximum Head-Change Value",
                                           limits = c(HCLOSE / 10, NA),
                                           breaks = 10^(-10:10),
                                           labels = scales::trans_format("log10", scales::math_format(10^.x)),
                                           minor_breaks = c(1:9 %o% 10^(-10:10)),
                                           expand = c(0, 0)) +
                       ggplot2::xlab("Iteration Number") +
                       ggplot2::theme_bw()

    if(slvr == "PCG"){
    PLOT <- PLOT + ggplot2::geom_point(data = HDCHNG %>% dplyr::filter(INNER_OUTER == 1),
                                       shape = 21,
                                       size = 2,
                                       colour = "black",
                                       fill = "red",
                                       alpha = 0.75)
    }
    print(PLOT)
}


############################################################
# For macaque paper, 08.19
# Counts SV stats and runs statistical tests
# Gregg Thomas
############################################################

this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

library(ggplot2)
library(reshape2)
library(cowplot)

source("../lib/read_svs.r")
source("../lib/filter_svs.r")
source("../lib/subset_svs.r")

cat("----------\n")

############################################################
# Functions
spacedOut <- function(str1, pad, str2){
  while(nchar(str1)<pad){
    str1 = paste(str1, " ", sep="")
  }
  return(paste(str1, str2, sep=""))
}
# Nice formatting for string output

##############################
avgInds <- function(df){
  cnv_sums = c()
  del_len_sums = c()
  dup_len_sums = c()
  max_cnvs = 0
  min_cnvs = 99999
  for(i in levels(as.factor(df$Individual))){
    tmp = subset(df, Individual == i)
    num_cnvs = length(tmp[,1])
    tmp_dels = subset(tmp, Type == "<DEL>")
    tmp_dups = subset(tmp, Type == "<DUP>")
    cnv_sums = c(cnv_sums, num_cnvs)
    if(num_cnvs > max_cnvs){
      max_cnvs = num_cnvs
    }

    if(num_cnvs < min_cnvs){
      min_cnvs = num_cnvs
    }

    del_len_sums = c(del_len_sums, sum(tmp_dels$Length))
    dup_len_sums = c(dup_len_sums, sum(tmp_dups$Length))
  }
  means = data.frame("num.cnvs"=mean(cnv_sums),
                     "max.cnvs"=max_cnvs,
                     "min.cnvs"=min_cnvs,
                     "num.del.bases"=mean(del_len_sums),
                     "num.dup.bases"=mean(dup_len_sums))
  return(means)
}

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

svCount <- function(df, pad){
  total = length(df$Type)
  dels = length(df$Type[df$Type=="<DEL>"])
  dels_p = signif(dels / total, digits=4)
  dups = length(df$Type[df$Type=="<DUP>"])
  dups_p = signif(dups / total, digits=4)

  del_sens = 0.88
  del_corrected = round(dels / del_sens)
  del_missed = del_corrected - dels

  dup_sens = 0.65
  dup_corrected = round(dups / dup_sens)
  dup_missed = dup_corrected - dups
  # Sensitivity estimates from Sudmant et al.

  cat(spacedOut("Total:",                   pad, total), "\n")
  cat(spacedOut("Deletions:",               pad, paste(dels, " (", dels_p, ")", sep="")), "\n")
  cat(spacedOut("Deletion sensitivity:",    pad, del_sens), "\n")
  cat(spacedOut("Deletions missed:",        pad, del_missed), "\n")
  cat(spacedOut("Deletions corrected:",     pad, del_corrected), "\n")

  cat(spacedOut("Duplications:",            pad, paste(dups, " (", dups_p, ")", sep="")), "\n")
  cat(spacedOut("Duplication sensitivity:", pad, dup_sens), "\n")
  cat(spacedOut("Duplication missed:",      pad, dup_missed), "\n")
  cat(spacedOut("Duplication corrected:",   pad, dup_corrected), "\n")

  bases = sum(df$Length)
  avg_bases = mean(df$Length)
  min_bases = min(df$Length)
  max_bases = max(df$Length)

  del_bases = sum(df$Length[df$Type=="<DEL>"])
  avg_del_bases = mean(df$Length[df$Type=="<DEL>"])
  del_bases_p = signif(del_bases / bases, digits=4)
  min_del_bases = min(df$Length[df$Type=="<DEL>"])
  max_del_bases = max(df$Length[df$Type=="<DEL>"])

  dup_bases = sum(df$Length[df$Type=="<DUP>"])
  avg_dup_bases = mean(df$Length[df$Type=="<DUP>"])
  dup_bases_p = signif(dup_bases / bases, digits=4)
  min_dup_bases = min(df$Length[df$Type=="<DUP>"])
  max_dup_bases = max(df$Length[df$Type=="<DUP>"])

  cat(spacedOut("Bases:",                   pad, bases), "\n")
  cat(spacedOut("Deleted bases:",           pad, paste(del_bases, " (", del_bases_p, ")", sep="")), "\n")
  cat(spacedOut("Duplicated bases:",        pad, paste(dup_bases, " (", dup_bases_p, ")", sep="")), "\n")

  cat(spacedOut("Avg. length:",             pad, avg_bases), "\n")
  cat(spacedOut("Min. length:",             pad, min_bases), "\n")
  cat(spacedOut("Max. length:",             pad, max_bases), "\n")

  cat(spacedOut("Avg. deletion length:",    pad, paste(avg_del_bases, "\n")))
  cat(spacedOut("Min. deletion length:",    pad, paste(min_del_bases, "\n")))
  cat(spacedOut("Max. deletion length:",    pad, paste(max_del_bases, "\n")))

  cat(spacedOut("Avg. duplication length:", pad, paste(avg_dup_bases, "\n")))
  cat(spacedOut("Min. duplication length:", pad, paste(min_dup_bases, "\n")))
  cat(spacedOut("Max. duplication length:", pad, paste(max_dup_bases, "\n")))
}
# Counts stuff for a CNV data frame

############################################################
# Input info

readdata = T
readonly = F
savelog = T
filterdata = T
rm_alus = T
# Run options

minlen = F
maxlen = 100000
# CNV length cutoffs

cat("Input info:\n")
cat("readdata   = ", readdata, "\n")
cat("readonly   = ", readonly, "\n")
cat("filterdata = ", filterdata, "\n")
cat("rm_alus    = ", rm_alus, "\n")
cat("minlen     = ", minlen, "\n")
cat("maxlen     = ", maxlen, "\n")
cat("savelog    = ", savelog, "\n")
# Some info printed to the screen

logfile = "cnv-counts"
if(filterdata){
  logfile = paste(logfile, "-filtered", sep="")
}else{
  logfile = paste(logfile, "-unfiltered", sep="")
}
if(rm_alus){
  logfile = paste(logfile, "-rmalus", sep="")
}
if(maxlen){
  logfile = paste(logfile, "-", maxlen, ".log", sep="")
}else{
  logfile = paste(logfile, "-all.log", sep="")
}

cat("logfile   -> ", logfile, "\n")
# The logfile

continue = readline("Review input vars above. Continue? (y/n) ")

if(!continue %in% c("Y", "y", "yes", "Yes", "YES")){
  stop("User chose to discontinue. Exiting.")
}
# Input info
######################
# Read the data
cat("----------\n")
cat("Starting counts\n")
pad = 55

if(savelog){
  sink(logfile)
}

if(readdata){
  sv_list = readSVs()
  if(filterdata){
    sv_list = filterSVs(sv_list, minlen, maxlen)
  }
  mq_events = sv_list[[1]]; hu_events = sv_list[[2]];
  # Read and filter data

  if(rm_alus){
    mq_events = subset(mq_events, Length < 275 | Length > 325)
    hu_events = subset(hu_events, Length < 275 | Length > 325)
  }
  # For Alu stuff

  cat("----------\nSubsetting macaque data...\n")
  mqr = subsetSVs(mq_events)
  mq_events_focal = mqr[[2]];
  mq_alleles = mqr[[4]]; mq_alleles_focal = mqr[[5]];

  cat("----------\nSubsetting human data...\n")
  hur = subsetSVs(hu_events)
  hu_events_focal = hur[[2]];
  hu_alleles = hur[[4]]; hu_alleles_focal = hur[[5]];
  # Subset data

  mq_denovo = subset(mq_events, Denovo=="Y")
  # Get macaque de novos
}

if(readonly){
  if(savelog){
    sink()
  }
  stop("Read only mode -- exiting.")
}
# Read the data
######################
# The counts for various subsets of data.
# EVENT = all CNVs in all individuals (ie a deletion at the same position in two individuals is counted as 2 events)
# ALLELE = all CNVs across individuals (ie a deletion at the same position in two individuals is counted as 1 allele)

cat("\nALL MACAQUE EVENTS:\n")
ind_means = avgInds(mq_events)
cat(spacedOut("Average CNVs per individual:",               pad, ind_means$num.cnvs), "(", ind_means$min.cnvs, "-", ind_means$max.cnvs, ")", "\n")
cat(spacedOut("Average bases deleted per individual:",      pad, ind_means$num.del.bases), "\n")
cat(spacedOut("Average bases duplicated per individual:",   pad, ind_means$num.dup.bases), "\n")
cat(spacedOut("Number of CNVs present in all individuals:", pad, 1755), "\n")
# Report average SVs per individual and number in all individuals.
# 1755 is hard coded because they are filtered out. Change lib/filter_svs.r to get.

svCount(mq_events, pad)

#cat("\nFOCAL MACAQUE EVENTS:\n")
#svCount(mq_events_focal, pad)

cat("\nALL MACAQUE ALLELES:\n")
svCount(mq_alleles, pad)

#cat("\nFOCAL MACAQUE ALLELES:\n")
#svCount(mq_alleles_focal, pad)

cat("\nDE NOVO MACAQUE ALLELES:\n")
svCount(mq_denovo, pad)

cat("\n----------\n")

cat("\nALL HUMAN EVENTS:\n")
svCount(hu_events, pad)

#cat("\nFOCAL HUMAN EVENTS:\n")
#svCount(hu_events_focal, pad)

cat("\nALL HUMAN ALLELES:\n")
svCount(hu_alleles, pad)

#cat("\nFOCAL HUMAN ALLELES:\n")
#svCount(hu_alleles_focal, pad)

cat("\n----------\n")

# The counts for various subsets of data
######################
# Brandler's de novo counts
cat("Counting Brandler de novos...\n")
brandler_denovo = read.csv("../cnv-calls/brandler-denovo.csv", header=TRUE)

brandler_denovo = subset(brandler_denovo, SVTYPE %in% c("DEL","DUP"))
names(brandler_denovo)[3] = "Length"
names(brandler_denovo)[11] = "Type"
brandler_denovo$Type = as.character(brandler_denovo$Type)
brandler_denovo$Type[brandler_denovo$Type=="DEL"] = "<DEL>"
brandler_denovo$Type[brandler_denovo$Type=="DUP"] = "<DUP>"

cat("\nDE NOVO BRANDLER ALLELES:\n")
svCount(brandler_denovo, pad)

cat("\n----------\n")
# Brandler's de novo counts
######################
# CAFE data
cat("CAFE DATA\n")
cafe_data = read.csv("../cafe-data/cafe-traits.csv", header=TRUE)
#cafe_data = subset(cafe_data, Node.type=="Tip")
cafe_data$genes.changed = cafe_data$Genes.gained + cafe_data$Genes.lost
cafe_data$perc.genes.gained = cafe_data$Genes.gained / cafe_data$genes.changed
cafe_data$perc.genes.lost = cafe_data$Genes.lost / cafe_data$genes.changed
# Read the CAFE data

cat("\nMACAQUE CAFE GENES:")

mq_changes = cafe_data$genes.changed[cafe_data$Node.ID=="Mmula"]
mq_gains = cafe_data$Genes.gained[cafe_data$Node.ID=="Mmula"]
mq_losses = cafe_data$Genes.lost[cafe_data$Node.ID=="Mmula"]
mq_gains_p = cafe_data$perc.genes.gained[cafe_data$Node.ID=="Mmula"]
mq_losses_p = cafe_data$perc.genes.lost[cafe_data$Node.ID=="Mmula"]

cat(spacedOut("Total changes:", pad, mq_changes), "\n")
cat(spacedOut("Losses:",        pad, paste(mq_losses, " (", mq_losses_p, ")", sep="")), "\n")
cat(spacedOut("Gains:",         pad, paste(mq_gains, " (", mq_gains_p, ")", sep="")), "\n")
# Macaque CAFE counts

cat("\n----------\n")

cat("\nHUMAN CAFE GENES:\n")

hu_changes = cafe_data$genes.changed[cafe_data$Node.ID=="Hsapi"]
hu_gains = cafe_data$Genes.gained[cafe_data$Node.ID=="Hsapi"]
hu_losses = cafe_data$Genes.lost[cafe_data$Node.ID=="Hsapi"]
hu_gains_p = cafe_data$perc.genes.gained[cafe_data$Node.ID=="Hsapi"]
hu_losses_p = cafe_data$perc.genes.lost[cafe_data$Node.ID=="Hsapi"]

cat(spacedOut("Total changes:", pad, hu_changes), "\n")
cat(spacedOut("Losses:",        pad, paste(hu_losses, " (", hu_losses_p, ")", sep="")), "\n")
cat(spacedOut("Gains:",         pad, paste(hu_gains, " (", hu_gains_p, ")", sep="")), "\n")
# CAFE data
# Human CAFE counts
######################
cat("\n----------\n")

if(savelog){
  sink()
}

cat("Done!")


add_test_results <- function (perf, modH){
	idx <- nrow(modH) + 1
	tab2 <- perf@metrics$cm$table

	modH[idx, 1] <- perf@metrics$model$name
	modH[idx, 2] <- round(1- perf@metrics$cm$table$Error[3], digits=3)
	modH[idx, 3] <- round(perf@metrics$mean_per_class_error, digits=3)
	modH[idx, 4] <- round(perf@metrics$logloss, digits=3)
	modH[idx, 5] <- round(perf@metrics$AUC, digits = 3)
	modH[idx, 6] <- round(perf@metrics$pr_auc, digits = 3)
	modH[idx, 7] <- round(tab2[2,2] / (tab2[2,2] + tab2[2,1]),digits=3)#recall
	modH[idx, 8] <- round(tab2[2,2] / (tab2[2,2] + tab2[1,2]),digits=3)# precision
	modH[idx, 9] <- round(tab2[1,1] / (tab2[1,1] + tab2[2,1]),digits=3)# Specificity
	modH[idx, 10] <- round(perf@metrics$max_criteria_and_metric_scores$value[1], digits=3)
	modH[idx, 11] <- round(perf@metrics$max_criteria_and_metric_scores$threshold[1], digits=3)

	return(modH)
}

##Loading top 5 GBM models
gbm_models <- c()
path <- "./hypeTune_results/top5_gbm_models_cv"
model_names <- grep("^GBM_model", list.files(path), value=T)
for(model in model_names){
	gbm_models <- c(gbm_models, h2o.loadModel(paste(path, model, sep = "/")))
}
#Now we have 5 models that we can use their "hyperTuned" parameters
gbm_models[[1]]@parameters

testRes <- new_resultFrame()
for(i in 1:5){
testRes <- add_test_results(h2o.performance(gbm_models[[i]], newdata=test), testRes)}

new_gbm <- do.call(h2o.gbm,

{
	p <- gbm_models[[1]]@parameters
	p$training_frame = train
	p$model_id <- "no_class_sr"
	p$sample_rate_per_class = NULL
	p
	})

testRes <- add_test_results(h2o.performance(new_gbm, newdata=test), testRes)

##We'll get back to this

gbm_cihi <- do.call(h2o.gbm,

{
	p <- gbm_models[[1]]@parameters
	p$model_id <- "gbm_cihi_cv_1"
	p$sample_rate = 0.79
	p$sample_rate_per_class = NULL
	p$training_frame = train
	p$validation_frame = test
	p$nfolds = 5
	p$fold_assignment = "Stratified"
	p$keep_cross_validation_prediction = TRUE
	p$keep_cross_validation_fold_assignment = TRUE
	p
	})
testRes <- add_test_results(h2o.performance(gbm_cihi, newdata=test), testRes)

bestModel <- gbm_cihi
bestModel %>% h2o.saveModel("./hypeTune_results/top_gbm_cihi_models_cv/")
sink("./hypeTune_results/top_gbm_cihi_models_cv/parameters.txt")
print(bestModel@parameters)
sink()

add_results(gbm_cihi, new_resultFrame()) %>% write.csv("./hypeTune_results/top_gbm_cihi_models_cv/test_train_results.csv")
bestModel@model$cross_validation_metrics@metrics$AUC
bestModel@model$validation_metrics@metrics$AUC
bestModel@model$training_metrics@metrics$AUC

###############
###############
# Tuning for ed-only model

hyper_params <- list(
	max_depth = seq(5,15,1),
	sample_rate = seq(0.4, 1, 0.01),
	# sample_rate_per_class = lapply(seq(0.4, 1, 0.01), function(x){x * c(0.12, 1)}),
	col_sample_rate = seq(0.4, 1, 0.01),
	col_sample_rate_per_tree = seq(0.4, 1, 0.01),
	col_sample_rate_change_per_level = seq(0.9, 1.1, .01),
	min_rows = 2 ^ seq(0, log2(nrow(df.split_valid[[1]]))-1,1),
	# nbins = 2 ^ seq(1,6, 1),
	# nbins_cats = 2 ^ seq(1,6, 1),
	min_split_improvement = c(0, 1e-8, 1e-6, 1e-4),
	histogram_type = c("UniformAdaptive", "QuantilesGlobal", "RoundRobin")
)

search_criteria = list(
strategy = "RandomDiscrete", #random grid search
max_runtime_secs = 3600 * 8,
max_models = 500,
seed = 1234,
stopping_rounds = 5,
stopping_metric = "AUCPR", #Try with AUC also
stopping_tolerance = 1e-3
)

df.split_valid <- h2o.splitFrame(train, ratios = c(0.8), seed = 1234) #validation set to size of 5-fold

t <- Sys.time()
grid <- h2o.grid(
hyper_params = hyper_params,
search_criteria = search_criteria,
algorithm = "gbm",
grid_id = "gbm_cihi_grid",
# nfolds = 5,
# fold_assignment = "Stratified",
balance_classes = TRUE,
x = sel_feat_ed_big,
y = "alc_status",
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
nbins_cats = 16, # instead of 1024 default
ntrees = 10000,
learn_rate = 0.05,
learn_rate_annealing = 0.99,
max_runtime_secs = 3600, #for each model
stopping_rounds = 5,
stopping_metric = "AUCPR", #Try with AUC also
stopping_tolerance = 1e-3,
score_tree_interval = 10,
seed = 1234
)
print(Sys.time() - t)

sortedGrid <- h2o.getGrid("gbm_cihi_grid", sort_by = "AUCPR", decreasing = TRUE)
sortedGrid
gridtop5 <- new_resultFrame()
for (i in 1:5){
	gbm <- h2o.getModel(sortedGrid@model_ids[[i]])
	gridtop5 <- add_results(gbm, gridtop5)

}

gbm_first <- do.call(h2o.gbm,
{
	p <- h2o.getModel(sortedGrid@model_ids[[1]])@parameters
	p$sample_rate = NULL
	p
})

gridtop5 <- add_results(gbm_first, gridtop5)

#sample rate actually helps here, higher training accuracy but slightly less test, so lets keep it!
####Taking a closer look at top 5 models
##Doing a 5fold cv
gridtop5_cv <- new_resultFrame()
for (i in 1:5){
	gbm <- h2o.getModel(sortedGrid@model_ids[[i]])
	cvgbm <- do.call(h2o.gbm,
	#update parameters of CV models
	{
		p <- gbm@parameters
		p$model_id = NULL
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = 5
		p$fold_assignment = "Stratified"
		p$keep_cross_validation_prediction = TRUE
		p$keep_cross_validation_fold_assignment = TRUE
		p
	})
	print(gbm@model_id)
	gridtop5_cv <- add_cv_results(cvgbm, gridtop5_cv) #its supposed to not use unseen test yet, only after coming up with the best model
	gridtop5_cv$Model[nrow(gridtop5_cv)] <- gbm@model_id
}
gridtop5_cv
> gridtop5_cv
                    # Model Hit_Ratio Mean_PerC_Error LogLoss   AUC AUCPR Recall Precision
# 1  gbm_cihi_grid_model_62     0.795           0.346   0.326 0.738 0.288  0.467     0.284
# 2 gbm_cihi_grid_model_159     0.803           0.350   0.326 0.738 0.288  0.449     0.290
# 3  gbm_cihi_grid_model_25     0.798           0.348   0.326 0.738 0.289  0.461     0.286
# 4 gbm_cihi_grid_model_139     0.797           0.347   0.326 0.737 0.288  0.464     0.285
# 5 gbm_cihi_grid_model_207     0.800           0.349   0.327 0.737 0.287  0.454     0.288
  # Specificity max_F1 trshold training_AUC training_AUCPR training_Recall
# 1       0.921  0.353   0.164        0.771          0.769           0.860
# 2       0.919  0.353   0.174        0.751          0.742           0.872
# 3       0.920  0.353   0.171        0.758          0.750           0.876
# 4       0.920  0.353   0.167        0.758          0.752           0.876
# 5       0.919  0.352   0.170        0.760          0.753           0.884
  # training_Precision training_Spec
# 1              0.624         0.775
# 2              0.603         0.769
# 3              0.608         0.778
# 4              0.606         0.776
# 5              0.605         0.785

bestModel <- cvgbm
bestModel %>% h2o.saveModel("./hypeTune_results/top_gbm_ed_models_cv/")
sink("./hypeTune_results/top_gbm_ed_models_cv/parameters.txt")
print(bestModel@parameters)
sink()

add_results(cvgbm, new_resultFrame()) %>% write.csv("./hypeTune_results/top_gbm_ed_models_cv/test_train_results.csv")
bestModel@model$cross_validation_metrics@metrics$AUC
bestModel@model$validation_metrics@metrics$AUC
bestModel@model$training_metrics@metrics$AUC

###Save the best and write hyptune parameters


setwd("E:/code/R")
a<-read.csv("2020 November General Election - Turnout Rates.csv")
library("caret")
head(a)
w=createDataPartition(y=a$Parole,p=0.7,list=FALSE)
train=a[w,]
test=a[-w,]
print(train)
print(test)
print(nrow(a))
print(nrow(train))
print(nrow(test))


#' Plot catch at age consistency
#'
#' Lattice style plot of catch at age X vs age Y with each point a cohort for each fleet. Computed for both input and predicted catch at age.
#' @param asap name of the variable that read in the asap.rdat file
#' @param fleet.names names of fleets
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @return list with correlation matrices for input and predicted catch at age matrices for each fleet
#' @export

PlotCatchAtAgeConsistency <- function(asap,fleet.names,save.plots,od,plotf){
  cat.corr <- list()
  for (ifleet in 1:asap$parms$nfleets){
    if (asap$parms$nfleets == 1) title1 = "Catch"
    if (asap$parms$nfleets >= 2) title1 = paste0("Catch for Fleet ",ifleet," (",fleet.names[ifleet],")")

    # get catch at age
    s.age <- asap$fleet.sel.start.age
    e.age <- asap$fleet.sel.end.age
    catchob <- wtprop2caa(asap$catch.obs[ifleet,],
                          asap$WAA.mats[[(ifleet*2-1)]][, s.age:e.age],
                          asap$catch.comp.mats[[(ifleet*4-3)]])
    catchpr <- wtprop2caa(asap$catch.pred[ifleet,],
                          asap$WAA.mats[[(ifleet*2-1)]][, s.age:e.age],
                          asap$catch.comp.mats[[(ifleet*4-2)]])

    # replace zeros with NA and take logs
    cob <- rep0log(catchob)
    cpr <- rep0log(catchpr)

    # make cohorts
    cob.coh <- makecohorts(cob)
    cpr.coh <- makecohorts(cpr)

    # make the plots
    cob.cor <- PlotCoh(cob.coh,save.plots,od,plotf,mytitle=paste0(title1," Observed"))
    cpr.cor <- PlotCoh(cpr.coh,save.plots,od,plotf,mytitle=paste0(title1," Predicted"))
    cat.corr[[ifleet]] <- list(cob.cor,cpr.cor)
  }
  return(cat.corr)
}


# prepare_sex_age_data_mcd.r
# Author: David Van Riper
# Date: 2020-10-12
#
# This script creates three long data frames - SF1, v1 (Oct 2019) and v2 (June 2020) - and adds sex and age recodes to each record

#### Load packages ####
require(tidyverse)

#### Factor parameters ####
sex_levels <- c(0,1)
sex_labels <- c("M", "F")

age_grp_levels <- c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,100,200,300,400,500,600,700,800,900,1000,1100,1200,1300,1400,1500,1600,1700,1800,1900,2000)
age_grp_labels <- c("0-4", "5-9", "10-14", "15-19", "20-24", "25-29", "30-34", "35-39", "40-44", "45-49", "50-54", "55-59", "60-64", "65-69", "70-74", "75-79", "80-84", "85+", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19")

version_levels <- c("sf", "v1", "v2")
version_labels <- c("sf", "v1", "v2")

#### Select records for Massachussetts ####
v2 <- v2 %>%
  filter(state == "25")

v1 <- v1 %>%
  mutate(state = str_sub(gisjoin, 2,3)) %>%
  filter(state == "25")

#### Create a gisjoin - name fc ####
mcd_name <- v1 %>%
  select(gisjoin, name_sf)

# remove city town and Town from name_sf
mcd_name <- mcd_name %>%
  mutate(name = name_sf) %>%
  mutate(name = str_remove(name, "city"),
         name = str_remove(name, "Town"),
         name = str_remove(name, " town"),
         name = str_trim(name))

#### Create pop size categories for MCDs in MA ####
mcd_pop <- v1 %>%
  select(gisjoin, H7V001_sf) %>%
  mutate(pop_bin = case_when(H7V001_sf < 1000 ~ 1,
                             H7V001_sf >= 1000 & H7V001_sf < 2500 ~ 2,
                             H7V001_sf >= 2500 & H7V001_sf < 5000 ~ 3,
                             H7V001_sf >= 5000 & H7V001_sf < 10000 ~ 4,
                             H7V001_sf >= 10000 & H7V001_sf < 25000 ~ 5,
                             H7V001_sf >= 25000 & H7V001_sf < 50000 ~ 6,
                             H7V001_sf > 50000 ~ 7))

# factor pop_bin
mcd_pop$pop_bin <- factor(mcd_pop$pop_bin, labels = c("< 1k", "1 - 2.5k", "2.5 - 5k", "5 - 10k", "10 - 25k", "25 - 50k", "> 50k"))

#### Create an SF1, v1, and v2 df with just age/sex variables ####
sf <- v2 %>%
  select(gisjoin, H76001_sf:H76049_sf, H78001_sf:H78043_sf)

v2 <- v2 %>%
  select(gisjoin, H76001_dp:H76049_dp, H78001_dp:H78043_dp)

v1 <- v1 %>%
  select(gisjoin, H76001_dp:H76049_dp, H78001_dp:H78043_dp)

#### Create long dfs for sf, v2, and v1s ####
# pivot longer, separate var into multiple parts and add a version value
long_sf <- sf %>%
  pivot_longer(H76001_sf:H78043_sf, names_to = "var", values_to = "n") %>%
  separate(var, into = c("var_code", "version"), sep = "_")

long_v2 <- v2 %>%
  pivot_longer(H76001_dp:H78043_dp, names_to = "var", values_to = "n") %>%
  separate(var, into = c("var_code", "version"), sep = "_") %>%
  mutate(version = "v2")

long_v1 <- v1 %>%
  pivot_longer(H76001_dp:H78043_dp, names_to = "var", values_to = "n") %>%
  separate(var, into = c("var_code", "version"), sep = "_") %>%
  mutate(version = "v1")

#### Row bind all sex by age by race counts into single df ####
df <- bind_rows(long_sf, long_v1)
df <- bind_rows(df, long_v2)

#### Remove unneeded dfs ####
rm(v1)
rm(v2)
rm(sf)
rm(list = ls(pattern = "^long"))

#### Join recodes to df ####
df <- df %>%
  left_join(recode, by = c("var_code" = "var"))

#### Create final sex/age df ####
# group by county, version, age_grp, sex
# drop NA values before creating the final df
df_sa <- df %>%
  filter(!is.na(age_grp)) %>%
  group_by(gisjoin, version, age_grp, sex) %>%
  summarise(n = sum(n))

#### Split df_sa on age_grp to create a 5-year age bin df and a single year of age df ####
df_sa_5year <- df_sa %>%
  filter(age_grp < 100)

df_sa_1year <- df_sa %>%
  filter(age_grp > 99)

#### Apply factors to version sex, and age_grp ####
df_sa_5year$sex <- factor(df_sa_5year$sex, levels = sex_levels, labels = sex_labels)
df_sa_5year$version <- factor(df_sa_5year$version, levels = version_levels, labels = version_labels)
df_sa_5year$age_grp <- factor(df_sa_5year$age_grp, levels = age_grp_levels, labels = age_grp_labels)

df_sa_1year$sex <- factor(df_sa_1year$sex, levels = sex_levels, labels = sex_labels)
df_sa_1year$version <- factor(df_sa_1year$version, levels = version_levels, labels = version_labels)
df_sa_1year$age_grp <- factor(df_sa_1year$age_grp, levels = age_grp_levels, labels = age_grp_labels)

#### Save to rds files ####
saveRDS(df_sa_1year, "data/df_sa_1year_MA_mcd.rds")
saveRDS(df_sa_5year, "data/df_sa_5year_MA_mcd.rds")


#' @title Generate data
#'
#' @description
#' Generates a data.frame that can then be passed to a model to predict the
#' effects of particular variables with the other variables held constant.
#'
#' @details
#' Unless a variable is named in range it is fixed at its base value.
#' A continuous variable's base value is its mean value
#' of the same class, i.e., an integer variable's base value is its rounded mean.
#' A logical variable's base value is FALSE while a factor's is
#' its first level.
#'
#' Alternatively if a variable is named in range then a sorted sequence of
#' unique values of the same class
#' from the minimum to the maximum of the observed values with a
#' length of up to length_out (by default 30) is generated. If length_out is less
#' than the number of possible values then in the case of a continous variable the
#' values are as evenly distributed as possible while in the case of a factor only
#' the first length_out levels are selected.
#'
#' @param data data.frame of variables from which the data.frame will be generated
#' @param range character vector of the variables in data to
#' represent by a sequence of values or NULL (the default)
#' @param length_out integer scalar of the maximum number of values in a sequence
#' @return The generated data.frame which can then be passed to a model for the
#' purpose of estimating the effects of particular variables.
#' @examples
#' data <- data.frame(numeric = 1:10 + 0.1, integer = 1:10,
#'    factor = factor(1:10), date = as.Date("2000-01-01") + 1:10,
#'    posixt = ISOdate(2000,1,1) + 1:10)
#'
#' generate_data (data)
#' generate_data (data, range = "numeric")
#' generate_data (data, range = c("date", "factor"))
#' generate_data (data, range = c("numeric"))
#'
#' @export
generate_data <- function (data, range = NULL, length_out = 30) {

  warning("generate_data is deprecated in datalist 0.3 for new_data")

  return (new_data(data, sequence = range, length_out = length_out))
}


source("tests.r")
library(nlme)

cat("Testing stepAIC...\n")
# Prepare objects and calls for testing.
calls <- list(
	glm = substitute(
		glm(
			Sepal.Length ~ Species + Petal.Length,
			data = iris, family = gaussian
		)
	),
	lm = substitute(lm(Sepal.Length ~ Species + Petal.Length, data = iris)),
	lme = substitute(
		lme(
			Sepal.Length ~ Species + Petal.Length, random = ~1 | Species,
			data = iris, method = "ML"
		)
	)
)

objects <- lapply(calls, eval)

# do MASS::stepAIC.
result.stepAIC <- lapply(objects, MASS::stepAIC, trace = FALSE)

# Test result of stepAIC does not produce errors.
expect_silent(
	null <- lapply(result.stepAIC, model.adapter$new)
)

# Remove objects.
rm(calls, objects, result.stepAIC, null)


## -----------------------------------------------------------------------------------------------------
## analyze_game_data.r
## Author: Amelia Bertozzi-Villa
## Date: April 15th 2018
## Description: Make descriptive plots and tables included in game analysis.
## -----------------------------------------------------------------------------------------------------

library(data.table)
library(ggplot2)
library(stringr)
library(Hmisc)
library(scales)

rm(list=ls())

## set ggtheme
theme_set(theme_minimal())

## load data
in_dir <- "/Users/bertozzivill/Dropbox/main/Collaborations/my_future_family/chennai_2018/data_090818/clean/"

all_data <- fread(file.path(in_dir, "all_game_data.csv"))
milestones <- fread(file.path(in_dir, "milestones.csv"))
demog <- fread(file.path(in_dir, "demog.csv"))

## remove some values where they were still playing the old game
demog <- demog[self.report.sex %in% c("male", "female")]
demog <- demog[, list(user.id, event.id, age, self.report.sex)]

## Age distribution by sex
age_dist <- ggplot(demog, aes(x=age)) +
            geom_bar(aes(fill=self.report.sex, color=self.report.sex), alpha=0.7) +
            facet_grid(~self.report.sex) +
            theme(legend.title = element_blank()) +
            labs(title="Distributions of Reported Age, by Sex",
                 x="Reported Age",
                 y="Count")

##  Milestone analysis ---------------------------------------------------------------------------------------------

milestones <- merge(milestones, demog[, list(user.id, age, self.report.sex)],
                    by="user.id", all.y=T)

# format data about age and number of marriage and children
marriage_age <- milestones[event.name=="marriage" & key=="age"]
marriage_age <- marriage_age[, list(user.id, self.report.sex, age, wants.marriage=T, marriage.age=as.integer(value))]

no_marriage_age <- milestones[event.name=="marriage" & key=="skip" & value=="yes",
                              list(user.id, self.report.sex, age, wants.marriage=F, marriage.age=NA)]
marriage_data <- rbind(marriage_age, no_marriage_age)

children_age <- milestones[event.name =="children" & key=="baby"]
children_age[, child.sex:= gsub(" .*", "", value)]
children_age[, age.at.child:=as.integer(gsub(".* ", "", value))]
children_age[, child.idx:= rowid(user.id)]
children_age[, child.count:= .N, by="user.id"]
children_age <- children_age[, list(user.id, self.report.sex, age, wants.children=T,
                                    child.count, child.sex, age.at.child, child.idx)]

no_children_age <- milestones[event.name=="children" & key=="skip" & value=="yes",
                              list(user.id, self.report.sex, age, wants.children=F,
                                   child.count=NA, child.sex=NA, age.at.child=NA, child.idx=NA)]

children_data <- rbind(children_age, no_children_age)

family_data <- merge(marriage_data, children_data, by=c("user.id", "self.report.sex", "age"), all=T)

## plot distribution of reported age vs age at events (before imposing age restrictions)

age_comparison <- melt(family_data[(wants.marriage==T | wants.children==T) & (is.na(child.idx) | child.idx==1)],
                       id.vars=c("user.id", "self.report.sex", "age"),
                       measure.vars=c("marriage.age", "age.at.child"),
                       variable.name = "event", value.name="age.at.event")
age_comparison[, event := ifelse(event=="age.at.child", "First Child", "Marriage")]
age_comparison <- age_comparison[, list(count=.N), by=list(event, self.report.sex,
                                                           age, age.at.event)]
age_comparison[, event:=factor(event, levels=c("Marriage", "First Child"))]

age_milestone_compare <- ggplot(age_comparison[!is.na(age.at.event)], aes(x=age, y=age.at.event)) +
                          geom_point(aes(color=self.report.sex, size=count), alpha=0.75) +
                          scale_color_discrete(guide=FALSE) +
                          facet_grid(event ~ self.report.sex) +
                          geom_vline(xintercept=19) +
                          geom_abline(intercept=0, slope=1) +
                          theme(legend.title = element_blank(),
                                text=element_text(size=14)) +
                          labs(x="Reported Age",
                               y="Desired Age at Event",
                               title="Reported Age vs Desired Age At Milestone")

## Drop ages not within 13-19
milestones <- milestones[age>=13 & age<=19]
family_data <- family_data[age>=13 & age <=19]
age_comparison <- age_comparison[age>=13 & age<=19]

## Plot: What age do people want to get married/have their first child?
age_plot <- ggplot(age_comparison, aes(x=age.at.event)) +
            geom_bar(aes(fill=self.report.sex, color=self.report.sex), alpha=0.75) +
            facet_grid(event~self.report.sex) +
            theme(legend.position="none",
                  text=element_text(size=14)) +
            labs(title="Desired Age of Milestones, by Sex",
                 x="Age",
                 y="Count")

write.csv(age_comparison, file=paste0(in_dir, "marriage_child_age.csv"), row.names=F)

## Plot: how many kids do people want? What Sex?
child_count_plot <- ggplot(family_data[child.count>0], aes(x=child.count)) +
                    geom_bar(aes(fill=self.report.sex, color=self.report.sex), alpha=0.75) +
                    facet_grid(~self.report.sex) +
                    theme(legend.position="none",
                          text=element_text(size=14)) +
                    labs(title="Desired Number of Children, by Sex",
                         x="# of Children",
                         y="Count")

children_age[, self.report.sex:= paste(self.report.sex, "Respondent")]
children_age[, child.sex:= paste(child.sex, "Child")]

child_sex_plot <- ggplot(children_age, aes(x=child.idx)) +
                    geom_bar(aes(fill=child.sex, color=child.sex), alpha=0.75) +
                    facet_grid(~self.report.sex) +
                    theme(legend.title = element_blank(),
                          text=element_text(size=14)) +
                    labs(title="Desired Sex of Each Child, by Respondent Sex",
                         x="Child",
                         y="Count")

# Plot: Who influences life choices?
influencers <- milestones[key %like% "influencer", list(user.id, influencer=value, self.report.sex,
                                                  milestone=capitalize(event.name))]
influencer_order <- influencers[, list(count=sum(.N)), by=influencer][order(count)]$influencer
influencers[, influencer:= factor(influencer, levels=influencer_order)]
influencers[, milestone:=factor(milestone, levels=c("Graduation", "Lifepartner", "Marriage", "Children"))]
colors = brewer_pal(type="div", palette="Spectral")(7)

influence_plot <- ggplot(influencers, aes(x=milestone)) +
                  geom_bar(aes(fill=influencer, color=influencer), alpha=0.8) +
                  facet_grid(~self.report.sex) +
                  theme(legend.title = element_blank(),
                        axis.text.x = element_text(angle=45, hjust=1),
                        text=element_text(size=14)) +
                  scale_color_manual(values=colors) +
                  scale_fill_manual(values=colors) +
                  labs(title="Milestone Influencers, by Sex",
                       x="Milestone",
                       y="Count")

## table for paper: influencer percent
influence_perc <- influencers[, list(count=.N), by=list(self.report.sex, milestone, influencer)]
influence_perc[, perc:=count/sum(count)*100, by=list(self.report.sex, milestone)]
influence_perc <- dcast(influence_perc, self.report.sex + milestone ~ influencer, value.var = "perc")

## --------------------------------------------------------------------------------------------------------------
## save plots

plots <- Filter( function(x) 'ggplot' %in% class( get(x) ), ls() )

pdf(paste0(in_dir, "plots/game_plots.pdf"), width=11, height=8.5)

for (plot in plots){
  print(get(plot))
}
graphics.off()

for (plot in plots){
  png(paste0(in_dir, "plots/", plot, ".png"), height=900, width=1200, units = "px", res=140)
  print(get(plot))
  graphics.off()
}


library(data.table)

source('../../functions.r')

load('mcmc-results.rdata', v=T)

spplist <- fread('../../input-data/species-list.csv')[base_species == T]
setkeyv(spplist, 'code')

sppdem <- fread('../../input-data/demographic-parameters-processed.csv')

## * PST
if ('ntot' %in% mc_attributes$vartype) {
    cat('\tCalculating PST...\n')

    ntots <- mcmc[variable %in% mc_attributes[vartype == 'ntot', variable]]
    ntots[mc_attributes, species := i.species, on = 'variable']

    n_samples <- max(mcmc$sample)

    spp <- spplist$code

    pstfun <- function(sp1) {

        age_first_breeding <- sppdem[species == sp1 & parameter == 'age_first_breeding', rnorm(n_samples, mean, sd)]
        survival_optimal   <- sppdem[species == sp1 & parameter == 'survival_optimal',   rlnorm(n_samples, mean_log, sd_log)]
        population_total   <- ntots[species == sp1, value]

        rmax_nl <- Rmax_NL(survival_optimal, age_first_breeding)

        pst_nl <- 0.5 * population_total * rmax_nl

        return(data.table(species = sp1, sample = 1:n_samples, pst_nl = pst_nl,
                          rmax_nl = rmax_nl, population_total = population_total))
    }
    pst_samples <- rbindlist(lapply(spp, pstfun))

    ## * Add overall nu correction ##
    nu <- 0.5
    pst_samples[, pst_nlc := pst_nl * nu]

    ## Save
    saveRDS(pst_samples, file = 'pst-samples.rds')

    pstsumm <- pst_samples[, .(mean = mean(pst_nlc),
                              lcl = quantile(pst_nlc, 0.025, names = F),
                              ucl = quantile(pst_nlc, 0.975, names = F)), species]

    fwrite(pstsumm, 'pst-samples-summary.csv')

} else {
    pst_samples <- NULL
    if (any(file.exists(c('pst-samples-summary.csv', 'pst-samples.rds')))) {
        file.remove(c('pst-samples-summary.csv', 'pst-samples.rds'))
    }
}

## * Risk ratio

if (!is.null(pst_samples)) {
    cat('\tCalculating risk ratios...\n')

    ## * APF
    mcsel <- mcmc[variable %in% mc_attributes[role == 'month1_spatial0' & vartype == 'apf_t', variable]]
    mcsel <- merge(mcsel, mc_attributes, by = 'variable', all.x=T, all.y=F)
    apf <- mcsel[, .(apf = sum(value)), .(species, sample)]

    ## * Risk
    risk_ratio <- merge(pst_samples, apf, by = c('species', 'sample'))
    risk_ratio[, riskratio := apf / pst_nlc]

    saveRDS(risk_ratio, 'risk-ratios.rds')

    ## * Summarise
    risk_summ <- risk_ratio[, .(mean = mean(riskratio),
                               sd   = sd(riskratio),
                               lcl  = quantile(riskratio, 0.025, names = F),
                               ucl  = quantile(riskratio, 0.975, names = F)), species]
    risk_summ <- merge(spplist[, .(code, taxa, common_name)], risk_summ, by.x = 'code', by.y = 'species')
    fwrite(risk_summ, 'risk-ratios-summary.csv')

} else {
    cat('No PST was calculated. Skipping calculation of risk\n')
    if (any(file.exists(c('risk-ratios.rds', 'risk-ratios-summary.csv')))) {
        file.remove(c('risk-ratios.rds', 'risk-ratios-summary.csv'))
    }
}


##predefined_condition_begin
#setwd("/scratch/cqs/shengq1/rnaseq/20150226_bojana_FFPE_FF/hiseq/star_deseq2/result")
#
#data<-read.table("/scratch/cqs/shengq1/rnaseq/20150226_bojana_FFPE_FF/hiseq/star_genetable/result/FFPE_FF_HiSeq_gene.count",row.names=1, header=T, check.names=F)
#
#showLabelInPCA<-1
#showDEGeneCluster<-1
#pvalue<-0.05
#foldChange<-2
#
#comparisons=list(
#  "HiSeq_FFPE2_VS_FF2_NoMismatch" = c("HiSeq_FFPE2_VS_FF2_NoMismatch.design", "HiSeq_FF_NoMismatch", "HiSeq_FFPE_NoMismatch")
#)
#
##predefined_condition_end

options(bitmapType='cairo')

library("edgeR")

data<-data[,colnames(data) != "Feature_length"]
colClass<-sapply(data, class)
countNotNumIndex<-which(colClass!="numeric" & colClass!="integer")
if (length(countNotNumIndex)==0) {
  index<-1;
  indecies<-c()
} else {
  index<-max(countNotNumIndex)+1
  indecies<-c(1:(index-1))
}

countData<-data[,c(index:ncol(data))]
countData[is.na(countData)] <- 0
countData<-round(countData)

if(addCountOne){
  countData<-countData+1
}

comparisonNames=names(comparisons)
comparisonName=comparisonNames[1]

for(comparisonName in comparisonNames){
  str(comparisonName)
  designFile=comparisons[[comparisonName]][1]
  gnames=comparisons[[comparisonName]][2:3]
  designData<-read.table(designFile, sep="\t", header=T)
  designData$Condition<-factor(designData$Condition, levels=gnames)

  if(ncol(designData) == 3){
    ispaired<-TRUE
    cat("Paired data!\n")
  }else{
    ispaired<-FALSE
    cat("Not paired data!\n")
  }

  comparisonData<-countData[,colnames(countData) %in% as.character(designData$Sample),drop=F]
  if(ncol(comparisonData) != nrow(designData)){
    warning(paste0("Data not matched, there are ", nrow(designData), " samples in design file ", designFile, " but ", ncol(comparisonData), " samples in data "))
    next
  }
  comparisonData<-comparisonData[,as.character(designData$Sample)]

  prefix<-comparisonName
  curdata<-data
  if(minMedianInGroup > 0){
    conds<-unique(designData$Condition)
    data1<-comparisonData[, colnames(comparisonData) %in% designData$Sample[designData$Condition==conds[1]]]
    data2<-comparisonData[, colnames(comparisonData) %in% designData$Sample[designData$Condition==conds[2]]]
    med1<-apply(data1, 1, median) >= minMedianInGroup
    med2<-apply(data2, 1, median) >= minMedianInGroup
    med<-med1 | med2
    comparisonData<-comparisonData[med,]
    cat(nrow(comparisonData), " genes with minimum median count in group larger or equals than ", minMedianInGroup, "\n")
    prefix<-paste0(comparisonName, "_min", minMedianInGroup)
    curdata<-data[med,]
  }

  notEmptyData<-apply(comparisonData, 1, max) > 0
  comparisonData<-comparisonData[notEmptyData,]
  curdata<-curdata[notEmptyData,]

  if(ispaired){
    colnames(comparisonData)<-unlist(lapply(c(1:ncol(comparisonData)), function(i){paste0(designData$Paired[i], "_", colnames(comparisonData)[i])}))
  }
  rownames(designData)<-colnames(comparisonData)
  conditionColors<-as.matrix(data.frame(Group=c("red", "blue")[designData$Condition]))

  #different expression analysis
	condition<-designData$Condition
  if(ispaired){
  	subject<-designData$Paired
  	design <- model.matrix(~subject+condition)
  }else{
  	design <- model.matrix(~condition)
  }
  y<-DGEList(comparisonData)
  y <- estimateGLMCommonDisp(y,design)
  y <- estimateGLMTrendedDisp(y,design)
  y <- estimateGLMTagwiseDisp(y,design)
  fit <- glmFit(y,design)
  lrt <- glmLRT(fit,coef=2)
  res<-topTags(lrt)

  cat("EdgeR finished.\n")

  select<-(!is.na(res$padj)) & (res$padj<pvalue) & ((res$log2FoldChange >= log2(foldChange)) | (res$log2FoldChange <= -log2(foldChange)))

  if(length(indecies) > 0){
    inddata<-curdata[,indecies,drop=F]
    tbb<-cbind(inddata, comparisonData, res)
  }else{
    tbb<-cbind(comparisonData, res)
  }
  tbbselect<-tbb[select,,drop=F]

  tbb<-tbb[order(tbb$padj),,drop=F]
  write.csv(as.data.frame(tbb),paste0(prefix, "_DESeq2.csv"))

  tbbselect<-tbbselect[order(tbbselect$padj),,drop=F]
  write.csv(as.data.frame(tbbselect),paste0(prefix, "_DESeq2_sig.csv"))

  if(showDEGeneCluster){
    siggenes<-rownames(rldmatrix) %in% rownames(tbbselect)

    nonDEmatrix<-rldmatrix[!siggenes,,drop=F]
    DEmatrix<-rldmatrix[siggenes,,drop=F]

    drawPCA(paste0(prefix,"_geneNotDE"), nonDEmatrix, showLabelInPCA, designData, conditionColors)
    drawHCA(paste0(prefix,"_geneNotDE"), nonDEmatrix, ispaired, designData, conditionColors, gnames)

    drawHCA(paste0(prefix,"_geneDE"),DEmatrix , ispaired, designData, conditionColors, gnames)
    #drawHCA(paste0(prefix,"_gene500NotDE"), nonDEmatrix[1:min(500, nrow(nonDEmatrix)),,drop=F], ispaired, designData, conditionColors, gnames)
  }
}

if(length(pairedspearman) > 0){
  #draw pca graph
  filename<-ifelse(minMedianInGroup > 0, paste0("spearman_min", minMedianInGroup, ".png"), "spearman.png")
  png(filename=filename, width=1000 * length(pairedspearman), height=2000, res=300)
  boxplot(pairedspearman)
  dev.off()
}


#!/usr/local/bin/Rexec
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#
# usage: graph.r <name>    name of the dataset
#                <nvars>   number of parameters used
#                <index>   index of the parameters' permutation
#                <seed>    seed of the genetic algorithm
#                [scale]   scaling of original data [default to 1]
#                [trans]   translation of original data [default to 0]
#
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

# Init arguments list ----
args <- commandArgs()
args_start = grep("--args", args) + 1

if (length(args_start) > 0 && args_start < length(args)) {
    args <- args[args_start:length(args)]
} else {
    args = c()
}

require(data.table)

# Utilities ----

idxparms <- function(nvars, index) {
    #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    #  Each index is a specific permutation of
    #  the current number of parameters used over
    #  the 8 possible parameters.
    #
    #  example
    #  nvars = 5; index = 3
    #  permutation = 0 0 1 1 0 1 1 1
    #
    #  that is, simulations with nvars(5
    #  and index(3) will use the 3rd, 4th
    #  6th, 7th and 8th kernel of the
    #  equation, and only the corresponding
    #  parameters will be searched for.
    #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

    require(gtools)

    p = permutations(8, 8)

    # put to zero parameters > nvars
    p = p * (p > (8 - nvars)) - (8 - nvars)

    p = p * (p > 0)

    # put to one all other parameters
    # we need only the position in
    # the sequence
    p = unique(1 * (p > 0))

    # get the sequence at
    # position "index"
    p = p[index,]

    return(p)
}

g_table <- function(nvars, params, FVU, file_name) {
    tabl = c()

    tabl = rbind(tabl, c('Number of components:', nvars))
    tabl = rbind(tabl, c('FVU:', FVU))
    tabl = rbind(tabl, c('Onset amplification:', params[3]))
    tabl = rbind(tabl, c('pre-synaptic tau:', params[1]))
    tabl = rbind(tabl, c('post-synaptic tau:', params[2]))

    require(xtable)
    print.xtable(
        xtable(tabl, align = "rrl"),
        type = "latex",
        file = paste(file_name, '-params_table.tex', sep = ''),
        include.rownames = FALSE,
        include.colnames = FALSE,
        hline.after = FALSE
    )
}

g_kernels <- function(pars, file_name) {
    postscript(
        paste(file_name, '-used_kernels.eps', sep = ''),
        onefile = FALSE,
        horizontal = FALSE,
        pointsize=6,
        width = 2.5,
        height = 1.67
    )

    par(mar = c(5, 4, 2, 2) + .1)
    pidx = (1:8)[pars != 0]

    labels = c(
        expression(sigma[pp]),
        expression(sigma[np]),
        expression(sigma[pn]),
        expression(sigma[nn]),
        expression(eta[ps]),
        expression(eta[sp]),
        expression(eta[ns]),
        expression(eta[sn])
    )

    plot(
        pidx,
        pars[pidx],
        cex = 1,
        cex.lab = 2,
        xlim = c(.5, 8.5),
        ylim = c(-1.3, 1.3),
        axes = FALSE,
        xlab = "Component type",
        ylab = ''
    )

    pp = pars[pidx]
    pp = as.matrix(pp)
    arrows(pidx,
           pp * 0,
           pidx,
           pp,
           lwd = 1,
           length = 0.08)

    points(1:8, pars * 0, cex = .05)

    for (x in 1:length(pidx)) {
        text(pidx[x],
             pars[pidx[x]]
             + .3 * (pars[pidx[x]] / abs(pars[pidx[x]])),
             format(pars[pidx[x]],
                    digits = 2),
             cex = 1.2)
    }

    axis(
        1,
        at = 1:8,
        labels = labels,
        lwd = 0,
        cex.axis = 1.5
    )

    axis(2,
         at = seq(-1, 1, 1),
         lwd = 1,
         cex.axis = 1.5)

    dev.off()

}

g_fitting <- function(data, regression, file_name) {
    postscript(
        paste(file_name, '-data_fitting.eps', sep = ''),
        onefile = FALSE,
        horizontal = FALSE,
        width = 6,
        height = 6,

    )

    data = data[order(data[, 1]),]
    data_plus_regression = c(data[, 2], regression[, 2])

    dr = c(max(data[, 1]) - min(data[, 1]),
           max(data_plus_regression) - min(data_plus_regression))
    drg = c(dr[1] * (.1 / 2), dr[2] * (.1 / 2))

    ylim = c(min(data_plus_regression) - drg[2] ,
             max(data_plus_regression) + drg[2])

    xlim = c(min(data[, 1]) - drg[1] ,  max(data[, 1]) + drg[1])

    print(xlim)
    plot(
        axes = FALSE,
        xlab = "",
        ylab = "",
        frame.plot = FALSE,
        data,
        ylim = ylim,
        xlim = xlim
    )

    arrows(
        c(min(data[, 1]) - drg[1]  ,  0),
        c(0                       ,  min(data_plus_regression) - drg[2]),
        c(max(data[, 1]) + drg[1]  ,  0),
        c(0                       ,  max(data_plus_regression) + drg[2]),
        length = .08,
        lwd = 3
    )

    lines(regression, lwd = 6)
    points(data, pch = 19, col = "#ffffff")

    points(data)

    lab = "Delta*t"
    lab = eval(parse(text = paste('expression(', lab, ')')))

    text(xlim[2],-.1 * (ylim[2] - ylim[1]), lab, cex = 2)
    lab = "-Delta*t"
    lab = eval(parse(text = paste('expression(', lab, ')')))

    text(xlim[1],-.1 * (ylim[2] - ylim[1]), lab, cex = 2)

    axis(
        1,
        lwd = 0,
        lwd.ticks = .1,
        at = seq(-100, 100, 50),
        cex.axis = 1.5
    )

    dev.off()
}

g_clear <- function(data, file_name, data_name) {
    postscript(
        paste(file_name, '-clear.eps', sep = ''),
        onefile = FALSE,
        horizontal = FALSE,
        pointsize = 12,
        width = 6,
        height = 6
    )

    load("data_bezier.dat")

    labels = list()
    labels[["BiPoo2001"]]                  = list(
        "x" = "Spike timing (msec)",
        "y" = "Synaptic change (%)",
        "atx" = seq(120,-100,-40),
        "aty" = seq(-60, 100, 20),
        "laby" = seq(-60, 100, 20)
    )
    labels[["WoodinGangulyPoo2003"]]       = list(
        "x" = "Spike timing (msec)",
        "y" = "Change in GPSC amplitude (%)",
        "atx" = seq(-80, 80, 40),
        "aty" = seq(-50, 100, 50),
        "laby" = seq(-50, 100, 50)
    )
    labels[["CassenaerLaurent2007"]]       = list(
        "x" = "Spike timing (ms)",
        "y" = "Synaptic change (%)",
        "atx" = seq(-40, 40, 20),
        "aty" = seq(-60, 100, 20),
        "laby" = seq(-60, 100, 20)
    )
    labels[["FroemkeDan2002"]]             = list(
        "x" = "Spike timing (msec)",
        "y" = "Synaptic change (%)",
        "atx" = seq(-40, 40, 20),
        "aty" = seq(-60, 100, 20),
        "laby" = seq(-60, 100, 20)
    )
    #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    labels[["ZhouAckerWhite2005"]]         = list(
        "x" = "Spike timing (ms)",
        "y" = "% Change in EPSPs",
        "atx" = seq(-40, 40, 20),
        "aty" = seq(-80, 80, 40),
        "laby" = seq(-80, 80, 40)
    )
    labels[["ZhouAckerWhite2005-0"]]       = list(
        "x" = "Spike timing (ms)",
        "y" = "% Change in EPSPs",
        "atx" = seq(-40, 40, 20),
        "aty" = seq(-60, 100, 20),
        "laby" = seq(-60, 100, 20)
    )
    #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    labels[["HaasNowotnyAbarbanel2006"]]   = list(
        "x" = expression(paste(Delta, "t [ms]")),
        "y" = expression(paste(Delta[ISPS], "[norm]")),
        "atx" = seq(-40, 40, 20),
        "aty" = seq(-50, 100, 50),
        "laby" = seq(0.5, 2, 0.5)
    )
    #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    labels[["WittenbergWang20062"]]        = list(
        "x" = "Delay from EPSP to 2nd AP (mc)",
        "y" = "Normalized synaptic strength",
        "atx" = seq(-80, 80, 40),
        "aty" = seq(-50, 100, 50),
        "laby" = seq(0.5, 2, 0.5)
    )
    #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    labels[["ZhangTaoPoo1998"]]            = list(
        "x" = "Spike timing (msec)",
        "y" = "Synaptic change (%)",
        "atx" = seq(-40, 40, 20),
        "aty" = seq(-60, 100, 20),
        "laby" = seq(-60, 100, 20)
    )
    par(mar = c(5, 6, 2, 2) + .1)

    data = data[order(data[, 1]),]

    regression = data
    regression[, 2] = 0
    data_plus_regression = c(data[, 2], regression[, 2])

    dr = c(max(data[, 1]) - min(data[, 1]),
           max(data_plus_regression) - min(data_plus_regression))
    drg = c(dr[1] * (.1 / 2), dr[2] * (.1 / 2))

    ylim = c(min(min(data_plus_regression) - drg[2], labels[[data_name]][["aty"]])  ,
             max(max(data_plus_regression) + drg[2], labels[[data_name]][["aty"]]))

    xlim = c(min(data[, 1]) - drg[1] ,  max(data[, 1]) + drg[1])

    print(xlim)
    plot(
        axes = FALSE,
        frame.plot = TRUE,
        xlab = labels[[data_name]][["x"]],
        ylab = labels[[data_name]][["y"]],
        cex.lab = 2,
        data,
        ylim = ylim,
        xlim = xlim
    )

    if (data_name %in% data_bezier$name) {
        curr_bezier = data_bezier[data_bezier$name == data_name]
        bez = curr_bezier[idx == 1]
        lines(bez$x, bez$y, lwd = 3, col = "#ff0000")
        bez = curr_bezier[idx == 2]
        lines(bez$x, bez$y, lwd = 3, col = "#ff0000")
    }

    arrows(
        c(min(data[, 1]) - drg[1]  ,  0),
        c(0                       ,  min(data_plus_regression) - drg[2]),
        c(max(data[, 1]) + drg[1]  ,  0),
        c(0                       ,  max(data_plus_regression) + drg[2]),
        length = .08,
        lwd = 3
    )

    points(data, pch = 19, col = "#ffffff")

    points(data)

    axis(
        1,
        lwd = .0,
        lwd.ticks = .5,
        at = labels[[data_name]][["atx"]],
        cex.axis = 1.5
    )

    axis(
        2,
        lwd = .0,
        lwd.ticks = .5,
        at = labels[[data_name]][["aty"]],
        labels = labels[[data_name]][["laby"]],
        cex.axis = 1.5
    )
    dev.off()
}

g_bic <- function(bics, current, file_name) {
    postscript(
        paste(file_name, '-number_of_kernels.eps', sep = ''),
        onefile = FALSE,
        horizontal = FALSE,
        pointsize=6,
        width = 2.5,
        height = 1.67
    )

    par(mar = c(5, 6, 2, 2) + .1)

    bicrange = c(min(bics) - abs(max(bics) - min(bics)) / 6 ,
                 max(bics) + abs(max(bics) - min(bics)) / 6)
    plot(
        bics,
        pch = 15,
        frame.plot = FALSE,
        axes = FALSE,
        ylim = bicrange,
        xlab = "Number of components",
        ylab = "BIC",
        cex = 1.5,
        cex.lab = 2,
        cex.axis = 2
    )

    lines(bics, lwd = 4)

    points(
        which.min(bics),
        min(bics),
        pch = 1,
        cex = 3.5,
        lwd = 1
    )
    points(current,
           bics[current],
           pch = 2,
           cex = 3.5,
           lwd = 1)

    q = as.integer(bics)
    axis(2, at = seq(min(q), max(q), abs(max(q) - min(q)) / 2) , lwd = 1)
    axis(1, at = seq(1, 8, 1), lwd = 1)

    deltabic =  abs(min(bics) - bics[current])
    if (deltabic > 0)
    {
        lab = "Delta*BIC"
        lab = eval(parse(text = paste(
            'expression(',
            'Delta*BIC',
            '==',
            format(deltabic),
            ')'
        )))

        text(4, max(bics) + abs(max(bics) - min(bics)) / 12, lab, cex =
                 1.5)
    }
    dev.off()

}

# Functions ----------------------------------------------------------------------------------------

graph <- function(name,
                  nvars,
                  index,
                  seed,
                  data_dir,
                  scale = 1,
                  trans = 0) {
    # radix of the data filenames for this kernel combination
    radix_file = paste(
        'curve-',
        name,
        '-',
        format(nvars),
        '-',
        format(index),
        '-',
        format(seed),
        '_',
        sep = ''
    )

    label_file = paste(radix_file,
                       'data',
                       sep = '')

    # radix of the data filenames for this kernel combination
    # best fitting
    curve_file = paste(data_dir, '/', radix_file, 'data', sep = '')

    # experimental_data
    data_file = paste(data_dir, '/', radix_file, 'orig_data', sep = '')

    # parameters for the best fitting
    params_file = paste(data_dir, '/', radix_file, 'params', sep = '')

    # bics
    bics_file = paste(data_dir, '/', 'bics', sep = '')

    data_all = read.table('data_all')

    colnames(data_all) = c(
        'name',
        'nvars',
        'index',
        'seed',
        'FVU',
        'tau1',
        'tau2',
        'k',
        'gpp',
        'gnp',
        'gpn',
        'gnn',
        'eps',
        'esp',
        'ens',
        'esn'
    )

    FVU = data_all[data_all$name == name &
                       data_all$nvars == nvars &
                       data_all$index == index &
                       data_all$seed == seed, ]$FVU

    curve_ = as.matrix(read.table(curve_file))

    data_ = as.matrix(read.table(data_file))

    data_[, 2] = data_[, 2] * scale + trans
    bics_ = read.table(bics_file)

    bics_ = bics_[bics_[, 1] == name,]

    bics_ = bics_[order(bics_[, 2]),][, 5]

    params_ = as.matrix(read.table(params_file))

    # Parameters table ----
    g_table(nvars, params_, FVU, label_file)

    # Used kernels ----
    g_kernels(params_[4:11], label_file)

    # Fitting ----
    g_fitting(data_, curve_, label_file)
    g_clear(data_, label_file, name)

    # BIC -----
    g_bic(bics_, nvars, label_file)

}

custom_graph <- function(dt = .01,
                         tau1 = 1,
                         tau2 = 1,
                         k = 1,
                         gpp = 0,
                         gnp = 0,
                         gpn = 0,
                         gnn = 0,
                         eps = 0,
                         esp = 0,
                         ens = 0,
                         esn = 0,
                         width = 6,
                         height = 4) {
    print(args)
    if (length(args) != 7) {
        return('wrong number of args')

    }

    name = args[1]

    nvars = as.numeric(args[2])

    index = as.numeric(args[3])

    seed = as.numeric(args[4])

    data_dir = args[5]

    scale = as.numeric(args[6])

    trans = as.numeric(args[7])

    curve_ = as.matrix(read.table(curve_file))

    data_ = as.matrix(read.table(data_file))

    data_[, 2] = data_[, 2] * scale + trans
    scores_ = as.matrix(read.table(scores_file))

    params_ = as.matrix(read.table(params_file))

    # Parameters table ----
    tabl = c()

    tabl = rbind(tabl, 'Data:', name)

    tabl = rbind(tabl, 'Kernels number:', nvars)
    tabl = rbind(tabl, 'Seed:', seed)
    tabl = rbind(tabl, 'kernel amplification:', params_[3])
    tabl = rbind(tabl, 'pre-synaptic tau:', params_[1])
    tabl = rbind(tabl, 'post-synaptic tau:', params_[2])

    require(xtable)
    tabl = print(xtable(tabl))
    write(tabl, paste(curve_file, '-params_table.tex', sep = ''))

    # Used kernels ----
    postscript(
        paste(curve_file, '-used_kernels.eps', sep = ''),
        onefile = FALSE,
        horizontal = FALSE,
        pointsize = 11,
        width = 2.5,
        height = 1.67,

    )

    par(mar = c(5, 4, 2, 2) + .1)

    pars = params_[4:11]

    pidx = (1:8)[pars != 0]

    labels = c(
        expression(sigma[pp]),
        expression(sigma[np]),
        expression(sigma[pn]),
        expression(sigma[nn]),
        expression(eta[ps]),
        expression(eta[sp]),
        expression(eta[ns]),
        expression(eta[sn])
    )

    plot(
        pidx,
        pars[pidx],
        cex = .5,
        cex.lab = 2,
        xlim = c(.5, 8.5),
        ylim = c(-1.3, 1.3),
        axes = FALSE,
        xlab = "GDHL Component type",
        ylab = ''
    )

    pp = pars[pidx]
    pp = as.matrix(pp)
    arrows(pidx,
           pp * 0,
           pidx,
           pp,
           lwd = 4,
           length = 0.08)

    points(1:8, pars * 0, cex = .05)

    for (x in 1:length(pidx)) {
        text(pidx[x],
             pars[pidx[x]]
             + .3 * (pars[pidx[x]] / abs(pars[pidx[x]])),
             format(pars[pidx[x]],
                    digits = 2),
             cex = 1.3)

    }

    axis(
        1,
        at = 1:8,
        labels = labels,
        lwd = 0,
        cex.axis = 2
    )

    axis(2,
         at = seq(-1, 1, 1),
         lwd = 3,
         cex.axis = 1)

    dev.off()

    # GA history ----
    postscript(
        paste(curve_file, '-fitness_curve.eps', sep = ''),
        onefile = FALSE,
        horizontal = FALSE,
        width = 6,
        height = 6,

    )

    par(mar = c(5, 4, 2, 1) + .1)

    plot(
        1:length(scores_),
        main = "Fitness curve",
        ylab = "Best scores",
        scores_,
        cex = .1,

        xlab = 'Generations',
    )

    grid()

    dev.off()

    # Fitting ----
    postscript(
        paste(curve_file, '-data_fitting.eps', sep = ''),
        onefile = FALSE,
        horizontal = FALSE,
        width = 6,
        height = 6,

    )

    data_ = data_[order(data_[, 1]),]

    all_scores = c(data_[, 2], curve_[, 2])

    # for(f in similar_files)  {
    # similar_=as.matrix(read.table(f));
    # all_scores=c(all_scores,similar_[,2]);
    # }

    dr = c(max(data_[, 1]) - min(data_[, 1]),
           max(all_scores) - min(all_scores))
    drg = c(dr[1] * (.1 / 2), dr[2] * (.1 / 2))

    ylim = c(min(all_scores) - drg[2] , max(all_scores) + drg[2])

    xlim = c(min(data_[, 1]) - drg[1] ,  max(data_[, 1]) + drg[1])

    plot(
        axes = FALSE,
        xlab = "",
        ylab = "",
        frame.plot = FALSE,
        data_,
        ylim = ylim,
        xlim = xlim
    )

    arrows(
        c(min(data_[, 1]) - drg[1], 0),
        c(0,                           min(all_scores) - drg[2]),
        c(max(data_[, 1]) + drg[1], 0),
        c(0,                           max(all_scores) + drg[2]),
        length = .08,
        lwd = 3
    )

    # for(f in similar_files)  {
    # similar_=as.matrix(read.table(f));
    # lines(similar_,col='#aaaaaa',lwd=2);
    # }
    lines(curve_, lwd = 6)

    points(data_, pch = 19, col = "#ffffff")

    points(data_)

    #grid();

    dev.off()

    postscript(
        paste(curve_file, '-number_of_kernels.eps', sep = ''),
        onefile = FALSE,
        horizontal = FALSE,
        pointsize = 11,
        width = 2.5,
        height = 1.67,

    )

    par(mar = c(5, 6, 2, 2) + .1)

    allscores = c()
    for (f in similar_scores) {
        sc = as.matrix(read.table(f))
        sc = sc[dim(sc)[1],]
        allscores = c(allscores, sc)

    }

    plot(
        allscores,
        pch = 15,
        ylim = c(0, .8),
        frame.plot = FALSE,
        axes = FALSE,
        xlab = "Number of components",
        ylab = "Best fitting",
        cex = 1.5,
        cex.lab = 2,
        cex.axis = 2
    )

    lines(allscores, lwd = 4)

    points(nvars,
           allscores[nvars],
           pch = 1,
           cex = 3.5,
           lwd = 3)

    axis(2, at = seq(0, 1, .4), lwd = 3)
    axis(1, at = seq(1, 8, 1), lwd = 3)

    dev.off()

    postscript(
        paste(curve_file, '_legend_all.eps', sep = ''),
        onefile = FALSE,
        horizontal = FALSE,
        width = 6,
        height = 6,

    )

    layout(matrix(c(1, 5, 2, 2, 1, 5, 2, 2, 3, 3, 4, 4, 3, 3, 4, 4), 4, 4))

    par(mar = c(1, 4, 0, 2) + .1)
    plot.new()

    text(.5, .7, format(paste('Kernels number:', nvars), width = 12))
    text(.5, .4, format(paste('kernel amplification:', params_[3]), width =
                            12))
    text(.5, .3, format(paste('pre-synaptic tau:', params_[1]), width = 12))
    text(.5, .2, format(paste('post-synaptic tau:', params_[2]), width = 12))

    par(mar = c(5, 4, 2, 2) + .1)

    pars = params_[4:11]

    pidx = (1:8)[pars != 0]

    labels = c(
        expression(sigma[pp]),
        expression(sigma[np]),
        expression(sigma[pn]),
        expression(sigma[nn]),
        expression(eta[ps]),
        expression(eta[sp]),
        expression(eta[ns]),
        expression(eta[sn])
    )

    plot(
        pidx,
        pars[pidx],
        main = "Used kernels",
        cex = .1,
        xlim = c(.5, 8.5),
        ylim = c(-1.3, 1.3),
        axes = FALSE,
        xlab = '',
        ylab = ''
    )

    pp = pars[pidx]
    pp = as.matrix(pp)
    arrows(pidx,
           pp * 0,
           pidx,
           pp,
           length = 0.03)

    points(1:8, pars * 0, cex = .05)

    for (x in 1:length(pidx)) {
        text(pidx[x],
             pars[pidx[x]]
             + .15 * (pars[pidx[x]] / abs(pars[pidx[x]])),
             format(pars[pidx[x]],
                    digits = 2),
             cex = .8)

    }

    axis(1,
         at = 1:8,
         labels = labels,
         lwd = 0)

    axis(2, at = seq(-1, 1, 1))

    par(mar = c(5, 4, 2, 1) + .1)

    plot(
        1:length(scores_),
        main = "Fitness curve",
        ylab = "Best scores",
        scores_,
        cex = .1,
        xlab = 'Generations',
    )

    grid()

    data_ = data_[order(data_[, 1]),]

    all_scores = c(data_[, 2], curve_[, 2])

    for (f in similar_files)  {
        similar_ = as.matrix(read.table(f))

        all_scores = c(all_scores, similar_[, 2])

    }

    ylim = c(min(all_scores), max(all_scores))

    plot(
        data_,
        main = "Data fitting",
        ylim = ylim,
        ylab = "EPSP",
        xlab = "time-window (msec)"
    )

    for (f in similar_files)  {
        similar_ = as.matrix(read.table(f))

        lines(similar_, col = '#dadada')

    }
    points(data_)

    lines(curve_)

    grid()

    par(mar = c(5, 4, 2, 2) + .1)

    allscores = c()
    for (f in similar_scores) {
        sc = as.matrix(read.table(f))
        sc = sc[dim(sc)[1],]
        allscores = c(allscores, sc)

    }

    plot(
        allscores,
        pch = 14,
        cex = .5,
        ylim = c(0, 1),
        main = "Current kernel number",
        xlab = "Number of kernels",
        ylab = "Best score"
    )

    lines(allscores)

    points(nvars, allscores[nvars], pch = 1, cex = 1.5)
    dev.off()
}

# MAIN ----
if (length(args) != 7) {
    return('wrong number of args')

} else {
    print(args)
    graph(
        name = args[1],
        nvars = as.numeric(args[2]),
        index = as.numeric(args[3]),
        seed = as.numeric(args[4]),
        data_dir = args[5],
        scale = as.numeric(args[6]),
        trans = as.numeric(args[7])
    )

}


library(tidyverse)
library(DT)
library(data.table)
library(yaml)
library(rstudioapi)
library(recommenderlab)
library(Matrix)
library(broom)

source("select_file.R")
total_newsposts <- config$n_newsposts + config$n_newsposts_step  * config$n_steps

source("user_generation.R")
source("posts_generation.R")
source("generate_cosine_matrix.R")

set.seed(0)

# User generation ----
user <- generate_users(config)

# posts generation  ----
news_posts <- generate_news(config)

# initilize ground truth
total_newsposts <- config$n_newsposts + config$n_newsposts_step  * config$n_steps

cosine_matrix <- generate_cosine_matrix(user, news_posts)

#' Generate ground truth recommendation for a user_id from a cosine similariy matrix
#'
#' @param user_id the user id (i.e. the row number in the cosine matrix)
#' @param cosine_matrix a cosine similarity matrix where rownumber is the number of users, and colnumer is the number of items
#' @param n how many recommendations to generate
#'
#' @return The ordered recommendations
#'
generate_topn_truth <- function(user_id, cosine_matrix, n = 1) {
  df <- as_tibble(data.frame(t(cosine_matrix)))
  df <- df %>% mutate(id = 1:dim(df)[1]) %>% select(id, user_id)
  suppressMessages(
    res <- top_n(df, n)
  )
  names(res) <- c("id", "match")
  res %>% arrange(desc(match))
}

m <- matrix(
  sample(c(0), total_newsposts * config$n_users, replace = TRUE),
  ncol = total_newsposts,
  dimnames = list(
    user = paste("u", 1:config$n_users, sep = ''),
    item = paste("i", 1:total_newsposts, sep = '')
  )
)

ui_matrix <- as(m, "dgCMatrix")
trainingmatrix <- (new("realRatingMatrix", data = ui_matrix))
#getRatingMatrix(trainingmatrix)
#image(trainingmatrix, main = "Normalized Ratings")
#hist(getRatings(trainingmatrix), breaks=100)

# create a basic recommendation algorithm
generate_topn_rec <- function(user_id, cosine_matrix, n = 1) {
  df <- as_tibble(data.frame(t(cosine_matrix)))
  df <- df %>% mutate(id = 1:dim(df)[1]) %>% select(id, user_id)
  suppressMessages(
    res <- top_n(df, n)
  )
  names(res) <- c("id", "match")
  res %>% arrange(desc(match))
}

# generate an empty exposure matrix with rownumbers = posts , colnumbers = simulationsteps
exposure <- matrix(c(0), nrow = total_newsposts, ncol = config$n_steps)

#list to store user interest for evaluation later on
user_record <- list()

# run all simulation steps
pb <- txtProgressBar(min = 0, max = config$n_steps, initial = 0, char = "=",
               width = NA, title="Simulation Run", label, style = 3, file = "")
for (steps in 1:config$n_steps) {

  #select currently relevant posts
  n_current_posts <- config$n_newsposts+config$n_newsposts_step  * steps
  current_posts <- m[ ,1:n_current_posts]

  #generate recommendations once per step
  if(!config$update_for_user){
    ui_matrix <- as(current_posts, "dgCMatrix")
    trainingmatrix <- (new("realRatingMatrix", data = ui_matrix))
    rec_sys <- Recommender(trainingmatrix, method=config$recommender)
    recoms <- recommenderlab::predict(rec_sys, trainingmatrix, n = 10)
  }

  #draw users that are randomly shown new content
  first_users <- sample(1:config$n_users, config$n_newsposts_step )

  # for all users
  for(user_id in 1:config$n_users){
    # generate top 10 recommendations

    #update recommendation after each user
    if(config$update_for_user){
      ui_matrix <- as(current_posts, "dgCMatrix")
      trainingmatrix <- (new("realRatingMatrix", data = ui_matrix))

      rec_sys <- Recommender(trainingmatrix, method=config$recommender)
      recoms <- recommenderlab::predict(rec_sys, trainingmatrix[user_id], n = 10)
      res <- as(recoms, "list")
    } else {
      res <- as(recoms, "list")[user_id] #get recommendation from matrix per step
    }
    consumed_item <- NA
    if(user_id %in% first_users){
      #show user new item
      consumed_item <- n_current_posts - config$n_newsposts_step + match(user_id, first_users)
      #print(paste("Show item ", consumed_item , " to user ", user_id))
    } else {
      if(length(res[[1]])==0){
        consumed_item <- round(runif(1, 1, n_current_posts))
      } else {
        consumed_item <- as.numeric(str_remove(res[[1]][[1]], "i"))
      }
    }

    evaluation <- (cosine_matrix[user_id, consumed_item] * 5)
    m[user_id, consumed_item] <- evaluation

    # update user interests ----
    switch(config$update_user_interest,
    none={
      #users won't be updated
    },
    random={
      #update users randomly
      if(rbinom(n=1, size=1, prob=config$p_user_update)){
        user[user_id,2:(config$n_topics+1)] <-user[user_id,2:(config$n_topics+1)]+news_posts[consumed_item,2:(config$n_topics+1)]
        #norm users interests
        user[user_id,2:(config$n_topics+1)] <- user[user_id,2:(config$n_topics+1)] / sum(user[user_id,2:(config$n_topics+1)]) *user$interest_resource[user_id]
      }
    },
    dominant={
      #update dominant topic
      #find dominant topic
      dominant <- which.max(news_posts[consumed_item,2:(config$n_topics+1)])
      #indices shifted by 1 because first column is ID
      user[user_id, dominant+1] <- user[user_id, dominant+1] + news_posts[consumed_item, dominant+1]
      #norm users interests
      user[user_id,2:(config$n_topics+1)] <- user[user_id,2:(config$n_topics+1)] / sum(user[user_id,2:(config$n_topics+1)]) *user$interest_resource[user_id]
    }
    )

    # update exposure counts in each step for all recommendations

    exposure[consumed_item, steps] + 1 -> temp
    exposure[consumed_item, steps] <- temp

  }

  #decrease relevance of old news
  decay_matrix <- diag(c(rep(config$decay_factor, n_current_posts),rep(1, total_newsposts - n_current_posts)))

  m <-t(decay_matrix %*% t(m)) #transposed as dimensions won't fit otherwise
  colnames(m) <- paste("i", 1:total_newsposts, sep='') #colnames lost after multiplication

  if(steps > 1){
    exposure[,steps] <- exposure[, steps] + exposure[, steps -1]
    #image(trainingmatrix, main = "Normalized Ratings")
  }

  if(config$update_user_interest != "none"){
    #update cosine matrix
    cosine_matrix <- generate_cosine_matrix(user, news_posts)
  }

  #keep record of users' interest
  psych::describe(user)  %>%  as.data.frame() %>%
    rownames_to_column() %>%
    filter(str_starts(rowname, "topic")) %>% mutate(step = steps) -> user_record[[steps]]
  setTxtProgressBar(pb, steps)
}
close(pb)

# save results
results_data <- list(user = user,
                     news_posts = news_posts,
                     exposure = exposure,
                     user_record = user_record)
rds_filename <- config$outputfilename
write_rds(results_data, rds_filename)