# Inverse function
myginv <- function (X, tol = sqrt(.Machine$double.eps)){
    ## the ginv function for symmetric matrices. it avoid some errors.
        if (length(dim(X)) > 2L || !(is.numeric(X) || is.complex(X)))
                  stop("'X' must be a numeric or complex matrix")
            if (!is.matrix(X))
                      X <- as.matrix(X)
	    if(!isSymmetric(X))
		      X <- (X + t(X))/2
            Xeigen <- eigen(X,symmetric=T)
            Positive <- Xeigen$values > max(tol * Xeigen$values[1L], 0)
            if (all(Positive))
                      Xeigen$vectors %*% (1/Xeigen$values * t(Xeigen$vectors))
            else if (!any(Positive))
                      array(0, dim(X)[2L:1L])
            else Xeigen$vectors[, Positive, drop = FALSE] %*% ((1/Xeigen$values[Positive]) *
                                              t(Xeigen$vectors[, Positive, drop = FALSE]))
}

mtxInvPrx <- function(d,w,LD.matrix,thrw,thrctd=1,thrp=length(d)/2,thrp2=thrp/2,thrp3=5){ ### This function approximates the inverse of D+diag(w)%*%LD.matrix%*%diag(w)
 p <- length(w)
 wsq <- w^2
 rkwsq <- rank(wsq)
 wsqcumsum <- sapply(1:p, function(ii) sum(wsq[rkwsq<=ii]))
 wstat <- wsqcumsum+sqrt((p-(1:p))*wsqcumsum)
 rkthr <- min(max(which(wstat<thrw),p-thrp),p-thrp3) ## at least throw out half of the variables
 ix1 <- (rkwsq>rkthr)
 if(sum(ix1) != 1){
   ctdmax <- apply(abs(LD.matrix-diag(diag(LD.matrix)))[ix1,],2,max)
   ctdmax[ix1] <- 0
   ix1 <- ix1|(ctdmax>=thrctd)
   ix2 <- !ix1

   M0 <- sapply(1:p, function(ii) w[ii]*LD.matrix[ii,])
   M0 <- sapply(1:p, function(ii) w[ii]*M0[ii,])
   M <- diag(d)+M0
   Minv <- diag(1/d)
   if(isSymmetric(M[ix1,ix1])){
     Minv[ix1,ix1] <- myginv(M[ix1,ix1])
   }else Minv[ix1,ix1] <- myginv((M[ix1,ix1]+t(M[ix1,ix1]))/2)#myginv(M[ix1,ix1])
   out <- Minv
 }else out <- 'ginv'
 out
}

vestepDirectSS <- function(posterior, para, LD.matrix, wzy, ycy, anno = matrix(1, length(wzy), 1), thrw.mtxinv = 0.1, thrctd.mtxinv = 0.8, thrp.mtxinv = length(wzy)){
	p <- length(wzy)
	gammabeta <- para$gammabeta
	lodanno <- anno%*%gammabeta
	qlodbeta <- matrix(posterior$lodbeta,p,1)
	qbeta <- 1/(1+exp(-qlodbeta))

	### update the posterior distribution of the prior distribution of pibeta
	updatePibeta <- function(expanno, qbeta){
		shape1pibeta <- expanno + qbeta
		shape2pibeta <- 1/expanno+1-qbeta
		epibeta <- shape1pibeta/(shape1pibeta+shape2pibeta)
		elogpibeta <- digamma(shape1pibeta) - digamma(shape1pibeta+shape2pibeta)
		elogpibetac <- digamma(shape2pibeta) - digamma(shape1pibeta+shape2pibeta)
		elodpibeta <- elogpibeta - elogpibetac
		out <- list(par = list(shape1pibeta = shape1pibeta, shape2pibeta = shape2pibeta), stat = list(epibeta = epibeta,
			elodpibeta = elodpibeta, elogpibeta = elogpibeta, elogpibetac = elogpibetac))
		out
	}

	### update the posterior distribution of tau
	updateTau <- function(para, qbeta){
		vareps <- para$vareps
		nutau <- para$nutau
		At <- try(myginv(diag(as.vector(qbeta))%*%LD.matrix%*%diag(as.vector(qbeta))+diag(as.vector(qbeta-qbeta^2))+diag(1,p)/nutau))
		if (class(At) == 'try-error') {
			cat('Caught an error during full inversion, trying approximation.\n')
			At <- mtxInvPrx(d=1/nutau+as.vector(qbeta-qbeta^2), w=qbeta, LD.matrix=LD.matrix, thrw=thrw.mtxinv, thrctd=thrctd.mtxinv, thrp=thrp.mtxinv, thrp2=thrp.mtxinv/2)
		}
		vartau <- vareps*At
		mutau <- At%*%(qbeta*wzy)
		out <- list(A = At, vartau = vartau, mutau = mutau)
		out
	}

	post.tau <- updateTau(para,qbeta)

	### update the posterior distribution of sbeta (signal of each SNP)
	updateSbeta <- function(para, lodprior, posttau, qbeta){
		vareps <- para$vareps
		vartau <- posttau$vartau
		mutau <- posttau$mutau
		muwzy <- LD.matrix%*%(mutau*qbeta)
		res <- (wzy - muwzy)
		post.lodbeta <- lodprior-(1/(2*vareps))*(diag(LD.matrix)*(mutau^2+diag(vartau))-2*mutau*res-2*mutau^2*qbeta+2*(LD.matrix*vartau)%*%qbeta-2*diag(LD.matrix)*diag(vartau)*qbeta)
		out <- list(lodbeta = post.lodbeta)
		out
	}

	post.sbeta <- updateSbeta(para, lodanno, posttau = post.tau, qbeta)

	out <- list(posterior = c(post.sbeta, post.tau), stat = NULL)
	out
} ### End of "vestepDirectSS"

vmstepDirectSS <- function(post, LD.matrix, wzy, ycy, init = list(gammabeta = rep(0, dim(anno)[2]), vareps = 1, nutau = 5), anno = matrix(1, length(wzy), 1), iter.max.mstep = 100){
	p <- length(wzy)
	mutau <- post[['posterior']]$mutau
	vartau <- post[['posterior']]$vartau
	lodbeta <- post[['posterior']]$lodbeta
	qbeta <- 1/(1+exp(-lodbeta))
	mubeta <- mutau*qbeta
	qdly <- (ycy-2*sum(wzy*mubeta)+sum(mubeta*(LD.matrix%*%mubeta))+sum(qbeta*((LD.matrix*vartau)%*%qbeta))+sum(diag(LD.matrix)*(qbeta-qbeta^2)*(mutau^2+diag(vartau))))
	qdltau <- sum((mutau^2+diag(vartau))*qbeta)

	vareps <- qdly/(p-sum(qbeta))
	nutau <- qdltau/sum(qbeta)/vareps

	loglkpibetaprior <- function(gammabeta){
		lodanno <- anno%*%matrix(gammabeta, ncol = 1)
		out <- -qbeta*lodanno+log(1+exp(lodanno))
		sum(out)
	}

	out.loglkpibetaprior <- optim(par = init$gammabeta, fn = loglkpibetaprior, method = "BFGS", hessian = TRUE, control = list(maxit = iter.max.mstep))
	out <- list(par = list(gammabeta = out.loglkpibetaprior$par, vareps = vareps, nutau = nutau), hess = list(pibetaprior = out.loglkpibetaprior$hessian))
	out
} ### End of "vmstepDirectSS"

vemDirectSS <- function(LD.matrix, GEMsummstats, anno = NULL, iter.max = 200, iter.max.mstep = 100, er.max = 1e-5,
          init = list(gammabeta = c(-1, rep(0, dim(anno)[2] - 1)), vareps = sd(GEMsummstats)^2, nutau = 2),
          posterior.init = list(lodbeta = matrix(0, length(GEMsummstats), 1))){
  thrw.mtxinv = 0.1
  thrctd.mtxinv=0.8
  wzy <- GEMsummstats
	p <- length(wzy)
	if(is.null(anno)) anno <- matrix(1, p, 1)
	LD.matrix.inv <- myginv(LD.matrix)
	ycy <- as.numeric(t(wzy)%*%LD.matrix.inv%*%wzy)
	posterior.old <- posterior.init
	wzy <- matrix(wzy,p,1)

	vaicDirect <- function(para,post){
 		mutau <- post[['posterior']]$mutau
		vartau <- post[['posterior']]$vartau
		lodbeta <- post[['posterior']]$lodbeta
		vareps <- para[['vareps']]
		qbeta <- 1/(1+exp(-lodbeta))
		mubeta <- mutau*qbeta
		p <- length(lodbeta)
		qdly <- (ycy-2*sum(wzy*mubeta)+sum(mubeta*(LD.matrix%*%mubeta))+sum(qbeta*((LD.matrix*vartau)%*%qbeta))+sum(diag(LD.matrix)*(qbeta-qbeta^2)*(mutau^2+diag(vartau))))
		ely <- -qdly/(2*vareps) -(p/2)*log(vareps)
		mly <- -(ycy-2*sum(wzy*mubeta)+sum(mubeta*(LD.matrix%*%mubeta)))/(2*vareps) -(p/2)*log(vareps)
		pd <- 2*(mly-ely)
		vaic <- -2*mly+2*pd
		vaic
	}

	er <- Inf
	ll.all <- Inf
	ll.old <- Inf
	iter <- 1
	mstep.all <- list()

	### The algorithm stop until the hyperparameter estimation converges in relative error.
	while((abs(er)>er.max)&(iter<iter.max)){
		estep <- vestepDirectSS(posterior.old, init, LD.matrix, wzy, ycy, anno, thrw.mtxinv = thrw.mtxinv, thrctd.mtxinv = thrctd.mtxinv, thrp.mtxinv = floor(p*(1/4+(3/4)^iter)))
		mstep <- vmstepDirectSS(post = estep, LD.matrix, wzy, ycy, init = init, anno, iter.max.mstep = iter.max.mstep)
		mstep.all[[iter]] <- mstep
		posterior.old <- estep[['posterior']]
		init <- mstep$par
		ll <- vaicDirect(init, estep)
		ll.all <- c(ll.all, ll)
		er <- ll.old - ll
		er <- max(er,er/abs(ll))
		ll.old <- ll
		iter <- iter + 1
	}

	out <- list(posterior = estep[['posterior']], par = mstep$par, niter = iter,
		converged = (er<er.max), par.all = mstep.all)
	out
} ### End of "vemDirectSS"

vestepMedSS <- function(posterior,para,LD.matrix,wzy,ycy,wzr,rcr,rcy,anno=matrix(1,length(wzy),1),thrw.mtxinv=0.1,thrctd.mtxinv=0.8,thrp.mtxinv=length(wzy)){
  p <- length(wzy)
  gammabeta <- para$gammabeta
  lodanno <- anno%*%gammabeta
  qlodbeta <- matrix(posterior$lodbeta,p,1)
  qbeta <- 1/(1+exp(-qlodbeta))
  m1gamma <- posterior$mudelta

  ### update the posterior distribution of the prior distribution of pibeta
  updatePibeta <- function(expanno, qbeta){
    shape1pibeta <- expanno+qbeta
    shape2pibeta <- 1/expanno+1-qbeta
    epibeta <- shape1pibeta/(shape1pibeta+shape2pibeta)
    elogpibeta <- digamma(shape1pibeta)-digamma(shape1pibeta+shape2pibeta)
    elogpibetac <- digamma(shape2pibeta)-digamma(shape1pibeta+shape2pibeta)
    elodpibeta <- elogpibeta-elogpibetac
    out <- list(par=list(shape1pibeta=shape1pibeta,shape2pibeta=shape2pibeta),stat=list(epibeta=epibeta,elodpibeta=elodpibeta,elogpibeta=elogpibeta,elogpibetac=elogpibetac))
    out
  }

  ### update the posterior distribution of tau
  updateTau <- function(para,qbeta){
    vareps <- para$vareps
    nutau <- para$nutau
    At <- try(myginv(diag(as.vector(qbeta))%*%LD.matrix%*%diag(as.vector(qbeta))+diag(as.vector(qbeta-qbeta^2))+diag(1,p)/nutau))
    if (class(At) == 'try-error') {
      cat('Caught an error during full inversion, trying approximation.\n')
      At <- mtxInvPrx(d=1/nutau+as.vector(qbeta-qbeta^2), w=qbeta, LD.matrix=LD.matrix, thrw=thrw.mtxinv, thrctd=thrctd.mtxinv, thrp=thrp.mtxinv, thrp2=thrp.mtxinv/2)
    }
    vartau <- vareps*At
    mutau <- At%*%(qbeta*(wzy-m1gamma*wzr))
    out <- list(A=At,vartau=vartau,mutau=mutau)
    out
  }

  post.tau <- updateTau(para,qbeta)

  updateDelta <- function(para,posttau,qbeta){
    vareps <- para$vareps
    mutau <- posttau$mutau
    mudelta <- (rcy-sum(wzr*mutau*qbeta))/rcr
    vardelta <- vareps/rcr
    out <- list(mudelta=mudelta,vardelta=vardelta)
    out
  }

 post.delta <- updateDelta(para,post.tau,qbeta)

  ### update the posterior distribution of sbeta
  updateSbeta <- function(para,lodprior,posttau,postdelta,qbeta){
    vareps <- para$vareps
    vartau <- posttau$vartau
    mutau <- posttau$mutau
    mudelta <- postdelta$mudelta
    muwzy <- LD.matrix%*%(mutau*qbeta)+mudelta*wzr
    res <- (wzy -muwzy)
    post.lodbeta <- lodprior-(1/(2*vareps))*(diag(LD.matrix)*(mutau^2+diag(vartau))-2*mutau*res-2*mutau^2*qbeta+2*(LD.matrix*vartau)%*%qbeta-2*diag(LD.matrix)*diag(vartau)*qbeta)
    out <- list(lodbeta=post.lodbeta)
    out
  }

  post.sbeta <- updateSbeta(para,lodanno,posttau=post.tau,postdelta=post.delta,qbeta)

  out <- list(posterior=c(post.sbeta,post.tau,post.delta),stat=NULL)
  out
} ### End of "vestepMedSS"

vmstepMedSS <- function(post, LD.matrix, wzy, ycy, wzr, rcr, rcy, init = list(gammabeta = rep(0, dim(anno)[2]), vareps = 1, nutau = 5),
				anno = matrix(1, length(wzy), 1), iter.max.mstep = 100){

	p <- length(wzy)
	mutau <- post[['posterior']]$mutau
	vartau <- post[['posterior']]$vartau
	mudelta <- post[['posterior']]$mudelta
	vardelta <- post[['posterior']]$vardelta
	lodbeta <- post[['posterior']]$lodbeta
	qbeta <- 1/(1+exp(-lodbeta))
	mubeta <- mutau*qbeta
	qdly <- (ycy-2*sum(wzy*mubeta)+sum(mubeta*(LD.matrix%*%mubeta))+sum(qbeta*((LD.matrix*vartau)%*%qbeta))+sum(diag(LD.matrix)*(qbeta-qbeta^2)*(mutau^2+diag(vartau)))+(mudelta^2+vardelta)*rcr-2*mudelta*(rcy-sum(wzr*mubeta)))

	qdltau <- sum((mutau^2+diag(vartau))*qbeta)
	vareps <- qdly/(p-sum(qbeta)-1)
	nutau <- qdltau/sum(qbeta)/vareps

	loglkpibetaprior <- function(gammabeta){
		lodanno <- anno%*%matrix(gammabeta, ncol = 1)
		out <- log(1 + exp(lodanno)) - qbeta*lodanno
		sum(out)
	}
	out.loglkpibetaprior <- optim(par = init$gammabeta, fn = loglkpibetaprior, method = "BFGS", hessian = TRUE, control = list(maxit = iter.max.mstep))
	out <- list(par = list(gammabeta = out.loglkpibetaprior$par, vareps = vareps, nutau = nutau), hess = list(pibetaprior = out.loglkpibetaprior$hessian))
	out
} ### End of "vmstepMedSS"

vemMedSS <- function(LD.matrix, DEMsummstats, GEMsummstats, anno = NULL, iter.max = 200, iter.max.mstep = 100, er.max = 1e-5,
	init = list(gammabeta = c(-1, rep(0, dim(anno)[2] - 1)), vareps = sd(DEMsummstats)^2, nutau = 2),
	posterior.init = list(lodbeta = matrix(0, length(DEMsummstats), 1), mudelta = 0)){
  thrw.mtxinv = 0.1
  thrctd.mtxinv = 0.8
  wzy <- DEMsummstats
  wzr <- GEMsummstats
	p <- length(wzy)
	if(is.null(anno)) anno <- matrix(1, p, 1)
	LD.matrix.inv <- myginv(LD.matrix)
  ycy <- as.numeric(t(wzy)%*%LD.matrix.inv%*%wzy)
  rcr <- as.numeric(t(wzr)%*%LD.matrix.inv%*%wzr)
  rcy <- as.numeric(t(wzr)%*%LD.matrix.inv%*%wzy)

	posterior.old <- posterior.init
	wzy <- matrix(wzy,p,1)

	vaicMed <- function(para,post){
		mutau <- post[['posterior']]$mutau
		vartau <- post[['posterior']]$vartau
		mudelta <- post[['posterior']]$mudelta
		vardelta <- post[['posterior']]$vardelta
		lodbeta <- post[['posterior']]$lodbeta
		vareps <- para[['vareps']]
		qbeta <- 1/(1+exp(-lodbeta))
		mubeta <- mutau*qbeta
		p <- length(lodbeta)

		qdly <- (ycy-2*sum(wzy*mubeta)+sum(mubeta*(LD.matrix%*%mubeta))+sum(qbeta*((LD.matrix*vartau)%*%qbeta))+sum(diag(LD.matrix)*(qbeta-qbeta^2)*(mutau^2+diag(vartau)))+(mudelta^2+vardelta)*rcr-2*mudelta*(rcy-sum(wzr*mubeta)))

		ely <- -qdly/(2*vareps) -(p/2)*log(vareps)
		mly <- -(ycy-2*sum(wzy*mubeta)+sum(mubeta*(LD.matrix%*%mubeta))+mudelta^2*rcr-2*mudelta*(rcy-sum(wzr*mubeta)))/(2*vareps) -(p/2)*log(vareps)
		pd <- 2*(mly-ely)
		vaic <- -2*mly+2*pd
		vaic
	}

	er <- Inf
	ll.all <- Inf
	ll.old <- Inf
	iter <- 1
	mstep.all <- list()
	### The algorithm stop until the hyperparameter estimation converges in relative error.
	while((abs(er)>er.max)&(iter<iter.max)){
		estep <- vestepMedSS(posterior.old, init, LD.matrix, wzy, ycy, wzr, rcr, rcy, anno, thrw.mtxinv = thrw.mtxinv, thrctd.mtxinv = thrctd.mtxinv,
			thrp.mtxinv = floor(p*(1/4+(3/4)^iter)))
		mstep <- vmstepMedSS(post = estep,LD.matrix, wzy, ycy, wzr, rcr, rcy, init = init, anno, iter.max.mstep = iter.max.mstep)
		mstep.all[[iter]] <- mstep
		posterior.old <- estep[['posterior']]
		init <- mstep$par
		ll <- vaicMed(init, estep)
		ll.all <- c(ll.all, ll)
		er <- ll.old - ll
		er <- max(er,er/abs(ll))
		ll.old <- ll
		iter <- iter + 1
  }
	out <- list(posterior = estep[['posterior']], par = mstep$par, niter = iter, converged = (er<er.max),
		par.all = mstep.all)
	out
} ### End of "vemMedSS"

getParameters <- function(omod){  ### process the output of the model without mediator
	omod[['par']]
}

getPostProb <- function(omod){
	PP <- 1/(1+exp(- omod[['posterior']]$lodbeta))
	SNP.name <- rownames(PP)
	PP <- c(PP)
	names(PP) <- SNP.name
	idfdr <- rank(-PP, ties.method = 'max')
	fdr <- sapply(idfdr, function(ii) 1 - mean(PP[idfdr <= ii]))

  out <- PP
	out
}

processFunMed <- function(GEMoutput, DEMoutput){

  mod <- list()
  mod[['model.opt']] <- list(GEM = GEMoutput, DEM = DEMoutput)

	mod.out <- list()
	mod.out[['Parameters']] <- lapply(mod[['model.opt']], getParameters)
	names(mod.out[['Parameters']][['GEM']]) <- c('gammaB', 'varEta', 'nuB')
	names(mod.out[['Parameters']][['DEM']]) <- c('gammaBeta', 'varEpsilon', 'nuBeta')
	mod.out[['Parameters']][['DEM']][['delta']] <- mod[['model.opt']][['DEM']][['posterior']]$mudelta
	mod.out[['PostProb']] <- lapply(mod[['model.opt']], getPostProb)
	mod.out[['Convergence']] <- lapply(mod[['model.opt']], function(xx) xx[c('niter','converged')])

	mod.out
}

meanAnno <- function(x,y){
  y <- (as.numeric(y)>0)
  if(sum(y)>0){ x1 <- mean(x[y])
  }else{ x1 <- 0}
  x1
}

lbAnno <- function(x, y, post, nrep=1000){
  y <- as.numeric(y)
  n <- length(y)
  n1 <- sum(y>0)
  shm <- sapply(1:nrep, function(ii){
    idii <- sample(n,n1,replace=FALSE)
    out <- mean(x[idii])
    out })
  out <-  sum(shm >= post)/nrep
  out
}

annoEnrich <- function(iFunMedNull, annoMtx, Nperm = 5000, cores = 20){
  require(parallel)
  idanno <- colnames(annoMtx)
  ## posterior porbabilities from the null model
  post.null <- list(GEM = iFunMedNull[['PostProb']][['GEM']],
                    DEM = iFunMedNull[['PostProb']][['DEM']])

  ## average posterior probability of inclusion of the SNPs with the annotation, for each annotation
  post.meananno.null <- lapply(post.null, function(x) apply(annoMtx, 2, meanAnno, x = x))

  anno.enrichment <- mclapply(names(post.null), function(x) sapply(1:length(idanno), function(y) lbAnno(post.null[[x]], annotation.matrix[, y], post.meananno.null[[x]][y], nrep = Nperm)), mc.cores = cores, mc.preschedule = FALSE)
  names(anno.enrichment) <- names(post.null)
  names(anno.enrichment[['GEM']]) <- names(post.meananno.null[['GEM']])
  names(anno.enrichment[['DEM']]) <- names(post.meananno.null[['DEM']])

  return(list(enrichmentPval = anno.enrichment, avePP = post.meananno.null))
}


##
## Draw networks
##
library(tidyverse)
library(ggraph)
library(igraph)
source("init if necessary.r")

for (site in unique(people$Pop)) {
  gifts = dyads %>%
    filter(Pop == site, GiftGiven > 0) %>%
    mutate(Weight = as.integer(as.factor(Amount)) / 10) %>%
    select(Ego = Ego.ID, Alter = Alter.ID, Weight)

  nodes = people %>%
    filter(Pop == site)

  g = graph_from_data_frame(gifts, vertices = nodes)

  gg = ggraph(g) +
    geom_edge_link(aes(edge_width = Weight),
                   colour = "lightgrey",
                   arrow = arrow(length = unit(1.5, 'mm')),
                   end_cap = circle(3, 'mm')) +
    geom_node_point(aes(size = gift.deg.in, colour = HG)) +
    scale_edge_width_continuous(range = c(0.5, 2)) +
    theme_void() +
    theme(legend.position="none")

  ggsave(paste0("plots/network - ", site, ".pdf"), plot = gg,
         width = 200, height = 200, units = "mm")

  print(paste0("Plotted ", site))
}


library(tidyverse)
library(runner)

e = read_csv('data/intermediate/exposures.csv')
f = read_csv('data/intermediate/article_features.csv')
u = read_csv('data/intermediate/users_new.csv')

tp = u %>%
  select(user_id, starts_with('t_')) %>%
  mutate(t_other = 8 - (t_buit + t_bin + t_econ + t_crime + t_sport + t_ent + t_mil + t_imm) / 8) %>%
  pivot_longer(-user_id, names_to = 'topic', values_to='topic_pref') %>%
  mutate(topic = recode(topic,
                        t_econ = 'Economie',
                        t_buit = 'Buitenland',
                        t_bin = 'Binnenland',
                        t_crime = 'Justitie',
                        t_sport = 'Sport',
                        t_ent = 'Entertainment',
                        t_mil = 'Anders',
                        t_imm = 'Anders',
                        t_other = 'Anders')) %>%
  group_by(user_id, topic) %>%
  summarise(topic_pref = mean(topic_pref))

u1 = u %>%
  select(user_id, exp_group=group, Diversity_1:Diversity_4, div_trait, gender, age, edu, pol_knowledge,
         overconfidence, political_efficacy, pol_interest) %>%
  mutate(exp_group = as.factor(paste('group', exp_group)))

d = f %>%
  select(news_id, topic) %>%
  inner_join(e) %>%
  select(user_id, session, exposure_id, timestamp, topic, position,
         selected, rating_selected, rating2_selected, devices_group) %>%
  mutate(timestamp = as.POSIXct(timestamp)) %>%
  arrange(user_id, timestamp) %>%
  left_join(tp)

d = left_join(d, u1) %>%
  mutate(exp_group = recode(exp_group,
                            `group 1` = "random",
                            `group 2` = "rec_A",
                            `group 3` = 'rec_B',
                            `group 4` = "custom"),
         device = recode(devices_group,
                         `mobile` = 'mobile',
                         `tablet` = 'PC',
                         `PC` = "PC")) %>%
  filter(user_id != 637) #Excluding one extreme user with 1232 selections

## set long and short window (in hours)
## the long window will not include the short window
long_window = 3*24
short_window = 1
max_n = Inf  ## include only n last articles within window
sum_selected <- function(x, n=max_n) sum(tail(x, n))
count_seen <- function(x, n=max_n) min(length(unique(x)), n)

## add lag_selected (i.e. how often was topic selected in past x hours).
d = d %>%
  group_by(user_id, topic) %>%
  mutate(long_window_selected = runner(selected, f=sum_selected, k=paste(long_window, 'hours'), lag=paste(short_window, 'hours'), idx=timestamp)) %>%
  mutate(long_window_seen = runner(exposure_id, f=count_seen, k=paste(long_window, 'hours'), lag=paste(short_window, 'hours'), idx=timestamp)) %>%
  mutate(short_window_selected = runner(selected, f=sum_selected, k=paste(short_window, 'hours'), lag='1 sec', idx=timestamp)) %>%
  mutate(short_window_seen = runner(exposure_id, f=count_seen, k=paste(short_window, 'hours'), lag='1 sec', idx=timestamp))

d = d %>%
  group_by(user_id) %>%
  mutate(long_window_n = runner(selected, f=sum, k=paste(long_window, 'hours'), lag=paste(short_window, 'hours'), idx=timestamp)) %>%
  mutate(short_window_n = runner(selected, f=sum, k=paste(short_window, 'hours'), lag='1 sec', idx=timestamp))

## add lag_window (note that this is NaN if lag_n == 0. We should drop these cases in analysis)
d = d %>%
  mutate(long_selected = long_window_selected / long_window_seen,
         long_seen = long_window_seen / long_window_n,
         short_selected = short_window_selected / short_window_seen,
         short_seen = short_window_seen / short_window_n) %>%
  mutate(full_selected = (long_window_selected + short_window_selected) / (long_window_seen + short_window_seen))

## add topic_in_exp (i.e. times selected topic occurs in current exposure)
d = d %>%
  group_by(user_id, exposure_id, topic) %>%
  mutate(topic_in_exp = n())

## make topic_pref (from survey) a multinom dist
topic_pref_dist = d %>%
  ungroup() %>%
  distinct(user_id, topic, topic_pref) %>%
  group_by(user_id) %>%
  mutate(topic_pref_dist = topic_pref / sum(topic_pref, na.rm=T))

d = d %>%
  left_join(topic_pref_dist)

saveRDS(d, 'data/intermediate/analysis_backup.rds')


library(ggplot2)
library(dplyr)
library(reshape2)
library(RColorBrewer)
library(latex2exp)
library(latex2exp)

findKeyPoint <- function(results) {
  idx <- which(results$CoverEpsilon < results$PackingEpsilon)[1]
  return( c(results$Generation[idx],results$CoverEpsilon[idx]) )
}

plotBoundedCoverPacking <- function(rhoMin=0.6, sigma=0.3, savePDF=False) {
  filename=paste("Results/bounded-sig-", sigma, "-k-3-rho-", rhoMin, ".out", sep='')

  results <- read.table(filename, header=T)
  maxMinSpar <- max(results$MinArchiveSparseness)

  aggregatedResults <- summarise(group_by(results, Generation),
                                 AvgCover=mean(CoverEpsilon),
                                 AvgPacking=mean(PackingEpsilon),
                                 AvgMinSparseness=mean(MinArchiveSparseness))

  longAggregatedResults <- filter(melt(aggregatedResults, id.vars=c("Generation")),
                                  Generation < 500)
  longAggregatedResults <- mutate(longAggregatedResults,
                                  variable = factor(variable,
                                                    levels=c("AvgCover",
                                                             "AvgPacking",
                                                             "AvgMinSparseness"),
                                                    ordered=T))

  rhoMinLabel = paste("$\\rho_{min} =", rhoMin, "$")
  sigmaLabel  = paste("Gaussian Mutation $\\sigma = ", sigma, "$")
  titleLabel = paste("Bounded 3D Euclidean Space")
  #keyPoint <- findKeyPoint(results)
  keyPoint <- c(25, 0.75)

  p1 <- ggplot(longAggregatedResults, aes(x=Generation, y=value, group=variable, color=variable)) +
    geom_hline(yintercept=0.6, size=0.5, color="black", linetype="longdash") +
    geom_line(size=1.25) +
    geom_curve(x=keyPoint[1]+75, y=keyPoint[2]+0.5,
               xend=keyPoint[1], yend=keyPoint[2],
               arrow=arrow(length=unit(0.015,"npc")),
               angle=270,
               curvature=0.25,
               color="darkgray") +
    #
    annotate("text", x=500, y=0.7, label=TeX(rhoMinLabel), hjust=1, size=5) +
    annotate("text", keyPoint[1]+75, keyPoint[2]+0.5,
             label=TeX("Archive Converged to $\\epsilon$-Net"),
             hjust=0, color="black", size=4) +
    annotate("text", x=500, y=0.16, size=4, hjust=1,
             label="Nothing substantively\nnew is being added",
             color="firebrick") +
    #
    scale_color_brewer(name="Archive\nMeasure",
                       palette="Set1",
                       labels=c("Cover\nEpsilon\n",
                                "Packing\nEpsilon\n",
                                "Minimum\nSparseness")) +
    xlab("Generation") +
    ylab("Measure") +
    ggtitle(titleLabel, subtitle=TeX(sigmaLabel)) +
    theme(text=element_text(family="Times", size=16))

  print(p1)

  if (savePDF) {
    pdfFilename = gsub("Results", "Graphs", gsub("out", "pdf", filename))
    print(paste("Saving to file", pdfFilename))
    ggsave(pdfFilename, width=5, height=4, units="in")
  }
}

estimateConvergenceRate <- function(sigma=0.1, rhoMin=0.45, suffix="-nopop") {
  filename = paste("Results/unbounded-rv-s", sigma, "-r", rhoMin, suffix,".out", sep='')

  print(paste("Reading file: ", filename), quote=F)
  results <- read.table(filename, header=T)
  aggregatedResults <- summarise(group_by(results, Generation),
                                 AvgCoverPackingDiff=max(mean(CoverEpsilon) - mean(PackingEpsilon),0))
  aggregatedResults <- mutate(aggregatedResults,
                              ScaledCPDiff = AvgCoverPackingDiff/(max(AvgCoverPackingDiff)-min(AvgCoverPackingDiff)) - min(AvgCoverPackingDiff))
  return(sum(aggregatedResults$ScaledCPDiff))
}

estimateCoverPackingIntersection <- function(sigma=0.1, rhoMin=0.45, suffix="-nopop", maxHypotheticalGeneration=100000, minGen=10) {
  filename = paste("Results/unbounded-rv-s", sigma, "-r", rhoMin, suffix,".out", sep='')
  print(paste("Reading file: ", filename), quote=F)
  results <- read.table(filename, header=T)
#  results <- filter(resultsRaw,
#                    CoverEpsilon < 3,
#                    PackingEpsilon > 0)

  coverModel <- loess(CoverEpsilon ~ Generation, results)
  hypotheticalCover <- predict(coverModel, newdata=data.frame(Generation=minGen:maxHypotheticalGeneration))

  packingModel <- loess(PackingEpsilon ~ Generation, results)
  hypotheticalPacking <- predict(packingModel, newdata=data.frame(Generation=minGen:maxHypotheticalGeneration))

  # LOESS is fine, if we do not have to extrapolate.  Otherwse we'll have to assume a specific
  # function.  If the curves have not intersected, then use log(x) for cover and sqrt(x) for packing
  trueMaxGen <- max(results$Generation)
  if (hypotheticalCover[trueMaxGen-minGen] > hypotheticalPacking[trueMaxGen-minGen]) {
    coverModel <- lm(CoverEpsilon ~ 1/Generation, results)
    hypotheticalCover <- predict(coverModel, newdata=data.frame(Generation=minGen:maxHypotheticalGeneration))

    packingModel <- lm(PackingEpsilon ~ sqrt(Generation), results)
    hypotheticalPacking <- predict(packingModel, newdata=data.frame(Generation=minGen:maxHypotheticalGeneration))
  }

  return(which(hypotheticalCover - hypotheticalPacking < 0)[[1]] + minGen)
}

plotUnboundedCoverPacking <- function(rhoMin=0.45, sigma=0.1, suffix="-mu2-lambda8", savePDF=False) {
  filename = paste("Results/unbounded-rv-s", sigma, "-r", rhoMin, suffix,".out", sep='')
  #filename = paste("Results/unbounded-sig-", sigma, "-k-3-rho-", rhoMin, suffix,".out", sep='')
  print(paste("Reading file: ", filename), quote=F)

  results <- read.table(filename, header=T)
  maxMinSpar <- max(results$MinArchiveSparseness)
  #minY <- min(results$MinArchiveSparseness)
  #maxY <- max(results$CoverEpsilon)

  aggregatedResults <- summarise(group_by(results, Generation),
                                 AvgCover=mean(CoverEpsilon),
                                 AvgPacking=mean(PackingEpsilon),
                                 AvgMinSparseness=mean(MinArchiveSparseness))

  longAggregatedResults <- filter(melt(aggregatedResults, id.vars=c("Generation")),
                                  Generation < 500)
  longAggregatedResults <- mutate(longAggregatedResults,
                                  variable = factor(variable,
                                                    levels=c("AvgCover",
                                                             "AvgPacking",
                                                             "AvgMinSparseness"),
                                                    ordered=T))
  minY = min(longAggregatedResults$value)
  maxY = max(longAggregatedResults$value)

  maxGen <- max(longAggregatedResults$Generation)
  rhoMinLabel = paste("$\\rho_{min} =", rhoMin, "$")
  sigmaLabel  = paste("Guassian Mutation $\\sigma = ", sigma, "$")
  titleLabel = paste("Unbounded 5D Euclidean Space")
  keyPoint <- findKeyPoint(results)

  p1 <- ggplot(longAggregatedResults, aes(x=Generation, y=value, group=variable, color=variable)) +
    geom_hline(yintercept=rhoMin, size=0.5, color="black", linetype="longdash") +
    geom_line(size=1.25) +
    ylim(c(minY, maxY)) +             #+0.25
    annotate("text", x=-20, y=rhoMin+0.05, label=TeX(rhoMinLabel), hjust=0, size=4) +
    annotate("text", x=120, y=1.3, label="Packing continues to increase\nbut space is no longer\nbeing covered",
             vjust=1, hjust=0, size=3, color="darkblue") +
    #annotate("text", x=maxGen, y=1.6, label=TeX("Eventually converges to $\\epsilon$-Net"),
    #         vjust=1, hjust=1, size=4, color="firebrick") +
    scale_color_brewer(name="Archive\nMeasure",
                       palette="Set1",
                       labels=c("Cover\nEpsilon\n",
                                "Packing\nEpsilon\n",
                                "Minimum\nSparseness")) +
    xlab("Generation") +
    ylab("Measure") +
    ggtitle(titleLabel, subtitle=TeX(sigmaLabel)) +
    theme(text=element_text(family="Times", size=16),
          legend.position="bottom")

  print(p1)

  if (savePDF) {
    pdfFilename = gsub("Results", "Graphs", gsub("out", "pdf", filename))
    print(paste("Saving to file", pdfFilename))
    ggsave(pdfFilename, width=5, height=4, units="in")
  }
}

plotHammingCoverPacking <- function(rhoMin=3, n=16, savePDF=False) {
  filename=paste("Results/hamming-r", rhoMin, "-n", n, ".out", sep='')

  results <- read.table(filename, header=T)

  maxMinSpar <- max(results$MinArchiveSparseness)
  minY <- min(results$MinArchiveSparseness)
  maxY <- max(results$CoverEpsilon)

  aggregatedResults <- summarise(group_by(results, Generation),
                                 AvgCover=mean(CoverEpsilon),
                                 AvgPacking=mean(PackingEpsilon),
                                 AvgMinSparseness=mean(MinArchiveSparseness))

  longAggregatedResults <- filter(melt(aggregatedResults, id.vars=c("Generation")),
                                  Generation < 200)
  longAggregatedResults <- mutate(longAggregatedResults,
                                  variable = factor(variable,
                                                    levels=c("AvgCover",
                                                             "AvgPacking",
                                                             "AvgMinSparseness"),
                                                    ordered=T))

  maxGen <- max(longAggregatedResults$Generation)
  rhoMinLabel = paste("$\\rho_{min} =", rhoMin, "$")
  nLabel  = paste("Bit-flip mutation using $1/n$")
  titleLabel = paste("Hamming Space, n=", n)
  keyPoint <- findKeyPoint(results)

  p1 <- ggplot(longAggregatedResults, aes(x=Generation, y=value, group=variable, color=variable)) +
    geom_hline(yintercept=0.6, size=0.5, color="black", linetype="longdash") +
    geom_line(size=1.25) +
    ylim(c(minY, maxY)) +
    annotate("text", x=maxGen, y=1, label=TeX(rhoMinLabel), hjust=1, size=5) +
    annotate("text", x=maxGen, y=9.75, label=TeX("Converges to $\\epsilon$-Net"),
             vjust=1, hjust=1, size=4, color="firebrick") +
    scale_color_brewer(name="Archive\nMeasure",
                       palette="Set1",
                       labels=c("Cover\nEpsilon\n",
                                "Packing\nEpsilon\n",
                                "Minimum\nSparseness")) +
    xlab("Generation") +
    ylab("Measure") +
    ggtitle(titleLabel, subtitle=TeX(nLabel)) +
    theme(text=element_text(family="Times", size=16))

  print(p1)

  if (savePDF) {
    pdfFilename = gsub("Results", "Graphs", gsub("out", "pdf", filename))
    print(paste("Saving to file", pdfFilename))
    ggsave(pdfFilename, width=5, height=4, units="in")
  }
}

barplotUnboundedConvergencePointByEval <- function(filename='Results/UnboundedConvergencePoint.csv', savePDF=F) {
  ucp <- read.csv(filename, header=T, sep='|')
  ucp <- mutate(ucp,
                EvaluationCount=GenerationConverged*PopulationSize,
                UsesPopulation=factor( c("mulambda","nopop")[ (ExperimentalGroup == 'NoPop')+1 ] ))

  p <- ggplot(ucp, aes(x=reorder(ExperimentalGroup, EvaluationCount), y=EvaluationCount, fill=UsesPopulation)) +
        geom_bar(stat="identity") +
        scale_fill_manual(name="",
                          breaks=c("nopop","mulambda"),
                          values=c("steelblue","firebrick"),
                          labels=c("No Population","Population")) +
   # labels=c(TeX("$(\\mu,\\lambda)$ Population","No Population"))) +
  coord_flip() +
        xlab(TeX("Experimental Group, $(\\mu,\\lambda)$")) +
        ylab("Number of Evaluations before\nPacking & Cover Converged") +
        ggtitle("How Do Populations Affect SNS Converence?") +
        theme(text=element_text(family="Times", size=16))

  print(p)

  if (savePDF) {
    pdfFilename = gsub("Results", "Graphs", gsub("csv", "pdf", filename))
    print(paste("Saving to file", pdfFilename))
    ggsave(pdfFilename, width=7, height=4, units="in")
  }
}

visualizePopulations <- function(gens, tr=0, filename='Results/viz-archive-and-pop.csv'){
  vizRaw <- read.csv(filename, header=T)
  vizFiltered <- mutate(filter(vizRaw, trial==tr, generation %in% gens),
                        isarchive=(whichPop!="archive"))

  p<- ggplot(vizFiltered, aes(x=x, y=y, color=whichPop, size=isarchive)) +
    geom_point() +
    scale_color_manual(values=c("darkgray","red", "blue"),
                       name="") +
    facet_grid(. ~ generation, scales="fixed") +
    #facet_grid(generation ~ ., scales="fixed") +
    #facet_wrap(generation ~ .) +
    scale_size_discrete(name="Population", range=c(1.25,2.5)) +
    ylab("") + xlab("") + # xlab("Generation") +
    ggtitle("Populations Do Not Cover Like Archives (by gen.)") +
    theme_bw() +
    theme(text=element_text(family="Times", size=18),
          axis.text=element_blank(),
          axis.ticks=element_blank(),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          legend.position="none") +
    guides(size=FALSE)

  print(p)
}

barplotUnboundedConvergencePoint <- function(filename='Results/UnboundedConvergencePoint.csv', savePDF=F) {
  ucp <- read.csv(filename, header=T, sep='|')
  ucp <- mutate(ucp,
                UsesPopulation=factor( c("mulambda","nopop")[ (ExperimentalGroup == 'NoPop')+1 ] ))

  p <- ggplot(ucp, aes(x=reorder(ExperimentalGroup, Order), y=GenerationConverged, fill=UsesPopulation)) +
    geom_bar(stat="identity") +
    scale_fill_manual(name="",
                      breaks=c("nopop","mulambda"),
                      values=c("firebrick","steelblue"),
                      labels=c("No Population","Population")) +
    # labels=c(TeX("$(\\mu,\\lambda)$ Population","No Population"))) +
    coord_flip() +
    xlab(TeX("Experimental Group, $(\\mu,\\lambda)$")) +
    ylab("Generation at which\nPacking & Cover Converged") +
    ggtitle("How Do Populations Affect SNS Converence?") +
    theme(text=element_text(family="Times", size=16), legend.position="none")

  print(p)

  if (savePDF) {
    pdfFilename = gsub("Results", "Graphs", gsub("csv", "pdf", filename))
    print(paste("Saving to file", pdfFilename))
    ggsave(pdfFilename, width=7, height=4, units="in")
  }
}

plotChildCoverRatio <- function(filename='Results/unbounded-rv-s0.1-r0.45-pop2c16.out') {
  coverData <- read.table(filename, header=T)
  coverData <- mutate(coverData, ChildCoverRatio = ChildCover/CoverEpsilon )
  aggCoverData <- summarize(group_by(coverData, Generation),
                            MeanChildCover=mean(ChildCover),
                            MeanChildCoverRatio=mean(ChildCoverRatio))
  #p <- ggplot(aggCoverData, aes(x=Generation, y=MeanChildCoverRatio)) +
  #  geom_line(size=1.25, color="firebrick") +
  p <- ggplot(coverData, aes(x=Generation, y=ChildCover)) +
    #geom_line(size=0.5, color="darkgray") +
    geom_smooth(lwd=1.25, color="firebrick") +
    ylab("Cover Epsilon") +
    ggtitle("Children Population Cover",
            subtitle=TeX("(2,16)-SNSEA, 5D, $\\sigma = 0.45$, $\\rho_{min} = 0.1$")) +
    theme(text=element_text(family="Times", size=18))
  print(p)
}


#' Effective number of codons
#'
#' This function calculate the effective number of codons (ENC) using Wright's formula.
#'
#' @param x a list of KZsqns objects
#' @param spp.list an array indicating the the species identity of each KZsqns object in the list \emph{x}. The default option is to calculate an ENC for each KZsqns object. When \emph{spp.list} is specified, an ENC is calculated for each unique element of \emph{spp.list}
#' @param y a number to assign the type of codon table to be used for the translation. 0 = standard codon table, 2 = vertibrate mitchodrial (See dna2aa for additional options). If no number is specified or an option other than those provided above is specified, there will be a warning and the standard codon table will be used
#' @param formula a char array to denote the formula for calculating ENC. Options include: 'w': Wright's formula, 'f4-': Fuglsang's Ncf4- formula.
#' @return an numeric array of the ENCs
#' @section Warning:
#' According to Wright's formula, the ENC is the sum of the heterogeneity of all the degeneracy classes. When all the codons belonging to a degeneracy class is missing, the ENC can not be calculated. A warning will result when it happens. The most likely situation leading to such a condition is that the sequence of codons is too short. When the sequence is short, the calculated ENC is likely to deviate much from the underlying value. It is recommended to increase the sample size to solve this issue when Wright's formula is prefered. Alternatively, Fuglsang's Ncf4- formula could be used instead.
#' @references
#' Fuglsang, A., 2006 Estimating the "Effective Number of Codons": The Wright way of determining codon homozygosity leads to superior estimates. Genetics 172:1301-1307
#' Wright, F., 1990 The 'effective number of codons' used in a gene. Gene 87: 23-29.
#' @examples
#' dnalist = vector('list', 2)
#' dnalist[[1]] = CodonTable2[sample(1:64, 1e4, TRUE),1]
#' attr(dnalist[[1]], 'class') <- 'KZsqns'
#' dnalist[[2]] = CodonTable2[sample(1:64, 1e4, TRUE),1]
#' attr(dnalist[[2]], 'class') <- 'KZsqns'
#' enc(x = dnalist, y = 2) # Two numbers should be around 60 as there are 60 animo acid coding codons and 4 stop codons for codon table 2
#'
#' dnalist = vector('list', 2)
#' dnalist[[1]] = CodonTable2[sample(1:64, 1e4, TRUE),1]
#' attr(dnalist[[1]], 'class') <- 'KZsqns'
#' dnalist[[2]] = CodonTable2[sample(1:64, 1e4, TRUE),1]
#' attr(dnalist[[2]], 'class') <- 'KZsqns'
#' enc(x = dnalist, y = 4) # Two numbers should be around 62 as there are 60 animo acid coding codons and 2 stop codons for codon table 4
#' @export

enc <- function(x, y=0, spp.list='n', formula = 'w'){
  if(!is.list(x)) x = list(x)
  cTable = arg_check(x[[1]], "KZsqns", y)
  calc = nc_wright
  switch(formula,
         'f4-' = {calc = nc_fuglsang4m},
         'w'   = {},
         {
           warning("Not a valid formula, and Wright's formula will be used.")
         })
  if(length(spp.list)==1 && spp.list=='n'){
    cat("No species list is provided\nCalculating ENCs for each KZsqns object.\n")
    return(sapply(x, function(i){calc(table(i), cTable)}))
  } else {
    if (length(spp.list)!=length(x)) stop("The lengths of the species list and the list of KZsqns do not match")
    spp = unique(spp.list)
    fixx = function(i){
      jobs = which(spp.list==spp[i])
      ans = rep(0, 64)
      for(j in jobs){
        ans = rbind(ans, table(x[[j]])[cTable[,1]])
      }
      ans = colSums(ans, na.rm = TRUE)
      names(ans) <- cTable[,1]
      return(ans)
    }
    ans = sapply(1:length(spp), function(i){calc(fixx(i), cTable)})
    names(ans) <- spp
    return(ans)
  }
}


library('Matrix')
library('MASS')
source("https://raw.githubusercontent.com/ggrothendieck/gsubfn/master/R/list.R")

neuralnet.load <- function(path){
  fc1_W  <<- matrix(scan(paste(path,'fc1_W',sep='/')), 400, 784, byrow=TRUE)
  fc1_b  <<- scan(paste(path,'fc1_b',sep='/'))
  fc21_W <<- matrix(scan(paste(path,'fc21_W',sep='/')), 15, 400, byrow=TRUE)
  fc21_b <<- scan(paste(path,'fc21_b',sep='/'))
  fc22_W <<- matrix(scan(paste(path,'fc22_W',sep='/')), 15, 400, byrow=TRUE)
  fc22_b <<- scan(paste(path,'fc22_b',sep='/'))
  fc3_W  <<- matrix(scan(paste(path,'fc3_W',sep='/')), 400, 15, byrow=TRUE)
  fc3_b  <<- scan(paste(path,'fc3_b',sep='/'))
  fc4_W  <<- matrix(scan(paste(path,'fc4_W',sep='/')), 784, 400, byrow=TRUE)
  fc4_b  <<- scan(paste(path,'fc4_b',sep='/'))
}

neuralnet.sigmoid <- function(x){
  1/(1+exp(-x))
}

neuralnet.relu  <- function(x){
  structure(vapply(x, function(z) max(0,z), numeric(1)),dim=dim(x))
}

neuralnet.dense <- function(x, W, b, act=""){
  if (act=='sigmoid')
    neuralnet.sigmoid(x%*%t(W)+b)
  else if (act=='relu')
    neuralnet.relu(x%*%t(W)+b)
  else
     x%*%t(W)+b
}

encoder.encode <- function(x){
  h1 <- neuralnet.dense(x, fc1_W, fc1_b, 'relu')
  list(neuralnet.dense(h1, fc21_W, fc21_b), neuralnet.dense(h1, fc22_W, fc22_b))
}

decoder.decode <- function(x){
  h3 <- neuralnet.dense(x, fc3_W, fc3_b, 'relu')
  neuralnet.dense(h3, fc4_W, fc4_b, 'sigmoid')
}

reparametrize <- function(mean_, logvar){
  n <- dim(mean_)[1]
  sapply(1:n, function(i){mvrnorm(mu=mean_[i,], Sigma=Diagonal(x = exp(logvar[i,])))})
}

VDP.load <- function(path){
  weights_ <<- scan(paste(path, 'weights', sep='/'))
  mean_    <<- matrix(scan(paste(path, 'means', sep='/')), 500, 15, byrow=TRUE)
  var_     <<- matrix(scan(paste(path, 'covars', sep='/')), 500, 15, byrow=TRUE)
}

VDP.sample <- function(n){
  z <- max.col(t(rmultinom(n, 1, weights_)))
  sapply(z, function(i){mvrnorm(mu=mean_[i,], Sigma=Diagonal(x=var_[i,]))})
}

init <- function(path){
  VDP.load(path)
  neuralnet.load(path)
}

sample <- function(n, display=FALSE){
  ret <- decoder.decode(t(VDP.sample(n)))
}

reconstruct <- function(x, display=FALSE){
  list[mean_, logvar] <- encoder.encode(x)
  z   <- t(reparametrize(mean_, logvar))
  ret <- decoder.decode(z)
}

display <- function(x){
    x <- structure(x, dim=c(dim(x)[1], 28, 28))
    x[,,28:1]
}


# Record linkage techniques
# Allows for the combining of datasets that have similar keys which are not completely exact

# A. Comparing strings
# 1. Small distance, small difference
# The stringdist package has been loaded for you.
# Each method performs a different combination of possible actions to compare differences in strings.
# Common actions include; insertion, deletion, subsitution and transposition
stringdist("las angelos", "los angeles", method = "dl")
stringdist("las angelos", "los angeles", method = "lcs")
stringdist("las angelos", "los angeles", method = "jaccard")

# 2. Fixing typos with string distance
# dplyr and fuzzyjoin are loaded, and zagat and cities are available
# Count the number of each city variation
zagat %>%
  count(city)

# Join zagat and cities and look at results
zagat %>%
  # Left join based on stringdist using city and city_actual cols
  stringdist_left_join(cities, by = c("city" = "city_actual")) %>%
  # Select the name, city, and city_actual cols
  select(c("name", "city", "city_actual"))

# B. Generating and comparing pairs
# 1. Pair blocking
# Load reclin
library(reclin)

# Generate all possible pairs
pair_blocking(zagat, fodors)

# Generate pairs with same city. Ensures that some form of filtering is applied, otherwise all possible combinations are created
pair_blocking(zagat, fodors, blocking_var = "city")

# 2. Comparing pairs
# Generate pairs
pair_blocking(zagat, fodors, blocking_var = "city") %>%
  # Compare pairs by name using lcs()
  compare_pairs(by = "name",
      default_comparator = lcs())

# Generate pairs
pair_blocking(zagat, fodors, blocking_var = "city") %>%
  # Compare pairs by name, phone, addr
  compare_pairs(by = c("name", "phone", "addr"),
      default_comparator = jaro_winkler())

# C. Scoring and linking
# 1. Scoring and linking put together
# Create pairs
pair_blocking(zagat, fodors, blocking_var = "city") %>%
  # Compare pairs
  compare_pairs(by = "name", default_comparator = jaro_winkler()) %>%
  # Score pairs. Performs a probalistic review of the paired scores. Assigns highest probability to most appropriate match
  score_problink() %>%
  # Select pairs. Creates binary column that relates to the pair which should be used to match
  select_n_to_m() %>%
  # Link data. Performs the match
  link()


library(tidyverse)
library(leaflet)
library(glue)

##########################################
#'
#' Returns EPSG number used by NRCAN tiles
#'
leaflet_nrcan_crs_num <- function(){3978}

leaflet_nrcan_crs_proj4def <- function(){
    '+proj=lcc +lat_1=49 +lat_2=77 +lat_0=49 +lon_0=-95 +x_0=0 +y_0=0 +ellps=GRS80 +datum=NAD83 +units=m +no_defs'
}

##########################################
#'
#' Returns a CRS for NRCAN tiles needed for leaflet
#' Note: this is kinda brittle and I think all the little specific numbers on res and bnds need to be exact... its wierd
#'
leaflet_nrcan_crs <- function(){

    orgn <- c(-34655800, 39310000)

    bnds =  c(-7786476.885838887,
              -5153821.09213678,
              7148753.233541353,
              7928343.534071138
    )

    res <- c(
        38364.660062653464,
        22489.62831258996,
        13229.193125052918,
        7937.5158750317505,
        4630.2175937685215,
        2645.8386250105837,
        1587.5031750063501,
        926.0435187537042,
        529.1677250021168,
        317.50063500127004,
        185.20870375074085,
        111.12522225044451,
        66.1459656252646,
        38.36466006265346,
        22.48962831258996,
        13.229193125052918,
        7.9375158750317505,
        4.6302175937685215,
        2.6458386250105836,
        1.5875031750063502,
        0.92604351875370428,
        0.52916772500211673,
        0.31750063500127002,
        0.18520870375074083,
        0.11112522225044451,
        0.066145965625264591
    )

    leafletCRS(
        crsClass = "L.Proj.CRS",
        code = glue("EPSG:{leaflet_nrcan_crs_num()}"),
        proj4def = leaflet_nrcan_crs_proj4def(),
        origin = orgn,
        bounds =  bnds,
        resolutions = res
    )
}

leaflet_nrcan <- function(...){

    urlTemplate = "https://geoappext.nrcan.gc.ca/arcgis/rest/services/BaseMaps/CBMT3978/MapServer/tile/{z}/{y}/{x}?m4h=t"

    tile_attrib <- "base from geoappext.nrcan.gc.ca"

    epsg3978 <- leaflet_nrcan_crs()

    m <- leaflet(options = leafletOptions(worldCopyJump = F,
                                          crs = epsg3978,
                                          minZoom = 2, maxZoom = 17, ...)
    ) %>%
        addTiles(urlTemplate = urlTemplate,
                 attribution = tile_attrib,
                 options = tileOptions(continuousWorld = F)
        ) %>%
        # addMarkers(lng = -75.705793,
        #            lat = 45.345134,
        #            popup = "My office."
        # ) %>%
        setView(lng = -1*(96+(40/60)+(35/3600)),
                lat = 62+(24/60),
                zoom = 3
        )

    m
}

leaflet_nrcan_point_extract <- function(shp){
    tmp<-
        shp %>%
        leaflet_nrcan_shp_transform()
    do.call(rbind, st_geometry(tmp)) %>%
        as_tibble() %>% setNames(c("lng","lat"))

}

#####################################
#'
#'unsure why but we needto transform shp files to ESPG 4326 WGS84 before sending to leaflet
#'
#'
leaflet_nrcan_shp_transform <- function(shp){
    st_transform(shp, 4326)
}


##Shape=vector
##Rinde=field Shape
##output_plots_to_html
##Limite_minimo=number 0
##Limite_maximo=number 99999
##Metodo=selection Usuario;Media+3DS;Media+2DS;Quantil(90-10);Quantil(80-20)
##showplots
##outliers=output vector

sp.na.omit <- function(x, col.name = NULL, margin = 1) {
              if (!inherits(x, "SpatialPointsDataFrame") &
                  !inherits(x, "SpatialPolygonsDataFrame") &
                  !inherits(x, "SpatialLinesDataFrame") )
                stop("MUST BE sp SpatialPointsDataFrame OR SpatialPolygonsDataFrame class object")
              if(!is.null(col.name)) {
                if(is.na(match(col.name, names(x)))) stop(col.name, "does not exist in data")
                return( x[-which(is.na(x@data[,col.name])),] )
              } else {
                na.index <- unique(as.data.frame(which(is.na(x@data), arr.ind = TRUE))[, margin])
                if (margin == 1) {
                  cat("Deleting rows: ", na.index, "\n")
                  return(x[-na.index, ])
                }
                if (margin == 2) {
                  cat("Deleting columns: ", na.index, "\n")
                  return(x[, -na.index])
                }
              }
            }

library(sp)
crs_imagen<-st_crs(Shape)

myshp <- as_Spatial(Shape)
>print("--------------------------------------------------------")
>str(myshp)
#la presencia de NULL da error, agregado 28/07
#Esta linea dio conflictos con capas reproyectadas en 5346, se elimina
#myshp<-sp.na.omit(myshp[Rinde])

datos<-na.omit(myshp@data[,Rinde])
Media <- mean(na.omit(myshp@data[,Rinde]))
DE <- sd(na.omit(myshp@data[,Rinde]))
#LI <- Media-(2*DE)
#LS <- Media+(2*DE)

if(Metodo==0){LI <- Media-(3*DE); LS <- Media+(3*DE)}
if(Metodo==1){LI <- Media-(2*DE); LS <- Media+(2*DE)}
if(Metodo==2){LI <- quantile(datos,0.1); LS <- quantile(datos,0.9)}
if(Metodo==3){LI <- quantile(datos,0.2); LS <- quantile(datos,0.8)}
if(Metodo==4){LI <- Limite_minimo; LS <- Limite_maximo}

#if (LS > Maximo){LS = Maximo}
#if (LI > Minimo){LI = Minimo}

>print(paste("Media:",Media))
>print(paste("DE:",DE))
>print(paste("LI",LI))
>print(paste("LS",LS))

myshp.outlier<-myshp
myshp.outlier[LS<myshp@data[Rinde]|myshp@data[Rinde]<LI] <-NA
myshp.outlier <- subset(sp.na.omit(myshp.outlier[Rinde]))

>print("Datos a eliminar:")
>print(sum(is.na(myshp.outlier@data[Rinde])))

if(sum(is.na(myshp.outlier@data[Rinde])) == 0){stop("No hay datos para eliminar con los filtros propuestos")}

n<-nrow(myshp@data[Rinde])-nrow(myshp.outlier@data[Rinde])
>print(paste("Se filtraron",n,"puntos"))

output <- sf::st_as_sf(myshp.outlier,crs= crs_imagen)
outliers = output


###################################################################
# run functions of lasso regression to predict continous endpoint
###################################################################
# import the require packages
library("parcor")
library("ggplot2")
library("ggpubr")
# import the necessary functions for regression and plotting
source("lib/QSAR_functions.r")
# import the data
load("data/EColi_TELI_Physical_EC50_23chem_5pathways.rdata")

# lasso regression from function
Y <- EC50               # Response variable
X <-  X_TELI_total      # Explanatory variables
descriptorType <- "total"     # filename suffix to save the results
# X <- cbind(X_TELI_total,X_physical) # To generate explanatory variables for combined model
# descriptorType <- "physical_total"
lasso_regression_summary <- QSAR_lasso_regression (X, Y, 10)
"R-square : "; lasso_regression_summary$Rsquared

# save the results as rdata
save(file = paste("ec50_",descriptorType,"_Rsquare_",lasso_regression_summary$Rsquared,".rdata",sep = ''), lasso_regression_summary,X,Y)

#########################################################
# Draw figure for 1 model
#########################################################

# prepare data for plotting from raw data and prediction models
xTest <- X
yTest_obs <- Y
coeff <- matrix(lasso_regression_summary$lassoFit$coefficients.lasso, nrow = 1)
intercept <- lasso_regression_summary$lassoFit$intercept.lasso

yTest <- xTest %*% t( coeff ) # matrix multiplication
yTest <- yTest + intercept # add intercept

dat <- data.frame(xvar = log(yTest_obs), yvar = log(yTest))

# save the observed vs. predicted for one type of explanatory variables
tiff(file = paste("vF_EC50_",descriptorType,".tiff",sep = ''), width = 5.0, height = 4.5, units = 'in', res = 300, compression = 'lzw')
ggplot(dat, aes(x=xvar, y=yvar)) + geom_point(colour="blue", size = 4, shape=1) +
  theme_bw()  + coord_cartesian(xlim = c(0, 10), ylim = c(0, 10)) +
  geom_abline(intercept = 0, slope = 1,'linetype' = 'dashed',color = 'black','size' = 0.5) +
  theme (axis.title = element_text(size=21), axis.text=element_text(colour="black",size=17)) +
  labs(x="Observed EC50", y="Predicted EC50")
dev.off()

############################################################################
###     Plot figures of all 7 models in a panel
############################################################################

# load the results of the 7 models
load ("data/ec50_physical_Rsquare_0.130349046857749.rdata")
physicalModel = lasso_regression_summary
physicalModel$X = X
load ("data/ec50_gene_Rsquare_0.704734052060167.rdata")
geneModel = lasso_regression_summary
geneModel$X = X
load ("data/ec50_pathways_Rsquare_0.783956863877711.rdata")
pathModel = lasso_regression_summary
pathModel$X = X
load ("data/ec50_total_Rsquare_0.0848274215748496.rdata")
totalModel = lasso_regression_summary
totalModel$X = X
load("data/ec50_physical_gene_Rsquare_0.318469473082123.rdata")
genePhysicalModel = lasso_regression_summary
genePhysicalModel$X = X
load("data/ec50_physical_pathways_Rsquare_0.130349046857749.rdata")
pathPhysicalModel = lasso_regression_summary
pathPhysicalModel$X = X
load("data/ec50_physical_total_Rsquare_0.130349046857749.rdata")
totalPhysicalModel = lasso_regression_summary
totalPhysicalModel$X = X

# generate the panel plots for all 7 models

p1 <- plotPanelFigures(Y,physicalModel,'QSAR model','(Physio-chemical descriptors)') + labs(x=NULL, y =NULL)
p2 <- plotPanelFigures(Y,geneModel,'QBAR-Biomarker model','(Biomarker level descriptors)') + labs(x=NULL, y =NULL)
p3 <- plotPanelFigures(Y,genePhysicalModel,'QSBAR-Biomarker model','(Physio-chemical & biomarker level descriptors)') + labs(x=NULL, y =NULL)
p4 <- plotPanelFigures(Y,pathModel,'QBAR-Pathway model','(Pathway level descriptors)') + labs(x=NULL, y =NULL)
p5 <- plotPanelFigures(Y,pathPhysicalModel,'QSBAR-Pathway model','(Physio-chemical & pathway level descriptors)') + labs(x=NULL, y =NULL)
p6 <- plotPanelFigures(Y,totalModel,'QBAR-Cellular model','(Cellular level descriptors)') + labs(x=NULL, y =NULL)
p7 <- plotPanelFigures(Y,totalPhysicalModel,'QSBAR-Cellular model','(Physio-chemical & cellular level descriptors)') + labs(x=NULL, y =NULL)

# save the panel figures in the same image file as "tiff"
tiff(file = "allFigures_combined_5pathways_nolog_vF.tiff", width = 6.5, height = 8, units = 'in', res = 300, compression = 'lzw')
fig <- ggarrange(p1, p2,p4,p6, p3, p5, p7,
          labels = c("a)", "b)", "c)","d)", "e)", "f)", "g)"),
          ncol = 2, nrow = 4,hjust = -1)

annotate_figure(fig,
                bottom = text_grob(expression(bold("Observed EC"[50])), color = "black",
                                    face = "bold", size = 14),
                left = text_grob(expression(bold("Predicted EC"[50])), color = "black",
                                 face = "bold",rot = 90, size = 14)
                )
dev.off()
##############################################################################
#   Save the model results and coefficients as csv file.
##############################################################################

regMdl <- lasso_regression_summary
coeff_lasso <- matrix(regMdl$lassoFit$coefficients.lasso,nrow = 1)
path_coeff <- matrix(coeff_lasso[,1:42], nrow = 6, byrow = TRUE)# reorder the coefficient as conc. X pathways
write.csv(path_coeff, file = "lasso_coefficient_path_physical_onlyPath.csv")
write.csv(coeff_lasso[,-(1:42)], file = "lasso_coefficient_path_physical_onlyPhysical.csv")
write.csv(t(coeff_lasso), file = "lasso_coefficient_physical.csv")
write.csv(physicalDescriptorName, file = "physical_descriptorName.csv")
write.csv(t(geneName), file = "gene_descriptorName.csv")


library(compiler)
library(data.table)

source('../functions.r')

pst_rhos <- readRDS('../input-data/species-demography/nu.rds')

load('../input-data/species-demography/pop-corrections.rdata', verb=T)

load('generated/dem-samples.rdata', verb=T)

sppchar <- fread('../input-data/acap-species-list.csv')
setkeyv(sppchar, 'code.sra')

pstfun <- function(sp1) {
    d <- demsamples[[sp1]]

    sp0 <- sp1

    A <- d$a
    S <- d$scurr
    nads <- 2 * d$nbp_tot / d$pb

    ## N/Nbp
    N_g <- round(nads * S^(1-A))

    ## Rmax from Niel&Lebreton
    rmax_nl <- Rmax_NL(d$sopt, d$a)

    ## PST with f=1
    pst_nlg <- 0.5 * rmax_nl * N_g

    attr(pst_nlg, 'rmax') <- rmax_nl
    attr(pst_nlg, 'N') <- N_g
    return(pst_nlg)
}

## with f=1
pst1 <- lapply(names(demsamples), pstfun)

pst1nlg <- as.data.frame(pst1)
names(pst1nlg) <- names(demsamples)

################################
## Add overall rho correction ##
################################

rho <- 0.5
pst1nlgr <- pst1nlg * rho
rhovals <- rho

## Save
save(pst1nlg, pst1nlgr, rhovals, file = 'generated/pst-samples.rdata')

pstsumm <- rbindlist(lapply(names(pst1nlgr), function(sp) {
    x <- pst1nlgr[[sp]]
    data.table(sp=sp, mean = mean(x),
               lcl = quantile(x, 0.025, names = F),
               ucl = quantile(x, 0.975, names = F))
}))
save(pstsumm, file = 'generated/pst-summary.rdata')


# .libPaths() #this command gives the R library

func1 <- function(){
# Create vector objects.
city <- c("Tampa","Seattle","Hartford","Denver")
state <- c("FL","WA","CT","CO")
zipcode <- c(33602,98104,06161,80294)

# Combine above three vectors into one data frame.
addresses <- cbind(city,state,zipcode)

# Print a header.
cat("# # # # The First data frame\n")

# Print the data frame.
print(addresses)

# Create another data frame with similar columns
new.address <- data.frame(
   city = c("Lowry","Charlotte"),
   state = c("CO","FL"),
   zipcode = c("80230","33949"),
   stringsAsFactors = FALSE
)

# Print a header.
cat("# # # The Second data frame\n")

# Print the data frame.
print(new.address)

# Combine rows form both the data frames.
all.addresses <- rbind(addresses,new.address)

# Print a header.
cat("# # # The combined data frame\n")

# Print the result.
print(all.addresses)

#We can merge two data frames by using the merge() function.
#The data frames must have same column names on which the merging happens.
library(MASS)
merged.Pima <- merge(x = Pima.te, y = Pima.tr,
   by.x = c("bp", "bmi"),
   by.y = c("bp", "bmi")
)
print(merged.Pima)
nrow(merged.Pima)
}
# func1()
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# reshaping the data
func2 <- function(){
library(MASS)
print(ships)

library(reshape2)
#Now we melt the data to organize it, converting all columns other than type and year into multiple rows
molten.ships <- melt(ships, id = c("type","year"))
# print(molten.ships)

#Use ‘acast’ or ‘dcast’ depending on whether you want vector/matrix/array output or data frame output.
#We can cast the molten data into a new form where the aggregate of each type of ship for each year is created.
#It is done using the cast() function.(for each id=(type,year) the aggregate of other columns is calculated)
recasted.ship <- dcast(molten.ships, type+year~variable,sum)
print(recasted.ship)
}
func2()


dev<-"screen"
nox<-2; noy<-2;

clean.between<-FALSE
first.year.on.plot<-1970
last.year.on.plot<-2020

include.mean<-TRUE
include.std1<-TRUE     #include 1*std band
include.std2<-TRUE     #include 2*std band

include.obs<-TRUE	#include observations

cleanup()
newplot(dev,nox,noy);
i<-0

if (nsp>1) sp.title<-TRUE else sp.title<-FALSE;

plot_forcast<-function(vari='SSB') {

if (include.obs) {
  a<-Read.MCMC.data()
  a<-subset(a,(Year>=first.year.on.plot & Year<=last.year.on.plot) ,drop=T)
}

b<-Read.MCMC.mean.data();
b<-subset(b,(Year>=first.year.on.plot & Year<=last.year.on.plot) ,drop=T)

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

if (include.obs) {
 if (vari=="SSB") a1<-tapply(a$SSB,list(a$Species.n,a$Repetion,a$Iteration,a$Year),sum)/1000
 if (vari=="Yield") a1<-tapply(a$Yield,list(a$Species.n,a$Repetion,a$Iteration,a$Year),sum)/1000
 if (vari=="Recruit") a1<-tapply(a$recruit,list(a$Species.n,a$Repetion,a$Iteration,a$Year),sum)/1000
 if (vari=="F") a1<-tapply(a$mean.F,list(a$Species.n,a$Repetion,a$Iteration,a$Year),sum)

 repe<-as.numeric(dimnames(a1)[[2]])
 iter<-as.numeric(dimnames(a1)[[3]])
}

if (vari=="SSB") {
  b1<-tapply(b$SSB,list(b$Species.n,b$Year),sum)/1000
  b1.std<-tapply(b$SSB.std,list(b$Species.n,b$Year),sum)/1000
  y.lab<-"1000t"
  titl<-'SSB'
}
if (vari=="Yield") {
  b1<-tapply(b$Yield,list(b$Species.n,b$Year),sum)/1000
  b1.std<-tapply(b$Yield.std,list(b$Species.n,b$Year),sum)/1000
  y.lab<-"000t"
  titl<-'SOP'
}
 print(vari)
if (vari=="Recruit") {
  b1<-tapply(b$recruit,list(b$Species.n,b$Year),sum)/1000000
  b1.std<-tapply(b$recruit.std,list(b$Species.n,b$Year),sum)/1000000
  y.lab<-"10^6"
  titl<-"Recruits"
}
if (vari=="F") {
  b1<-tapply(b$mean.F,list(b$Species.n,b$Year),sum)
  b1.std<-tapply(b$mean.F.std,list(b$Species.n,b$Year),sum)
  y.lab<-" "
  titl<-expression(bar(F))
}
species.n<-dimnames(b1)[[1]]
years<-as.numeric(dimnames(b1)[[2]])
if (clean.between) {
  cleanup()
  newplot(dev,nox,noy);
  i<-0
}

for (sp in species.n) {
  if (i==noxy) {newplot(dev,nox,noy); i<-0 }
  if (sp.title) titl<-paste(name[as.numeric(sp)+1],titl)
  if (include.obs) {
     plot(years,a1[sp,1,1,],main=titl,type='l',ylab=y.lab,xlab='',ylim=(c(0,max(a1[sp,,,]))))
     for (r in repe) for (ii in iter) lines(years,a1[sp,r,ii,],col=ii)
     i<-i+1
  }
  else if (include.mean) {
     if (include.std2) max.y<-max(b1[sp,]+2*b1.std[sp,]) else if (include.std1) max.y<-max(b1[sp,]+b1.std[sp,]) else max.y<-max(b1[sp,])

     plot(years,b1[sp,],main=titl,type='l',ylab=y.lab,xlab='',ylim=c(0,max.y))
     if (include.std1) {
       lines(years,b1[sp,]-b1.std[sp,],col=2,lty=2)
       lines(years,b1[sp,]+b1.std[sp,],col=2,lty=2)
     }
     if (include.std2) {
       lines(years,b1[sp,]-2*b1.std[sp,],col=3,lty=3)
       lines(years,b1[sp,]+2*b1.std[sp,],col=3,lty=3)
     }
     i<-i+1
  }
}

}

plot_forcast(vari="Yield")
plot_forcast(vari="F")
plot_forcast(vari="SSB")
plot_forcast(vari="Recruit")


#!/usr/bin/env Rscript

#Andrew Burt - a.burt@ucl.ac.uk

library(BIOMASS)

yhatBIOMASS <- function(data)
{
	y <- computeAGB(D=data$d*100,H=data$h,WD=data$rho/1000)
	return(y)
}

uncertaintyIntervalsBIOMASS <- function(data,alpha)
{
	intervals <- list()
	uncertainties <- AGBmonteCarlo(D=data$d*100,WD=data$rho/1000,H=data$h,Dpropag=0.05,errWD=0.1,errH=0.1)
	treeintervals <- matrix(0,nrow(data),ncol=2)
	for(i in 1:nrow(data))
	{
		treeintervals[i,1] <- quantile(uncertainties$AGB_simu[i,],alpha/2)
		treeintervals[i,2] <- quantile(uncertainties$AGB_simu[i,],1-(alpha/2))
	}
	intervals[[1]] <- treeintervals
	plotintervals <- matrix(0,1,ncol=2)
	plotintervals[1,1] <- uncertainties$credibilityAGB[[1]]
	plotintervals[1,2] <- uncertainties$credibilityAGB[[2]]
	intervals[[2]] <- plotintervals
	return(intervals)
}


#!/usr/bin/Rscript --slave

#usage: chmod +x biosensor.r
#usage: ./biosensor.r "name"

argv<-commandArgs(TRUE)
query<-toString(argv[1])

#query <- "name"

#get the time machine
time<-toString(Sys.time())

#treatment of acceleration file

acceleration<-read.table("acceleration.txt",h=F)
acc_rows=nrow(acceleration)
acceleration_names<-c("acceleration_time","acceleration_X","acceleration_Y","acceleration_Z","unit")
colnames(acceleration)<-acceleration_names

pdf('acceleration_x.pdf', width=10, height=4)
plot(acceleration$acceleration_time,acceleration$acceleration_X,col="seagreen2",ylab="acceleration_X",xlab="time",pch="*",main=query, sub=paste("(",acc_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(acceleration$acceleration_time,acceleration$acceleration_X,lwd=2,col="red",cex=1.5)
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

pdf('acceleration_y.pdf', width=10, height=4)
plot(acceleration$acceleration_time,acceleration$acceleration_Y,col="seagreen2",ylab="acceleration_Y",xlab="time",pch="*",main=query, sub=paste("(",acc_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(acceleration$acceleration_time,acceleration$acceleration_Y,lwd=2,col="blue")
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

pdf('acceleration_z.pdf', width=10, height=4)
plot(acceleration$acceleration_time,acceleration$acceleration_Z,col="seagreen2",ylab="acceleration_Z",xlab="time",pch="*",main=query, sub=paste("(",acc_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(acceleration$acceleration_time,acceleration$acceleration_Z,lwd=2,col="darkgreen")
abline(h=0,lty=5,col="darkorange",lwd=2)

dev.off()

#graph all accelerations together
acc_minix<-min(acceleration$acceleration_X)
acc_miniy<-min(acceleration$acceleration_Y)
acc_miniz<-min(acceleration$acceleration_Z)

acc_minis<-c(acc_minix,acc_miniy,acc_miniz)

acc_extramini<-(min(acc_minis))-0.5

acc_maxx<-max(acceleration$acceleration_X)
acc_maxy<-max(acceleration$acceleration_Y)
acc_maxz<-max(acceleration$acceleration_Z)

acc_maxs<-c(acc_maxx,acc_maxy,acc_maxz)

acc_extramax<-(max(acc_maxs))+0.5

pdf('acceleration_all.pdf', width=10, height=6)
plot(acceleration$acceleration_time,acceleration$acceleration_X,col="seagreen2",ylab="acceleration_all",xlab="time",pch=".",
main=query, sub=paste("(",acc_rows," data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4",ylim=c(acc_extramini,acc_extramax))
lines(acceleration$acceleration_time,acceleration$acceleration_X,lwd=2,col="red")
lines(acceleration$acceleration_time,acceleration$acceleration_Y,lwd=2,col="blue")
lines(acceleration$acceleration_time,acceleration$acceleration_Z,lwd=2,col="darkgreen")
legend("topleft",legend=c("acceleration_X","acceleration_Y","acceleration_Z"), col=c("red","blue","darkgreen"),lty=1,cex=0.8)
abline(h=0,lty=5,col="darkorange",lwd=2)
print(summary(acceleration))
dev.off()

#treatment of gyroscope file
gyroscope<-read.table("gyroscope.txt",h=F)
gyro_rows=nrow(gyroscope)
gyroscope_names<-c("gyroscope_time","gyroscope_X","gyroscope_Y","gyroscope_Z","unit")
colnames(gyroscope)<-gyroscope_names

pdf('gyroscope_x.pdf', width=10, height=4)
plot(gyroscope$gyroscope_time,gyroscope$gyroscope_X,col="seagreen2",ylab="gyroscope_X",xlab="time",pch="*",main=query, sub=paste("(",gyro_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(gyroscope$gyroscope_time,gyroscope$gyroscope_X,lwd=2,col="red")
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

pdf('gyroscope_y.pdf', width=10, height=4)
plot(gyroscope$gyroscope_time,gyroscope$gyroscope_Y,col="seagreen2",ylab="gyroscope_Y",xlab="time",pch="*",main=query, sub=paste("(",gyro_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(gyroscope$gyroscope_time,gyroscope$gyroscope_Y,lwd=2,col="blue")
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

pdf('gyroscope_z.pdf', width=10, height=4)
plot(gyroscope$gyroscope_time,gyroscope$gyroscope_Z,col="seagreen2",ylab="gyroscope_Z",xlab="time",pch="*",main=query, sub=paste("(",gyro_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(gyroscope$gyroscope_time,gyroscope$gyroscope_Z,lwd=2,col="darkgreen")
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

#graph all gyroscope together
gyro_minix<-min(gyroscope$gyroscope_X)
gyro_miniy<-min(gyroscope$gyroscope_Y)
gyro_miniz<-min(gyroscope$gyroscope_Z)

gyro_minis<-c(gyro_minix,gyro_miniy,gyro_miniz)

gyro_extramini<-(min(gyro_minis))-0.5

gyro_maxx<-max(gyroscope$gyroscope_X)
gyro_maxy<-max(gyroscope$gyroscope_Y)
gyro_maxz<-max(gyroscope$gyroscope_Z)

gyro_maxs<-c(gyro_maxx,gyro_maxy,gyro_maxz)

gyro_extramax<-(max(gyro_maxs))+0.5

pdf('gyroscope_all.pdf', width=10, height=6)
plot(gyroscope$gyroscope_time,gyroscope$gyroscope_X,col="seagreen2",ylab="gyroscope_all",xlab="time",pch=".",
main=query, sub=paste("(",gyro_rows," data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4",ylim=c(gyro_extramini,gyro_extramax))
lines(gyroscope$gyroscope_time,gyroscope$gyroscope_X,lwd=2,col="red")
lines(gyroscope$gyroscope_time,gyroscope$gyroscope_Y,lwd=2,col="blue")
lines(gyroscope$gyroscope_time,gyroscope$gyroscope_Z,lwd=2,col="darkgreen")
legend("topleft",legend=c("gyroscope_X","gyroscope_Y","gyroscope_Z"), col=c("red","blue","darkgreen"),lty=1,cex=0.8)
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

#treatment of emg file
emg<-read.table("emg.txt",h=F)
emg_rows<-nrow(emg)
emg_names<-c("EMG_time","Electrode_01","Electrode_02","Electrode_03","Electrode_04","Electrode_05","Electrode_06","Electrode_07","Electrode_08","unit")
colnames(emg)<-emg_names

attach(emg)

MA1<-filter(Electrode_01,filter=array(1/10,dim=10),method=c("convolution"),side=2, circular=F)
pdf("electrodemm01.pdf",width=12, height=6)
plot(EMG_time,Electrode_01,col="seagreen4",ylab="Electrode_01",xlab="time with mobile average 10",lwd=1,main=query,sub=paste("(",emg_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(EMG_time,Electrode_01,col="seagreen2",lwd=2)
lines(EMG_time,MA1,col="red",lwd=2)
dev.off()

MA2<-filter(Electrode_02,filter=array(1/10,dim=10),method=c("convolution"),side=2, circular=F)
pdf("electrodemm02.pdf",width=12, height=6)
plot(EMG_time,Electrode_02,col="seagreen4",ylab="Electrode_02",xlab="time with mobile average 10",lwd=1,main=query,sub=paste("(",emg_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(EMG_time,Electrode_02,col="seagreen2",lwd=2)
lines(EMG_time,MA2,col="red",lwd=2)
dev.off()

MA3<-filter(Electrode_03,filter=array(1/10,dim=10),method=c("convolution"),side=2, circular=F)
pdf("electrodemm03.pdf",width=12, height=6)
plot(EMG_time,Electrode_03,col="seagreen4",ylab="Electrode_03",xlab="time with mobile average 10",lwd=1,main=query,sub=paste("(",emg_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(EMG_time,Electrode_03,col="seagreen2",lwd=2)
lines(EMG_time,MA3,col="red",lwd=2)
dev.off()

MA4<-filter(Electrode_04,filter=array(1/10,dim=10),method=c("convolution"),side=2, circular=F)
pdf("electrodemm04.pdf",width=12, height=6)
plot(EMG_time,Electrode_04,col="seagreen4",ylab="Electrode_04",xlab="time with mobile average 10",lwd=1,main=query,sub=paste("(",emg_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(EMG_time,Electrode_04,col="seagreen2",lwd=2)
lines(EMG_time,MA4,col="red",lwd=2)
dev.off()

MA5<-filter(Electrode_05,filter=array(1/10,dim=10),method=c("convolution"),side=2, circular=F)
pdf("electrodemm05.pdf",width=12, height=6)
plot(EMG_time,Electrode_05,col="seagreen4",ylab="Electrode_05",xlab="time with mobile average 10",lwd=1,main=query,sub=paste("(",emg_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(EMG_time,Electrode_05,col="seagreen2",lwd=2)
lines(EMG_time,MA5,col="red",lwd=2)
dev.off()

MA6<-filter(Electrode_06,filter=array(1/10,dim=10),method=c("convolution"),side=2, circular=F)
pdf("electrodemm06.pdf",width=12, height=6)
plot(EMG_time,Electrode_06,col="seagreen4",ylab="Electrode_06",xlab="time with mobile average 10",lwd=1,main=query,sub=paste("(",emg_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(EMG_time,Electrode_06,col="seagreen2",lwd=2)
lines(EMG_time,MA6,col="red",lwd=2)
dev.off()

MA7<-filter(Electrode_07,filter=array(1/10,dim=10),method=c("convolution"),side=2, circular=F)
pdf("electrodemm07.pdf",width=12, height=6)
plot(EMG_time,Electrode_07,col="seagreen4",ylab="Electrode_07",xlab="time with mobile average 10",lwd=1,main=query,sub=paste("(",emg_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(EMG_time,Electrode_07,col="seagreen2",lwd=2)
lines(EMG_time,MA7,col="red",lwd=2)
dev.off()

MA8<-filter(Electrode_08,filter=array(1/10,dim=10),method=c("convolution"),side=2, circular=F)
pdf("electrodemm08.pdf",width=12, height=6)
plot(EMG_time,Electrode_08,col="seagreen4",ylab="Electrode_08",xlab="time with mobile average 10",lwd=1,main=query,sub=paste("(",emg_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(EMG_time,Electrode_08,col="seagreen2",lwd=2)
lines(EMG_time,MA8,col="red",lwd=2)
dev.off()

#treatment of orientation file
orientation<-read.table("orientation.txt",h=F)
orient_rows<-nrow(orientation)
orientation_names<-c("orientation_time","cardinal_01","cardinal_02","cardinal_03","cardinal_04","unit")
colnames(orientation)<-orientation_names

pdf('cardinal_01.pdf', width=10, height=4)
plot(orientation$orientation_time,orientation$cardinal_01,col="seagreen2",ylab="cardinal_01",xlab="time",pch="*",main=query, sub=paste("(",orient_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(orientation$orientation_time,orientation$cardinal_01,lwd=2,col="darkgreen")
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

pdf('cardinal_02.pdf', width=10, height=4)
plot(orientation$orientation_time,orientation$cardinal_02,col="seagreen2",ylab="cardinal_02",xlab="time",pch="*",main=query, sub=paste("(",orient_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(orientation$orientation_time,orientation$cardinal_02,lwd=2,col="darkblue")
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

pdf('cardinal_03.pdf', width=10, height=4)
plot(orientation$orientation_time,orientation$cardinal_03,col="seagreen2",ylab="cardinal_03",xlab="time",pch="*",main=query, sub=paste("(",orient_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(orientation$orientation_time,orientation$cardinal_03,lwd=2,col="red")
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

pdf('cardinal_04.pdf', width=10, height=4)
plot(orientation$orientation_time,orientation$cardinal_04,col="seagreen2",ylab="cardinal_04",xlab="time",pch="*",main=query, sub=paste("(",orient_rows," collected data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4")
lines(orientation$orientation_time,orientation$cardinal_04,lwd=2,col="brown")
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

#graph all orientation together
cardinal_mini1<-min(orientation$cardinal_01)
cardinal_mini2<-min(orientation$cardinal_02)
cardinal_mini3<-min(orientation$cardinal_03)
cardinal_mini4<-min(orientation$cardinal_04)

cardinal_minis<-c(cardinal_mini1,cardinal_mini2,cardinal_mini3,cardinal_mini4)

cardinal_extramini<-(min(cardinal_minis))-0.5

cardinal_max1<-max(orientation$cardinal_01)
cardinal_max2<-max(orientation$cardinal_02)
cardinal_max3<-max(orientation$cardinal_03)
cardinal_max4<-max(orientation$cardinal_04)

cardinal_maxs<-c(cardinal_max1,cardinal_max2,cardinal_max3,cardinal_max4)

cardinal_extramax<-(max(cardinal_maxs))+0.5

pdf('cardinal_all.pdf', width=10, height=6)
plot(orientation$orientation_time,orientation$cardinal_01,col="seagreen2",ylab="orientation_all",xlab="time",pch=".",
main=query, sub=paste("(",gyro_rows," data )"),cex.main=2, cex.lab=1.5, cex.sub=1.2, col.sub="seagreen4",ylim=c(cardinal_extramini,cardinal_extramax))
lines(orientation$orientation_time,orientation$cardinal_01,lwd=2,col="darkgreen")
lines(orientation$orientation_time,orientation$cardinal_02,lwd=2,col="darkblue")
lines(orientation$orientation_time,orientation$cardinal_03,lwd=2,col="red")
lines(orientation$orientation_time,orientation$cardinal_04,lwd=2,col="brown")
legend("topleft",legend=c("cardinal_01","cardinal_02","cardinal_03","cardinal_04"), col=c("darkgreen","darkblue","red","brown"),lty=1,cex=0.8)
abline(h=0,lty=5,col="darkorange",lwd=2)
dev.off()

sink("summary_acceleration.txt")
print(summary(acceleration))
sink()

sink("summary_orientation.txt")
print(summary(orientation))
sink()

sink("summary_gyroscope.txt")
print(summary(gyroscope))
sink()

sink("summary_electrodes.txt")
print(summary(emg))
sink()


# rocauc.r - plot ROC and compute AUC given score+label table with R using RROC
#
# Alex Stivala, October 2008
#
# Requires the ROCR package from CRAN (developed with version 1.0-2)
# (ROCR in turn requires gplots, gtools, gdata)
#
# Run this on the output of e.g. tsevalfn.py with the -l option,
# it is a table with one column of scores from classifier, and second
# column of true class label (0 or 1)
#
# Uses commandArgs() R function to get trailing arguments from R command
# line ie after the --args option. The filename of the .slrtab file
# is obtained from --args, and the output file is constructed form it
# eg foo.slrtab results in foo.eps file for ROC plot with
#
#    R --vanilla -f rocauc.r --args foo.slrtab
#
#
# The citation for the ROCR package is
#   Sing et al 2005 "ROCR: visualizing classifier performance in R"
#   Bioinformatics 21(20):3940-3941
#
#
# Also calculate stdand eror (and 95% confidence inteval) for the AUC,
# according to Hanley-McNeil method:
#   Hanley & McNeil 1982 "The Meaning and Use of the Area under a Receiver
#   Operating Characteristic (ROC) Curve" Radiology 143(1):29-36
# ROCR has all sorts of featuers but this isn't one of them so had
# to implement it here.
#

# $Id: rocauc.r 3606 2010-05-04 06:03:55Z alexs $

library(ROCR)

#
# functions
#

#
# compute AUC and standard error and 95% CI by Hanley-McNeil method,
# using R wilcox.test for the Wilcoxon rank-sum (aka Mann-Whitney) test
#
# Parameters:
#   tab : data frame with score and label columns
#
# Return value:
#   list with auc and stderror members
#
compute_auc_error <- function(tab)
{
    # tab is a data frame with score and label columns
    x <- tab$score[tab$label == 1]
    y <- tab$score[tab$label == 0]
    wilcox <- wilcox.test(x,y)
    nA <- length(x)
    nN <- length(y)
    stopifnot(nA + nN == length(tab$label))
    nA <- as.double(nA)
    nN <- as.double(nN)
    U <- wilcox$statistic  # Mann-Whitney U statistic
    theta <- U / (nA * nN) # AUC
    theta2 <- theta*theta
    Q1 <- theta / (2 - theta)
    Q2 <- 2*theta2 / (1 + theta)
    SE2 <- (theta*(1-theta) + (nA - 1)*(Q1 - theta2) + (nN - 1)*(Q2 - theta2)) /
          (nA*nN)
    SE <- sqrt(SE2)

    retval <- list()
    retval$auc <- theta
    retval$stderror <- SE
    return(retval)
}

#
# plot the ROC curve and compute AUC using ROCR
#
plotroc <- function(filename)
{
    tab <- read.table(filename, header=TRUE)
    # tab is a data frame with score and label columns
    pred <- prediction(tab$score, tab$label)
    perfroc <- performance(pred, measure="tpr",x.measure="fpr")
    perfauc <- performance(pred, measure="auc")

    # EPS suitable for inserting into LaTeX
    postscript(sub('[.]slrtab$','.eps',filename),
               onefile=FALSE,paper="special",horizontal=FALSE,
               width = 9, height = 6)
    plot(perfroc)
    auc <- perfauc@y.values
    legend('bottomright', legend=paste('AUC =', format(auc, digits=4)), bty='n')
    dev.off()

    aucerr <- compute_auc_error(tab)
    quantile <- 1.96 # 0.975 quantile of normal distrib
    low95 <- aucerr$auc - quantile * aucerr$stderr
    high95 <- aucerr$auc + quantile * aucerr$stderr

    cat(filename,':\n')
    cat('RROC          AUC =',format(perfauc@y.values,digits=4),'\n')
    cat('Hanley-McNeil AUC =',format(aucerr$auc,digits=4),'\n')
    cat('       std. error =',format(aucerr$stderror,digits=5),'\n')
    cat('           95% CI =',format(low95,digits=4),',',
                               format(high95,digits=4),'\n')
}

#
# main
#
filename <- commandArgs(trailingOnly=TRUE)
plotroc(filename)


#Run this script in the case of fresh install of R

install.packages(c("dplyr",
                   "dslabs",
                   "kernlab",
                   "tidyverse"
                   )
                 )


data = read.delim("comparison.tsv")
keep = function(data, tag) {
  data[data$dist == tag & data$compression == 50 & data$q !=0.3 & data$q != 0.7 & data$q != 0.2 & data$q != 0.8, ]
}

png("qd-sizes.png", width=1800, height=700, pointsize=28)
layout(matrix(c(1,2,3), 1, 3, byrow=T), widths=c(1,1))

gray = rgb(0,0,0,0.05)

old = par(mar=c(4.5,5,3,0.5))
plot(s2~s1, data, log='xy', pch=21, col=gray, bg=gray, cex=0.4,
     xlab="t-digest (bytes)", ylab="Q-digest (bytes)",
     xlim=c(100, 120000),
     cex.lab=1.5, xaxt='n', yaxt='n')
box(lwd=3)

axis(at=c(100, 300, 1000, 3000, 10000, 30000, 100000), labels=c(100, 300, "1K", "3K", "10K", "30K", "100K"), side=1)
axis(at=c(100, 300, 1000, 3000, 10000, 30000, 100000), labels=c(100, 300, "1K", "3K", "10K", "30K", "100K"), side=2)

steps = exp(seq(log(100), log(200000), by=log(2)))
lines(steps, steps, col='lightgrey')
lines(steps, steps/2, lty=2, col='lightgrey')
lines(steps,steps*2, lty=2, col='lightgrey')

for (compression in c(2, 5, 10, 20, 50, 100, 200, 500, 1000, 2000)) {
  x = mean(data[data$compression == compression,]$s1) * 1.8
  y = mean(data[data$compression == compression,]$s2)
  text(x,y,compression)
}
text(10000, 1000, expression(1/delta), cex=1.5)

par(old)

old = par(mar=c(4.5,5,3,0.5))
boxplot(1e6*e2 ~ q, keep(data, 'uniform'), at=1:7 - 0.13, boxwex=0.3, xaxt='n', yaxt='n',
        ylab="Quantile error (ppm)", xlab="Quantile",
        ylim=c(-10000, 20000), cex.lab=1.5, col=rgb(0.95, 0.95, 0.95))
boxplot(1e6*e1 ~ q, keep(data, 'uniform'), col=rgb(0.4, 0.4, 0.4), at=1:7 + 0.13, add=T, boxwex=0.3, xaxt='n', yaxt='n')
axis(at=1:7, labels=c(0.001, 0.01, 0.1, 0.5, 0.9, 0.99, 0.999), side=1)
axis(side=2, cex.label=2)
abline(h=0, lwd=2, col='gray')
for (i in 1:7) {
  abline(v=i, lwd=1, col='lightgray', lty=2)
}
legend(5.5, 20000, c("Q-digest", "t-digest"), fill = c(rgb(0.95, 0.95, 0.95), rgb(0.4, 0.4, 0.4)))
text(6.5, 14000, "Uniform", cex=1.5)
text(6.5, 12000, expression(1/delta == 50), cex=1.5)
box(lwd=3)
par(old)

old = par(mar=c(4.5,5,3,0.5))
boxplot(1e6*e2 ~ q, keep(data, 'gamma'), col=rgb(0.95, 0.95, 0.95), at=1:7 - 0.13, boxwex=0.3, xaxt='n',
        ylab="Quantile error (ppm)", xlab="Quantile",
        cex.lab=1.5)
boxplot(1e6*e1 ~ q, keep(data, 'gamma'), col=rgb(0.4, 0.4, 0.4), at=1:7 + 0.13, add=T, boxwex=0.3, xaxt='n')
axis(at=1:7, labels=c(0.001, 0.01, 0.1, 0.5, 0.9, 0.99, 0.999), side=1)
abline(h=0, lwd=2, col='gray')
for (i in 1:7) {
  abline(v=i, lwd=1, col='lightgray', lty=2)
}
legend(5.5, 88000, c("Q-digest", "t-digest"), fill = c(rgb(0.95, 0.95, 0.95), rgb(0.4, 0.4, 0.4)))
text(6.5, 68000, expression(Gamma(0.1, 0.1)), cex=1.5)
text(6.5, 62000, expression(1/delta == 50), cex=1.5)
box(lwd=3)
par(old)

dev.off()


# set the working directory (where the files are, so no paths are needed when loading/saving data)
# change this to your directory
setwd('E:teaching/2015_acg5075_r/introR')

# read csv file with columns: month,orders,costs
myData = read.csv("chapter14/dataset.csv")
myMatrix = as.matrix(myData)
# functions
# see http://www.statmethods.net/management/userfunctions.html

# example, function that multiplies
myMultiply <- function(arg1, arg2 ){ return(arg1 * arg2) }

myMultiply(5,2)
#[1] 10

# read the function stored in the file myHighLow.r
source("chapter15/myHighLow.r");

# call it
varCost <- myHighLow( myMatrix, "orders", "costs")


# Working with full joins

# First need to understand the data
# Start with inventory_parts_joined table
inventory_parts_joined %>%
  # Combine with the sets table
  inner_join(sets, by = "set_num") %>%
  # Combine with the themes table
  inner_join(themes, by = c("theme_id" = "id"), suffix = c("_set", "_theme"))

# 2. Aggregate the data
# Count the part number and color id, weight by quantity
batman %>%
    count(part_num, color_id, wt = quantity)
star_wars %>%
    count(part_num, color_id, wt = quantity)

# 3. Full join the two datasets
batman_parts %>%
  # Combine the star_wars_parts table
  full_join(star_wars_parts, by = c("part_num", "color_id"), suffix = c("_batman", "_star_wars")) %>%
  # Replace NAs with 0s in the n_batman and n_star_wars columns
  replace_na(list(n_batman = 0,
                  n_star_wars = 0))

# 4. Comparing star wars with batman LEGO parts
parts_joined %>%
  # Sort the number of star wars pieces in descending order
  arrange(desc(n_star_wars)) %>%
  # Join the colors table to the parts_joined table
  inner_join(colors, by = c("color_id" = "id")) %>%
  # Join the parts table to the previous join
  inner_join(parts, by = "part_num", suffix = c("_color", "_part"))


#' Time derivative of DO concentration
#'
#' @param t Time step for the ode integration
#' @param y Current state (dissolved oxygen concentration)
#' @param parms a named vector of parameters; see details
#' @param data a list of data for the ode; see details
#' @param return_list logical, should a list (suitable for deSolve) be returned?
#' @details `params` must be a vector including the following named items:
#' * `P1` $(W min g^{-1} O_2)$ inverse of the slope of a photosynthesis–irradiance curve at low
#' 		 light intensity
#' * `P2` $(m^2 min g^{-1} O_2)$ inverse maximum photosynthesis rate; can be zero to assume
#' 		  GPP is linear with light intensity instead of saturating
#' * `k600` coefficient of gas exchange for a gas with a Schmidt number of 600 (see [kT()]).
#' * `ER24_20` daily ecosystem respiration rate, standardized at 20 degrees C
#'
#' `data` is a named list of (constant) data items, including the following:
#' * `PAR`  a function that takes time as a parameter and returns light intensity $(W/m^2)$
#' * `temp` a function that takes time as a parameter and returns water temperature (degrees C)
#' * `P`    pressure, in atmospheres
#' * `z`    Depth, in meters
#'
#' @references Fuß, T. et al. (2017). Land use controls stream ecosystem metabolism by shifting
#' 		 dissolved organic matter and nutrient regimes. *Freshw Biol* **62**:582–599.
#'
#'		 Van de Bogert MC et al. 2007. Assessing pelagic and benthic metabolism using free
#' 		 water measurements. *Limnol. Oceanogr. Methods* **5**:145–155.
#'
#' @return Time derivative of dissolved oxygen
#' @export
oneStation_dDOdt <- function(t, y, parms, data, return_list=FALSE)
{
	warning("oneStation_dDOdt is deprecated; use DOCalibration(..., method = 'stan' instead)")
	# gross primary production; Fuß et al eq 2
	GPP <- gpp(data$PAR(t), parms['P1'], parms['P2'])

	# rearation flux, Van de Bogert et al eqn 4; note that k600 is fixed
	RF <- kT(data$temp(t), parms['k600']) * (osat(data$temp(t), data$P) - y)

	# ecosystem respiration; Fuß et al eq 4
	ER <- (parms['ER24_20'] / (60*24)) * (1.045^(data$temp(t) - 20))

	val <- (GPP + ER + RF) / data$z
	if(return_list) {
		return(list(val))
	} else {
		return(val)
	}
}

#' Predict a time series of dissolved oxygen concentration
#' @param initial initial dissolved oxygen concentration
#' @param times The times at which to solve the system
#' @param params a named vector of parameters; see details
#' @param data a list of data for the ode; see details
#' @param dt Time step for integration; only used if `method == 'euler'`
#' @param method The integration method to use; default is euler
#' @param gpp Logical, should GPP at each time step be returned as well?
#' @details Light and temperature time series will be approximated using linear interpolation
#' 		at the desired time steps
#'
#' `params` must be a vector including the following named items:
#' * `P1` $(W min g^{-1} O_2)$ inverse of the slope of a photosynthesis–irradiance curve at low
#' 		 light intensity
#' * `P2` $(m^2 min g^{-1} O_2)$ inverse maximum photosynthesis rate; can be zero to assume
#' 		  GPP is linear with light intensity instead of saturating
#' * `k600` coefficient of gas exchange for a gas with a Schmidt number of 600; (see [kT()])
#' * `ER24_20` daily ecosystem respiration rate, standardized at 20 degrees C
#'
#' `data` is a named list of (constant) data items, including the following:
#' * `PAR`  2-column data frame; first column is light, second is time of observation
#' * `temp` 2-column data frame; first column is temperature, second is time of observation
#' * `P`    pressure, in atmospheres
#' * `z`    Depth, in meters
#' @return Time series of dissolved oxygen concentrations
#' @export
oneStation_DOPredict <- function(initial, times, params, data, dt = 1,
			method=c('euler', 'lsoda'), gpp = FALSE) {
	warning("oneStation_DOPredict is deprecated; use DOCalibration(..., method = 'stan' instead)")
	method <- match.arg(method)
	if(method == "lsoda" && !(requireNamespace("deSolve")))
		stop("Package deSolve is required for method lsoda; please install it and try again")
	if(times[1] != 0)
		stop('first time step must be 0')
	if(method == 'euler' && sum(times %% dt) != 0)
		stop('dt must divide evenly into all values in times')

	dDOData <- list(
		PAR = approxfun(x = data$PAR[,2], y = data$PAR[,1], rule = 2),
		temp = approxfun(x = data$temp[,2], y = data$temp[,1], rule = 2),
		P = data$P,
		z = data$z)

	if(method == 'euler') {
		state <- numeric(length(times))
		state[1] <- statet <- initial
		t <- times[1]
		for(i in 2:length(state)) {
			while(t < times[i]) {
				statet <- statet + dt * oneStation_dDOdt(t, statet, params, dDOData)
				t <- t + dt
			}
			state[i] <- statet
		}
	} else {
		state <- deSolve::ode(initial, times = times, func = oneStation_dDOdt, parms = params,
			data = dDOData, return_list=TRUE)
		state <- state[,2]
	}
	if(gpp) {
		state <- cbind(DO = state, GPP = gpp(dDOData$PAR(times), params['P1'], params['P2']))
	}
	return(state)
}

#' Log posterior probability for the DO curve given empirical data
#' @param params A named vector of model parameters; see details
#' @param data A list of model data, see details
#' @param prior A list of prior hyperparameters; see details
#' @param ... Additional parameters to be passed to [DO_predict()]
#' @details #' `params` must be a vector including the following named items:
#' * `logP1` $(W min g^{-1} O_2)$ log(inverse of the slope of a photosynthesis–irradiance curve)
#' 		 at low light intensity
#' * `logP2` $(m^2 min g^{-1} O_2)$ log(inverse maximum photosynthesis rate)
#' * `logk600` coefficient of gas exchange for a gas with a Schmidt number of 600; (see [kT()])
#' * `logMinusER24_20` log(-1 * daily ecosystem respiration rate), standardized at 20 degrees C
#' * `logsd` log(Error standard deviation)
#'
#' `data` is a named list of (constant) data items, including the following:
#' * `DO` 2-column data frame; first column is dissolved oxygen, second is time of observation
#' * `PAR`  2-column data frame; first column is light, second is time of observation
#' * `temp` 2-column data frame; first column is temperature, second is time of observation
#' * `P`    pressure, in atmospheres
#' * `z`    Depth, in meters
#'
#' `prior` is a list of hyperparameters for the priors on parameters listed under `params`.
#' All priors are normal. Thus, each list item should be named (following the names from
#' `params`), and each item should be a vector of length two giving the mean and standard
#' deviation of the prior for that parameter. Note that each parameter is optional
#' (as is the entire list); missing items will get a minimally informative normal(0,10)
#'  distribution.
#' @return The unnormalized log probability of the model given the data
#' @export
oneStation_DOlogprob <- function(params, data, prior = list(), ...) {
	warning("oneStation_DOlogprob is deprecated; use DOCalibration(..., method = 'stan' instead)")
	# check for each parameter, assign default priors if not specified
	trParNames <- c('logP1', 'logP2', 'logk600', 'logMinusER24_20', 'logsd')
	parNames <- c('P1', 'P2', 'k600', 'ER24_20', 'sd')
	for(nm in trParNames) {
		if(! nm %in% names(prior))
			prior[[nm]] <- c(0,10)
	}

	initial <- data$DO[1,1]
	times <- data$DO[,2]

	# parameters are log transformed to make sampling nicer
	doParams <- oneStation_parTransform(params)
	predicted <- oneStation_DOPredict(initial, times, doParams, data)

	logprob <- sum(dnorm(data$DO[,1], predicted, doParams['sd'], log = TRUE)) +
		dnorm(params['logP1'], prior[['logP1']][1], prior[['logP1']][2], log = TRUE) +
		dnorm(params['logP2'], prior[['logP2']][1], prior[['logP2']][2], log = TRUE) +
		dnorm(params['logk600'], prior[['logk600']][1], prior[['logk600']][2], log = TRUE) +
		dnorm(params['logMinusER24_20'], prior[['logMinusER24_20']][1], prior[['logMinusER24_20']][2], log = TRUE) +
		dnorm(params['logsd'], prior[['logsd']][1], prior[['logsd']][2], log = TRUE)

	return(logprob)
}

#' Transfornm parameters for the one station model
#' @param params The vector of parameters, see [oneStation_DOlogprob()], or a matrix of
#' 		samples (in which case the transformation is applied to app samples)
#' @param reverse Should the reverse transformation be applied?
#' @details This function transforms the parameters of the one station model from the
#' 	scale at which the parameters are calibrated to the scale of modelling. If
#'  `reverse == TRUE` the opposite transformation is performed.
#' @return The transformed parameters
#' @keywords internal
oneStation_parTransform <- function(params, reverse = FALSE) {
	if(reverse) {
		if(is.matrix(params)) {
			logP1 <- log(params[,'P1'])
			logP2 <- log(params[,'P2'])
			logk600 <- log(params[,'k600'])
			logMinusER24_20 <- log(-1 * params[,'ER24_20'])
			logsd <- log(params[,'sd'])
			result <- cbind(logP1, logP2, logk600, logMinusER24_20, logsd)
		} else {
			logP1 <- log(params['P1'])
			logP2 <- log(params['P2'])
			logk600 <- log(params['k600'])
			logMinusER24_20 <- log(-1 * params['ER24_20'])
			logsd <- log(params['sd'])
			result <- c(logP1 = logP1, logP2 = logP2, logk600 = logk600,
				logMinusER24_20 = logMinusER24_20, logsd = logsd)
		}
	} else {
		if(is.matrix(params)) {
			P1 <- exp(params[,'logP1'])
			P2 <- exp(params[,'logP2'])
			k600 <- exp(params[,'logk600'])
			ER24_20 <- -1 * exp(params[,'logMinusER24_20'])
			sd <- exp(params[,'logsd'])
			result <- cbind(P1, P2, k600, ER24_20, sd)
		} else {
			P1 <- exp(params['logP1'])
			P2 <- exp(params['logP2'])
			k600 <- exp(params['logk600'])
			ER24_20 <- -1 * exp(params['logMinusER24_20'])
			sd <- exp(params['logsd'])
			result <- c(P1, P2, k600, ER24_20, sd)
			names(result) <- c("P1", "P2", "k600", "ER24_20", "sd")
		}
	}
	return(result)
}

#' Produce posterior simulations for DO curve and GPP
#' @param params Parameter posterior matrix returned (e.g.) from [DOCalibration()].
#' @param data Data list as required by [oneStation_DOPredict()].
#' @return list including predicted DO and GPP at each time step as well as the prediction times.
oneStation_DOSim <- function(params, data) {
	initial <- data$DO[1,1]
	times <- data$DO[,2]

	sims <- apply(params, 1, function(par) {
		c(oneStation_DOPredict(initial, times, par, data, dt = 1, gpp=TRUE))
	})
	list(DO = sims[1:length(times),], GPP = sims[(length(times)+1):nrow(sims),], times = times)
}


library(proxy)
library(recommenderlab)
library(reshape2)
movies <- read.csv("C:/Users/Harsh Darji/Desktop/myapp/movies.csv", header = TRUE, stringsAsFactors=FALSE)
ratings <- read.csv("C:/Users/Harsh Darji/Desktop/myapp/ratingss.csv", header = TRUE)
movies2 <- movies[-which((movies$movieId %in% ratings$movieId) == FALSE),]

movie_recommendation <- function(input,input2,input3) {
  #input = "Gladiator (2000)"
  #input2 = "Aeon Flux (2005)"
  #input3 = "Alexander (2004)"
  row_num <- which(movies2[,2] == input)
  row_num2 <- which(movies2[,2] == input2)
  row_num3 <- which(movies2[,2] == input3)
  userSelect <- matrix(NA,10325)
  userSelect[row_num] <- 5 #hard code first selection to rating 5
  userSelect[row_num2] <- 4 #hard code second selection to rating 4
  userSelect[row_num3] <- 3 #hard code third selection to rating 3
  userSelect <- t(userSelect)

  ratingmat <- dcast(ratings, userId~movieId, value.var = "rating", na.rm=FALSE)
  ratingmat <- ratingmat[,-1]
  colnames(userSelect) <- colnames(ratingmat)
  ratingmat2 <- rbind(userSelect,ratingmat)
  ratingmat2 <- as.matrix(ratingmat2)

  #Convert rating matrix into a sparse matrix
  ratingmat2 <- as(ratingmat2, "realRatingMatrix")

  #Create Recommender Model. "UBCF" stands for user-based collaborative filtering
  recommender_model <- Recommender(ratingmat2, method = "UBCF",param=list(method="Cosine",nn=30))
  recom <- predict(recommender_model, ratingmat2[1], n=10)
  recom_list <- as(recom, "list")
  no_result <- data.frame(matrix(NA,1))
  recom_result <- data.frame(matrix(NA,10))
  if (as.character(recom_list[1])=='character(0)'){
    no_result[1,1] <- "Sorry, there is not enough information in our database on the movies you've selected. Try to select different movies you like."
    colnames(no_result) <- "No results"
    return(no_result)
  } else {
    for (i in c(1:10)){
      recom_result[i,1] <- as.character(subset(movies,
                                               movies$movieId == as.integer(recom_list[[1]][i]))$title)
    }
    colnames(recom_result) <- "User-Based Collaborative Filtering Recommended Titles"
    return(recom_result)
  }
}

Project - Movie Recommendation System/myapp/helpercode.r


 require(ncdf)
 require(raster)

 setClass("mapncdf",representation(
	filename="character",
	varname="character",
	start_ind="numeric",
	count_ind="numeric"))

 map2spatial<-function(lon,lat,map,missval){
	 lonarray<-array(rep(lon,length(lat)), dim=dim(map))
	 latarray<-t(array(rep(lat,length(lon)),dim=dim(t(map))))
	sp<-data.frame("lon"=as.vector(lonarray),"lat"=as.vector(latarray),"val"=as.vector(map))
	sp$lon[sp$lon>180]<-sp$lon[sp$lon>180]-360
	sp
}

 map.info.ncdf<-function(filename){
	nc<-open.ncdf(filename)
	ncdim<-list()
	cat("=========\n")
	cat(filename, ":\n")
	cat("=========\n")
	cat(length(nc$var), "variables:\n")

	print(names(nc$var))
	cat("\nvariables have",nc$ndims,"dimensions.\n")
	print(names(nc$dim))
	for(i in 1:nc$ndims){
		len<-nc$dim[[i]]$len
		cat(nc$dim[[i]]$name, nc$dim[[i]]$len, nc$dim[[i]]$units,"\n")
		if(len>8)  cat("[", nc$dim[[i]]$vals[1:4],",...,",nc$dim[[i]]$vals[(len-3):len],"]\n")
		else print(nc$dim[[i]]$vals)
		ncdim[[nc$dim[[i]]$name]]<-nc$dim[[i]]$vals
	}
	ncdim
}

 setMethod("mapConvert", signature(obj="mapncdf"),
	function(obj){
		 ncdim<-map.info.ncdf(obj@filename)
		 nc<-open.ncdf(obj@filename)
		 ndims<-nc$ndims
 		 data<-get.var.ncdf(nc, obj@varname, start=obj@start_ind,count=obj@count_ind)
 		 missval<-nc$var[[obj@varname]]$missval

 		 dataframe<-map2spatial(ncdim[[1]],ncdim[[2]], data,missval)
 		 mappoints<-list()
 		 mappoints[["dataframe"]]<-dataframe
 		 mappoints[["missval"]]<-missval

 		mappoints
	 })


library(ape)
library(geiger)

bi <- 0.5

files <- list.files("../data/asjpNex")

mbfiles <- files[grepl(".mb.nex$", files)]

families <- sub(".mb.nex*", "", mbfiles)

dir.create("../data/posteriorTrees", showWarnings = F, recursive = FALSE, mode = "0777")

for (fm in families) {
    print(fm)
    trees1 <- read.nexus(paste0("../data/asjpNex/output/", fm,'.run1.t'))
    trees2 <- read.nexus(paste0("../data/asjpNex/output/", fm,'.run2.t'))
    trees <- c(trees1[-(1:floor(bi*length(trees1)))],
               trees2[-(1:floor(bi*length(trees2)))])
    if (length(trees)>1000) {
        trees <- sample(trees,1000)
    }
    write.tree(trees,paste0("../data/posteriorTrees/", fm,'.posterior.tree'))
}

##

files = list.files("revbayes")
revfiles = files[grepl(".Rev", files)]
families = sub(".Rev","",revfiles)

for (fm in families) {
    print(fm)
    trees1S = as.character(read.table(paste0("revbayes/output/",fm,"_run_1.t"), header=T)$tree)
    trees1 = read.tree(text=trees1S)
    trees2S = as.character(read.table(paste0("revbayes/output/",fm,"_run_2.t"), header=T)$tree)
    trees2 = read.tree(text=trees2S)
    trees <- c(trees1[-(1:floor(bi*length(trees1)))],
               trees2[-(1:floor(bi*length(trees2)))])
    if (length(trees)>1000) {
        trees <- sample(trees,1000)
    }
    write.tree(trees,paste0("../data/posteriorTrees/", fm,'.posterior.tree'))
}