# setwd(dirname(rstudioapi::getActiveDocumentContext()$path))

covered <- function(bh, bt, SE, level = .05) {
  z. <- qnorm(1-level/2)
  (bt <= bh + z.*SE) & (bt >= bh - z.*SE)
}

l2 <- function(x) sqrt(sum(x^2))

# The following is taken from http://web.stanford.edu/~montanar/sslasso/home.html
# Authors: Hamid Javadi, Adel Javanmard, Andrea Montanari, Sven Schmit
# Date: April 24th, 2014
#
# Confidence intervals for high-dimensional regression using the method of
# A. Javanmard, A. Montanari
# "Confidence intervals and hypothesis testing for high-dimensional regression"
# 2013, arXiv:1306.3171
#
library(Matrix);
library(glmnet);
library(expm);
library(flare);

SoftThreshold <- function( x, lambda ) {
  #
  # Standard soft thresholding
  #
  if (x>lambda){
    return (x-lambda);}
  else {
    if (x< (-lambda)){
      return (x+lambda);}
    else {
      return (0); }
  }
}

InverseLinftyOneRow <- function ( sigma, i, mu, maxiter=50, threshold=1e-2 ) {
  p <- nrow(sigma);
  rho <- max(abs(sigma[i,-i])) / sigma[i,i];
  mu0 <- rho/(1+rho);
  beta <- rep(0,p);

  if (mu >= mu0){
    beta[i] <- (1-mu0)/sigma[i,i];
    returnlist <- list("optsol" = beta, "iter" = 0);
    return(returnlist);
  }

  diff.norm2 <- 1;
  last.norm2 <- 1;
  iter <- 1;
  iter.old <- 1;
  beta[i] <- (1-mu0)/sigma[i,i];
  beta.old <- beta;
  sigma.tilde <- sigma;
  diag(sigma.tilde) <- 0;
  vs <- -sigma.tilde%*%beta;

  while ((iter <= maxiter) && (diff.norm2 >= threshold*last.norm2)){

    for (j in 1:p){
      oldval <- beta[j];
      v <- vs[j];
      if (j==i)
        v <- v+1;
      beta[j] <- SoftThreshold(v,mu)/sigma[j,j];

      if (oldval != beta[j]){
        vs <- vs + (oldval-beta[j])*sigma.tilde[,j];
      }
    }

    iter <- iter + 1;
    if (iter==2*iter.old){
      d <- beta - beta.old;
      diff.norm2 <- sqrt(sum(d*d));
      last.norm2 <-sqrt(sum(beta*beta));
      iter.old <- iter;
      beta.old <- beta;
      if (iter>10)
        vs <- -sigma.tilde%*%beta;
    }
  }

  returnlist <- list("optsol" = beta, "iter" = iter)
  return(returnlist)
}

InverseLinfty <- function(sigma, n, resol=1.5, mu=NULL, maxiter=50, threshold=1e-2, verbose = TRUE) {
  isgiven <- 1;
  if (is.null(mu)){
    isgiven <- 0;
  }

  p <- nrow(sigma);
  M <- matrix(0, p, p);
  xperc = 0;
  xp = round(p/10);
  mus <- numeric(p)
  for (i in 1:p) {
    if ((i %% xp)==0){
      xperc = xperc+10;
      if (verbose) {
        print(paste(xperc,"% done",sep="")); }
    }
    if (isgiven==0){
      mu <- (1/sqrt(n)) * qnorm(1-(0.1/(p^2)));
    }
    mu.stop <- 0;
    try.no <- 1;
    incr <- 0;
    while ((mu.stop != 1)&&(try.no<10)){
      last.beta <- beta
      output <- InverseLinftyOneRow(sigma, i, mu, maxiter=maxiter, threshold=threshold)
      beta <- output$optsol
      iter <- output$iter
      if (isgiven==1){
        mu.stop <- 1
      }
      else{
        if (try.no==1){
          if (iter == (maxiter+1)){
            incr <- 1;
            mu <- mu*resol;
          } else {
            incr <- 0;
            mu <- mu/resol;
          }
        }
        if (try.no > 1){
          if ((incr == 1)&&(iter == (maxiter+1))){
            mu <- mu*resol;
          }
          if ((incr == 1)&&(iter < (maxiter+1))){
            mu.stop <- 1;
          }
          if ((incr == 0)&&(iter < (maxiter+1))){
            mu <- mu/resol;
          }
          if ((incr == 0)&&(iter == (maxiter+1))){
            mu <- mu*resol;
            beta <- last.beta;
            mu.stop <- 1;
          }
        }
      }
      try.no <- try.no+1
    }
    mus[i] <- mu
    M[i,] <- beta;
  }
  return(list(Theta.hat = M, mus = mus))
}


# add the rate column
murders <- mutate(murders, rate =  total / population * 100000, rank = rank(-rate))

# Create a table, call it my_states, that satisfies both the conditions
my_states <- filter(murders, region %in% c("Northeast", "West") & rate <1)

# Use select to show only the state name, the murder rate and the rank
select(my_states, state, rate, rank)


require(ppcor)
require(psych)
require(ggplot2)
require(rlm)
require(moments)
require(boot)
require(effsize)
require(reshape2)
require(ggplot2)
require(gridExtra)
require(dplyr)
require(stringr)
require(tidyr)
require(text2vec)
require(heatmaply)
require(lmerTest)
require(lavaan)
require(rbin)
require(Rmisc)
require(mixtools)
require(MASS)
require(faux)
# load('wave1_out')

# rewriting the original simulated correlation so nothing is anchored on empirical data ------
set.seed(20200604)
steps <- seq(0,1,.005)
iter.per.step <- nrow(df.indiff)
niter <- 10
r.super <- rep(NA,length(steps)*niter) # correlation between two correlations
r.super.split <- rep(NA,length(steps)*niter)
for(i in 1:length(steps)){
  r.base.1 <- rep(NA, iter.per.step)
  r.base.2 <- rep(NA, iter.per.step)
  r.base.3 <- rep(NA, iter.per.step)
  r.base.4 <- rep(NA, iter.per.step)
  for(k in 1:niter){
    for(j in 1:iter.per.step){
      anchor <- as.vector(scale(rnorm(75)))
      correlated.vec <- rnorm_pre(anchor, r = steps[i],empirical = T) # vary egocentrism
      third.vec <- rnorm(75) # vector to correlate with both the anchor and the correlated vec
      r.base.1[j] <- cor(anchor,third.vec)
      r.base.2[j] <- cor(correlated.vec,third.vec)
      # step 1. split half
      ind.all <- seq(1,75)
      half.ab <- sample(ind.all,sample(c(37,38),1),replace = F)
      half.bc <- ind.all[!(ind.all %in% half.ab)]
      r.base.3[j] <- cor(anchor[half.ab],third.vec[half.ab])
      r.base.4[j] <- cor(anchor[half.bc],third.vec[half.bc])
    }
    cormat <- cor(apply(cbind(r.base.1,r.base.2),2,fisherz))
    r.super[(i-1)*niter+k] <- cormat[2]
    cormat2 <- cor(apply(cbind(r.base.3,r.base.4),2,fisherz))
    r.super.split[(i-1)*niter+k] <- cormat2[2]
  }
  print(i)
}
test_ind <- rep(steps,each = niter)
test_dat <- as.data.frame(cbind(test_ind,r.super, r.super.split))
# graph without splitting procedure
g.rrabrac.varyac <- ggplot(data = test_dat, aes(x = test_ind, y = r.super)) +
  geom_point(alpha = .3)+
  xlab('Correlation between A and C')+
  ylab('Secondary correlation between rAB and rBC') +
  ggtitle('Secondary correlation as a function of the correlation between unshared base variable')
# graph when the the splitting procudure is employed
g.rrabrac.varyac.split <- ggplot(data = test_dat, aes(x = test_ind, y = r.super.split)) +
  geom_point(alpha = .3)+
  xlab('Correlation between A and C')+
  ylab('Secondary correlation between rAB and rBC') +
  ggtitle('Secondary correlation as a function of the correlation between unshared base variable')

# full generative----
# first generate top level correlation, given the correlation of correlations
# then for each person generate correlated base variables
# look at top level param recovery for split vs non-split
# specify params
cor_cor <- .8
split_recover <- function(cor_cor,ac){
  # generate top level correlation - draw from mvnorm then normalize and shift to between 0 and 1
  top_cor <- mvrnorm(n = 102,mu = c(0,0), Sigma = matrix(c(1,cor_cor,cor_cor,1),2,2))
  top_cor <- (top_cor-min(top_cor))/(max(top_cor)-min(top_cor))
  # remove 0s and 1s
  top_cor <- top_cor[!(top_cor[,1] == 0 | top_cor[,2] == 0 | top_cor[,1] == 1 | top_cor[,2] == 1),]
  # given these top level correlation, generate 3 base variables
  # 2 (ab,bc) of the base correlations are already determined, third (ac) can be fixed or varied systematically
  # here we first try fixing it at .5
  top_recover <- matrix(0,nrow = dim(top_cor)[1],ncol = dim(top_cor)[2])
  for(i in 1:dim(top_cor)[1]){
    ab <- top_cor[i,1]
    bc <- top_cor[i,2]
    ac <- .5
    sig <- matrix(c(1,ab,ac,
                    ab,1,bc,
                    ac,bc,1),3,3)
    # generate and scale to 0-100
    base_vars <- mvrnorm(n = 75,mu = c(0,0,0), Sigma = sig,2,2)
    base_vars <- (base_vars-min(base_vars))/(max(base_vars)-min(base_vars)) * 100
    # split and attempt recovery
    ind.all <- seq(1,75)
    half.ab <- sample(ind.all,sample(c(37,38),1),replace = F)
    half.bc <- ind.all[!(ind.all %in% half.ab)]
    top_recover[i,1] <- cor(base_vars[half.ab,1],base_vars[half.ab,2])
    top_recover[i,2] <- cor(base_vars[half.bc,2],base_vars[half.bc,3])
  }
  return(cor(top_recover[,1],top_recover[,2]))
}
# grid + simulate
set.seed(65284739)
niter <- 250
corcor_steps <- seq(.1,.9,.2)
ac_steps <- seq(.2,.8,.2)
df.split.recover <- as.data.frame(matrix(NA,nrow = niter,
                                         ncol = length(corcor_steps)*length(ac_steps)))
col.counter <- 1
for(corcor in corcor_steps){
  for(ac in ac_steps){
    recovered_corcor <- rep(0,niter)
    for(i in 1:niter){
      recovered_corcor[i] <- split_recover(corcor,ac)
    }
    df.split.recover[,col.counter] <- recovered_corcor
    col.lab <- paste('corcor_',corcor,'_ac_',ac,sep='')
    colnames(df.split.recover)[col.counter] <- col.lab
    col.counter <- col.counter + 1
  }
}
df.split.recover <- melt(df.split.recover)
newcols <- str_split_fixed(df.split.recover$variable,'_',n=4)
df.split.recover$corcor <- newcols[,2]
df.split.recover$ac <- newcols[,4]
g.split.recover <- ggplot(data = df.split.recover) + geom_histogram(aes(x = value)) + facet_grid(rows = vars(corcor), cols = vars(ac))

# two layer bootstrapping using real data -------
  # layer one: random split of states into similarity and accuracy measures
  # layer two: within the random split, bootstrap n times over participants

# write this as a function so it can be used on more than similarity/accuracy
# function takes in raw long dataframe (dfuse/dfuuu), strings indicating variables, and niters at the item and the subject levels
random.split.bootstrap <- function(rawdata,shared,vec1,vec2,steps.l1,steps.l2){
  r.super <- rep(NA, steps.l1 * steps.l2)
  for(i in 1:steps.l1){
    #generate a random assignment of the items into the two constructs: e.g. similarity and accuracy
    nitem <- length(unique(rawdata$prompt_num)) #column name hard coded
    ind.all <- seq(1,nitem)
    small.half <- floor(nitem/2) # odd number of items
    big.half <- nitem - small.half
    half.ab <- sample(ind.all,sample(c(big.half,small.half),1),replace = F)
    half.bc <- ind.all[!(ind.all %in% half.ab)]
    # calculate the two base ccorrelations for all subjects given the random split
    r.base.1 <- rep(NA, length(unique(rawdata$sub_num)))
    r.base.2 <- rep(NA, length(unique(rawdata$sub_num)))
    counter <- 1
    for(q in unique(rawdata$dyad_num)){
      dfind1 <- rawdata[which(rawdata$dyad_num == q & rawdata$ind_num == 1),]
      dfind2 <- rawdata[which(rawdata$dyad_num == q & rawdata$ind_num == 2),]
      #base correlation 1 for both sub in the dyad
      r.b1.1 <- cor(dfind1[half.ab,shared],dfind1[half.ab,vec1])
      r.b1.2 <- cor(dfind2[half.ab,shared],dfind2[half.ab,vec1])
      #base correlation 2 for both sub in the dyad
      r.b2.1 <- cor(dfind1[half.bc,shared],dfind1[half.bc,vec2])
      r.b2.2 <- cor(dfind2[half.bc,shared],dfind2[half.bc,vec2])
      r.base.1[c(counter, counter+1)] <- c(r.b1.1,r.b1.2)
      r.base.2[c(counter, counter+1)] <- c(r.b2.1,r.b2.2)
      counter <- counter + 2
    }
    zr.base.1 <- fisherz(r.base.1)
    zr.base.2 <- fisherz(r.base.2)
    # given the random split, do a small number of bootstrapping across subjects
    r.boot.sub <- rep(NA, steps.l2)
    for(j in 1:steps.l2){
      # for each iteration, randomly sample dyads with replacement
      temp.subs <- sample(1:length(zr.base.1),replace = T) #column name hard coded
      temp.base.1 <- zr.base.1[temp.subs]
      temp.base.2 <- zr.base.2[temp.subs]
      r.boot.sub[j] <- cor(temp.base.1,temp.base.2)
    }
    # print(r.boot.sub)
    r.super[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- r.boot.sub
  }
  return(r.super)
}

# bootstrapping relation between similarity and accuracy ----
steps.l1 <- 1000
steps.l2 <- 10
set.seed(29187562)
sim.acc.split.bootstrap <- random.split.bootstrap(dfuuu,
                                                  shared = '',
                                                  vec1 = '',
                                                  vec2 = '',
                                                  steps.l1 = steps.l1,
                                                  steps.l2 = steps.l2)
ci.sim.acc.split.bootstrap <- quantile(sim.acc.split.bootstrap,c(.025,.975))

##### next step: mediation models? higher sim2a -> higher egoc -> higher accuracy? -----
#function for calculating geometric mean
gm_mean = function(x, na.rm=TRUE, zero.propagate = FALSE){
  if(any(x < 0, na.rm = TRUE)){
    return(NaN)
  }
  if(zero.propagate){
    if(any(x == 0, na.rm = TRUE)){
      return(0)
    }
    exp(mean(log(x), na.rm = na.rm))
  } else {
    exp(sum(log(x[x > 0]), na.rm=na.rm) / length(x))
  }
}
# mediation 1: sim2a -> egoc -> accuracy ----
steps.l1 <- 50
steps.l2 <- 50
# initializing storage
med.s2a.a <- rep(NA, steps.l1 * steps.l2)
med.s2a.b <- rep(NA, steps.l1 * steps.l2)
med.s2a.c <- rep(NA, steps.l1 * steps.l2)
med.s2a.ab <- rep(NA, steps.l1 * steps.l2)
med.s2a.total <- rep(NA, steps.l1 * steps.l2)
med.s2a.a.p <- rep(NA, steps.l1 * steps.l2)
med.s2a.b.p <- rep(NA, steps.l1 * steps.l2)
med.s2a.c.p <- rep(NA, steps.l1 * steps.l2)
med.s2a.ab.p <- rep(NA, steps.l1 * steps.l2)
med.s2a.total.p <- rep(NA, steps.l1 * steps.l2)

rawdata <- dfuuu
# specifying the mediation model in lavaan
med <- ' # direct effect
             acc ~ c*s2a
           # mediator
             egoc ~ a*s2a
             acc ~ b*egoc
           # indirect effect (a*b)
             ab := a*b
           # total effect
             total := c + (a*b)
         '
set.seed(57482932)
for(i in 1:steps.l1){
  #generate a random assignment of the items into the two constructs: e.g. similarity and accuracy
  nitem <- length(unique(rawdata$prompt_num)) #column name hard coded
  ind.all <- seq(1,nitem)
  small.half <- floor(nitem/2) # odd number of items
  big.half <- nitem - small.half
  half.ab <- sample(ind.all,sample(c(big.half,small.half),1),replace = F)
  half.bc <- ind.all[!(ind.all %in% half.ab)]
  # calculate the two base ccorrelations for all subjects given the random split
  r.base.ps2a <- rep(NA, length(unique(rawdata$sub_num))) #base
  r.base.egoc <- rep(NA, length(unique(rawdata$sub_num)))
  r.base.acc <- rep(NA, length(unique(rawdata$sub_num)))
  counter <- 1
  for(q in unique(rawdata$dyad_num)){
    dfind1 <- rawdata[which(rawdata$dyad_num == q & rawdata$ind_num == 1),]
    dfind2 <- rawdata[which(rawdata$dyad_num == q & rawdata$ind_num == 2),]
    dfrest <- rawdata[which(rawdata$dyad_num != q),]
    #base correlation accuracy for both sub in the dyad
    r.bacc.1 <- cor(dfind1[half.ab,'friend_self'],dfind1[half.ab,'self_target']) # var a and c in the mediation will share base variable indices
    r.bacc.2 <- cor(dfind2[half.ab,'friend_self'],dfind2[half.ab,'self_target'])
    # base correlation similarity to group
    r.bs2a.1 <- cor(dfind1[half.ab,'self_self'], dfind1[half.ab,'ptonavg.excludedyad'])
    r.bs2a.2 <- cor(dfind2[half.ab,'self_self'], dfind2[half.ab,'ptonavg.excludedyad'])
    # base correlation egocentrism
    r.begoc.1 <- cor(dfind1[half.bc,'self_self'], dfind1[half.bc,'self_target'])
    r.begoc.2 <- cor(dfind2[half.bc,'self_self'], dfind2[half.bc,'self_target'])
    # tally
    r.base.ps2a[c(counter, counter+1)] <- c(r.bs2a.1,r.bs2a.2)
    r.base.acc[c(counter, counter+1)] <- c(r.bacc.1,r.bacc.2)
    r.base.egoc[c(counter, counter+1)] <- c(r.begoc.1,r.begoc.2)
    counter <- counter + 2
  }
  zr.base.ps2a <- fisherz(r.base.ps2a)
  zr.base.acc <- fisherz(r.base.acc)
  zr.base.egoc <- fisherz(r.base.egoc)
  # given the random split, do a small number of bootstrapping across subjects
  t.a <- rep(NA, steps.l2)
  t.b <- rep(NA, steps.l2)
  t.c <- rep(NA, steps.l2)
  t.ab <- rep(NA, steps.l2)
  t.total <- rep(NA, steps.l2)
  t.a.p <- rep(NA, steps.l2)
  t.b.p <- rep(NA, steps.l2)
  t.c.p <- rep(NA, steps.l2)
  t.ab.p <- rep(NA, steps.l2)
  t.total.p <- rep(NA, steps.l2)
  for(j in 1:steps.l2){
    # for each iteration, randomly sample dyads with replacement
    temp.subs <- sample(1:length(zr.base.ps2a),replace = T) #column name hard coded
    temp.base.ps2a <- scale(zr.base.ps2a[temp.subs])
    temp.base.acc <- scale(zr.base.acc[temp.subs])
    temp.base.egoc <- scale(zr.base.egoc[temp.subs])
    dt.med <- data.frame(s2a = temp.base.ps2a, acc = temp.base.acc, egoc = temp.base.egoc)
    fit.med <- sem(med, data = dt.med)
    t.a[j] <- coef(fit.med,'user')['a']
    t.b[j] <- coef(fit.med,'user')['b']
    t.c[j] <- coef(fit.med,'user')['c']
    t.ab[j] <- coef(fit.med,'user')['ab']
    t.total[j]  <- coef(fit.med,'user')['total']
    pe <- lavaan::parameterestimates(fit.med)
    t.a.p[j] <- pe$pvalue[pe$label == 'a']
    t.b.p[j] <- pe$pvalue[pe$label == 'b']
    t.c.p[j] <- pe$pvalue[pe$label == 'c']
    t.ab.p[j] <- pe$pvalue[pe$label == 'ab']
    t.total.p[j] <- pe$pvalue[pe$label == 'total']
  }
  print(i)
  med.s2a.a[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- t.a
  med.s2a.b[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- t.b
  med.s2a.c[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- t.c
  med.s2a.ab[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- t.ab
  med.s2a.total[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- t.total
  med.s2a.a.p[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- t.a.p
  med.s2a.b.p[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- t.b.p
  med.s2a.c.p[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- t.c.p
  med.s2a.ab.p[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- t.ab.p
  med.s2a.total.p[((i-1) * steps.l2 + 1):((i-1) * steps.l2 + j)] <- t.total.p
}

#SAM goodness, estimates of interest are random effect correlations.
goodstuff <- lmer(data = dfuuu,
                  self_target ~ friend_self + ptonavg.excludedyad + self_self +
                    (1+friend_self + ptonavg.excludedyad + self_self|dyad_num/sub_num)+
                    (1|prompt_num))


do_summary_stratified_mean <- function (x, target_var, strata_var, strata_size_var, klab){

	# calculates stratified mean statistics
	# Nuno Prista, SLU Aqua, Sweden
	# Developed @ KustMonitoring Review 2019

	#x is a dataframe values with
		# target values in target_var variable
		# a strata_var variable
		# a strata_size variable

	# 2019-05-06: added clow_mean and chigh_mean (confidence intervals)
	# 2019-05-11: adapted to presence of missing values
	# 2019-05-11: adapted argument klab to configure strata according to indicator (email jens 09-05-2019)
	# 2019-05-11: added n_strata sampled to output - in case only disturbed stations are sampled a strata may end up not being sampled (overall mean will be biased)
	# 2019-05-15: correction of st_var_mean
	# 2019-05-15: added stratum ci (based on t distribution)

	require(data.table)

	if(!is.data.table(x) & !is.data.frame(x)) stop ("x must be data.frame or data.table")
	if(!is.data.table(x)) x<-data.table(x)

# ==========================
# Stratified (st) results
# ==========================

	values<-parse(text=target_var)
	stratum<-parse(text=strata_var)
	size<-parse(text=strata_size_var)

	if(klab==TRUE)
		{
		if (target_var %in% c("CyprinidsB","CyprinidsN","PerchB","PerchN","PikeN","PiscivoresN"))
			{
			strata_to_keep <- c("0-3m", "3-6m", "6-10m")
			} else strata_to_keep <- c("0-3m", "3-6m", "6-10m", "10-20m")
		x<-droplevels(x[eval(stratum) %in% strata_to_keep,])
		}	else strata_to_keep<-unique(x[,eval(stratum)])
	# stratified variance
		# strata summary
			b1<-x[,list(stratum_size=eval(size)[1], variable = target_var, n=sum(!is.na(eval(values))), mean_x = mean(eval(values), na.rm=T), var_x = var(eval(values), na.rm=T), var_mean_x = var(eval(values), na.rm=T)/sum(!is.na(eval(values))), se_mean_x = sd(eval(values), na.rm=T)/sqrt(sum(!is.na(eval(values))))), eval(stratum)][order(eval(stratum))];
			b1[, c(.SD, rse_mean_x = round(se_mean_x/mean_x*100,1),clow_mean=mean_x-qt(0.975,n)*se_mean_x, chigh_mean=mean_x+qt(0.975,n)*se_mean_x),stratum]
		# stratified mean
			st_mean<-sum(b1$mean_x*b1$stratum_size/sum(b1$stratum_size))
		# stratified variance of the mean
			#st_var_mean<-sum(b1$var_mean_x*(b1$stratum_size/sum(b1$stratum_size))^2)
			st_var_mean<-sum( 1*( ( b1$stratum_size/sum(b1$stratum_size) )^2 )*(b1$var_mean_x) ) # according to Lohr (2009), pg 79 [assumes f=1]
		# stratified se of the mean
			st_se_mean<-sqrt(st_var_mean)
		# stratified cv/rse of the mean
			st_rse_mean<-round(st_se_mean/st_mean*100,1)

	list(pop_res = data.frame(type="stratified", variable = target_var, expect_strata = paste(strata_to_keep, collapse=","), samp_strata = paste(b1$stratum, collapse=","), n_tot = sum(b1$n), n_strata = paste(b1$n,collapse=","), mean = st_mean, var_mean = st_var_mean, se_mean = st_se_mean, rse_mean = st_rse_mean, clow_mean=st_mean-2*st_se_mean, chigh_mean=st_mean+2*st_se_mean), stratum_res = b1, type="stratified")

}


## plot kinship coefficients

args<-commandArgs(TRUE)

setwd(args[1])

dat<-read.table("king.kin0", header = TRUE, stringsAsFactors = FALSE)
outPred<-read.csv("PredictedPopulations.csv", stringsAsFactors = FALSE)

pdf("ScatterplotKinshipCoefficients.pdf")
plot(dat$IBS0, dat$Kinship, pch = 16,
  col = "blue", main = "KING-Robust (Default)",
  xlab="Proportion of Zero IBS", ylab = "Estimated Kinship Coefficient", ylim = c(0,0.4))
  abline(h = 0.3536, col = "black", lty = 3)
abline(h = 0.1768, col = "black", lty = 3)
abline(h = 0.0884, col = "black", lty = 3)
abline(h = 0.0442, col = "black", lty = 3)
abline(h = 0.0221, col = "black", lty = 3)
  dev.off()

## look for samples with higher than average IBD statistics
sampleIDs<-unique(c(dat$FID1, dat$FID2))
mean.kin<-rep(NA, length(sampleIDs))
names(mean.kin)<-sampleIDs
for(each in sampleIDs){
	values<-c(dat$Kinship[which(dat$FID1 == each | dat$FID2 == each)])
	mean.kin[each]<-mean(values, na.rm = TRUE)
}
mean.ibs<-rep(NA, length(sampleIDs))
names(mean.ibs)<-sampleIDs
for(each in sampleIDs){
	values<-c(dat$IBS0[which(dat$FID1 == each | dat$FID2 == each)])
	mean.ibs[each]<-mean(values, na.rm = TRUE)
}

outPred<-outPred[match(names(mean.ibs), outPred$V1),]

pdf("HistMeanKinshipCoefficients.pdf")
par(mfrow = c(1,2))
hist(mean.kin, breaks = 20, xlab = "Mean kinship coefficient", main = "")
mu<-mean(mean.kin)
sigma<-sd(mean.kin)
abline(v = mu, col = "red", lty = 2)
for(i in 1:3){
	abline(v = mu+i*sigma, col = "red")
	abline(v = mu-i*sigma, col = "red")
}
hist(mean.ibs, breaks = 20, xlab = "Mean IBS coefficient", main = "")
mu<-mean(mean.ibs)
sigma<-sd(mean.ibs)
abline(v = mu, col = "red", lty = 2)
for(i in 1:3){
	abline(v = mu+i*sigma, col = "red")
	abline(v = mu-i*sigma, col = "red")
}

## look for joint outliers
## colour by predicted super population

par(mfrow = c(1,1))
plot(mean.ibs, mean.kin, pch = 16, col = rainbow(5)[as.factor(outPred$predPop)])
mu<-mean(mean.ibs)
sigma<-sd(mean.ibs)
abline(v = mu, col = "red", lty = 2)
for(i in 1:3){
	abline(v = mu+i*sigma, col = "red")
	abline(v = mu-i*sigma, col = "red")
}
mu<-mean(mean.kin)
sigma<-sd(mean.kin)
abline(h = mu, col = "red", lty = 2)
for(i in 1:3){
	abline(h = mu+i*sigma, col = "red")
	abline(h = mu-i*sigma, col = "red")
}
dev.off()


model_ptq <- function (tTWindowForPTQ = 70.0,
         kl = 0.45,
         listTTShootWindowForPTQ_t1 = c(0.0),
         listPARTTWindowForPTQ_t1 = c(0.0),
         listGAITTWindowForPTQ = c(0.0, 5.2),
         pAR = 0.0,
         deltaTT = 0.0){
    #'- Name: PTQ -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Phyllochron Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA Montpellier
    #'            * Abstract: Calculate Photothermal Quaotient
    #'- inputs:
    #'            * name: tTWindowForPTQ
    #'                          ** description : Thermal time window in which averages are computed
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 70000.0
    #'                          ** default : 70.0
    #'                          ** unit : °C d
    #'                          ** uri : some url
    #'                          ** inputtype : parameter
    #'            * name: kl
    #'                          ** description : Exctinction Coefficient
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 50.0
    #'                          ** default : 0.45
    #'                          ** unit :
    #'                          ** uri : some url
    #'                          ** inputtype : parameter
    #'            * name: listTTShootWindowForPTQ_t1
    #'                          ** description : List of Daily Shoot thermal time during TTWindowForPTQ thermal time period
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** default : [0.0]
    #'                          ** unit : °C d
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'            * name: listPARTTWindowForPTQ_t1
    #'                          ** description : List of Daily PAR during TTWindowForPTQ thermal time period
    #'                          ** variablecategory : state
    #'                          ** inputtype : variable
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** default : [0.0]
    #'                          ** unit : MJ m2 d
    #'                          ** uri : some url
    #'            * name: listGAITTWindowForPTQ
    #'                          ** description : List of daily GAI over TTWindowForPTQ thermal time period
    #'                          ** variablecategory : state
    #'                          ** inputtype : variable
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** default : [0.0, 5.2]
    #'                          ** unit : m2 m-2
    #'                          ** uri : some url
    #'            * name: pAR
    #'                          ** description : Daily Photosyntetically Active Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 10000.0
    #'                          ** unit : MJ m² d
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'            * name: deltaTT
    #'                          ** description : daily delta TT
    #'                          ** variablecategory : auxiliary
    #'                          ** inputtype : variable
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** default : 0.0
    #'                          ** unit : °C d
    #'                          ** uri : some url
    #'- outputs:
    #'            * name: listPARTTWindowForPTQ
    #'                          ** description :  List of Daily PAR during TTWindowForPTQ thermal time period
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : MJ m2 d
    #'            * name: listTTShootWindowForPTQ
    #'                          ** description : List of Daily Shoot thermal time during TTWindowForPTQ thermal time period
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : °C d
    #'            * name: ptq
    #'                          ** description : Photothermal Quotient
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : MJ °C-1 d m-2)
    listPARTTWindowForPTQ <- vector()
    listTTShootWindowForPTQ <- vector()
    TTList <- vector()
    PARList <- vector()
    parInt <- 0.0
    for( i in seq(0, length(listTTShootWindowForPTQ_t1)-1, 1)){
        TTList <- c(TTList, listTTShootWindowForPTQ_t1[i+1])
        PARList <- c(PARList, listPARTTWindowForPTQ_t1[i+1])
    }
    TTList <- c(TTList, deltaTT)
    PARList <- c(PARList, pAR)
    SumTT <- sum(TTList)
    count <- 0
    while( SumTT > tTWindowForPTQ){
        SumTT <- SumTT - TTList[count+1]
        count <- count + 1}
    for( i in seq(count, length(TTList)-1, 1)){
        listTTShootWindowForPTQ <- c(listTTShootWindowForPTQ, TTList[i+1])
        listPARTTWindowForPTQ <- c(listPARTTWindowForPTQ, PARList[i+1])
    }
    for( i in seq(0, length(listTTShootWindowForPTQ)-1, 1)){
        parInt <- parInt + (listPARTTWindowForPTQ[i+1] * (1 - exp(-kl * listGAITTWindowForPTQ[i+1])))
    }
    TTShoot <- sum(listTTShootWindowForPTQ)
    ptq <- parInt / TTShoot
    return (list ("listPARTTWindowForPTQ" = listPARTTWindowForPTQ,"listTTShootWindowForPTQ" = listTTShootWindowForPTQ,"ptq" = ptq))
}


 ZGTCON Example Program Results

 Estimate of condition number =   1.84E+02


fibtests <- read.csv('./history/benchmark_13nov2017_n4050i3.csv')

plot(
  x=fibtests$n_arg,
  y=fibtests$recursive_seconds,
  type='o',
  col='red',
  main='Benchmarking de algoritmos Fibonacci',
  xlab='Valor do argumento n da função',
  ylab='Segundos levados executar 10^6 de vezes',
  ylim=c(0, 10)
)

lines(
  x=fibtests$n_arg,
  y=fibtests$iterative_seconds,
  type='o',
  col='green'
)

lines(
  x=fibtests$n_arg,
  y=fibtests$explicit_seconds,
  type='o',
  col='blue'
)

legend(
  x=30,
  y=10,
  c('Recursivo', 'Iterativo', 'Fechado'),
  fill=c('red', 'green', 'blue')
)


observation = read.csv('./observations.csv', header = TRUE, sep=",")
observation2 = read.csv('./rand-observations.csv', header = TRUE, sep=",")
observation[1,2]
observation[,2]
observation[1,]
observation = round(observation, digits=4)
observation2 = round(observation2, digits=4)
wilcox.test(observation2[,1], observation2[,2], alternative="two.sided", paired = FALSE, conf.level = 0.95)
wilcox.test(observation[,1], observation[,2], alternative="two.sided", paired = TRUE, conf.level = 0.95)
list_observations = list(observation[,1], observation[,2], observation2[,1], observation2[,2])
kruskal.test(list_observations)
combined_observations <- data.frame(observation, observation2)
matrix_observations = data.matrix(combined_observations)
friedman.test(matrix_observations)

install.packages("PMCMR")
library(PMCMR)

posthoc.kruskal.dunn.test(list_observations, p.adjust.method="holm")
posthoc.friedman.nemenyi.test(matrix_observations)

#may want to install PLUS


library(shiny)
library(matrixcalc)
library(plotly)

ui <- fluidPage(
  titlePanel("SVM demo"),
  sidebarLayout(
    sidebarPanel(
      h3("The first class specs"),
      h6("Expected value, μ"),
      fluidRow(
        column(6,
               numericInput("mu11", value = 1.825, label = "μ1")
        ),
        column(6,
               numericInput("mu12", value = 1.825, label = "μ2")
        )
      ),
      h6("Covariance matrix, Σ"),
      fluidRow(
        column(6,
               numericInput("E11", value = 1.5, label = "Σ (1,1)")
        ),
        column(6,
               numericInput("E12", value = 0.25, label = "Σ (1,2)")
        )
      ),
      fluidRow(
        column(6,
               numericInput("E13", value = 0.25, label = "Σ (2,1)")
        ),
        column(6,
               numericInput("E14", value = 1.5, label = "Σ (2,2)")
        )
      ),
      fluidRow(
        column(12,
               numericInput("count1", value = 50, label = "Samples count")
        )
      ),
      textOutput("err"),

      h3("The second class specs"),
      h6("Expected value, μ"),
      fluidRow(
        column(6,
               numericInput("mu21", value = 4.57, label = "μ1")
        ),
        column(6,
               numericInput("mu22", value = 4.57, label = "μ2")
        )
      ),
      h6("Covariance matrix, Σ"),
      fluidRow(
        column(6,
               numericInput("E21", value = 2.36, label = "Σ (1,1)")
        ),
        column(6,
               numericInput("E22", value = 0.11, label = "Σ (1,2)")
        )
      ),
      fluidRow(
        column(6,
               numericInput("E23", value = 0.11, label = "Σ (2,1)")
        ),
        column(6,
               numericInput("E24", value = 2.36, label = "Σ (2,2)")
        )
      ),
      fluidRow(
        column(12,
               numericInput("count2", value = 50, label = "Samples count")
        )
      ),
      fluidRow(
        column(12,
               numericInput("C", value = 1, label = "C parameter")
        )
      )
    ),
    mainPanel(
      fluidRow(
        column(6, plotOutput(outputId = "p1")),
        column(6, plotOutput(outputId = "p2"))
      )
    )
  )
)


#' Twinkle twinkle little start
#'
#' How I wonder what you are... Creates a nice plot with
#'
#' @param n Integer scalar. Number of stars to generate.
#' @param cols Vector of colors. Passed to [grDevices::colorRamp].
#' @param tail Integer scalar. Length of the tails.
#' @param stepsize Numeric scalar.
#' @param deg_from,deg_to Numeric scalar. A value in radians (0 to 2`pi`).
#' @param col_decay_rate Integer scalar. The higher the value the longer the light
#' of the star lasts.
#' @param size_decay_rate Numeric scalar. Multiplied by the size of the star at each step
#' (change of size).
#' @param stargen A function. The star generator. Should receive an integer `n`,
#' number of stars, and return a vector of that length with values greater than 0.
#' @param xlim,ylim Limits of the plotting device. This works together with `stargen`.
#' @param bg Character scalar. Passed to [graphics::par].
#'
#' @return NULL (invisible)
#' @export
#' @author Mateo and George G. Vega
#'
#' @examples
#'
#' set.seed(12)
#' twinkle(100)
#' @importFrom grDevices colorRamp rgb
#' @import graphics
#' @importFrom stats runif rbeta
#' @aliases littlestar estrellita
twinkle <- function(
  n          = 500,
  cols       = c("white","yellow", "gold"),
  tail       = 100,
  stepsize   = .002,
  deg_from   = -pi/8,
  deg_to     = pi/4,
  col_decay_rate = 2,
  size_decay_rate = .99,
  stargen   = function(n) {
    stats::rbeta(n, 2, 5)/10
  },
  xlim       = c(-2, 2),
  ylim       = c(-2, 2),
  bg         = "#041836FF"
) {

  # Setting the device
  oldpar <- graphics::par(no.readonly = TRUE)
  graphics::par(mai = rep(0, 4), bg=bg)
  on.exit(graphics::par(oldpar))
  graphics::plot.new()
  graphics::plot.window(c(-1, 1), c(-1, 1))

  # Generating the stars
  dat <- stargen(n)
  dat <- cbind(dat, dat/2, dat, dat/2, dat, dat/2, dat, dat/2, dat, dat/2)

  # Generating colors
  cols <- grDevices::colorRamp(cols, alpha = TRUE)(stats::runif(n))
  x     <- stats::runif(n, xlim[1], xlim[2])
  y     <- stats::runif(n, ylim[1], ylim[2])
  theta <- stats::runif(n, 0, 2*pi)

  for (i in col_decay_rate:(tail + col_decay_rate)) {

    # Updating color
    colss <- grDevices::rgb(
      cols[,1], cols[,2], cols[,3],
      alpha = cols[,4]/i*col_decay_rate,
      maxColorValue = 255
      )

    theta <- theta + stats::runif(n, deg_from, deg_to)/i
    x <- x + cos(theta)*stepsize
    y <- y + sin(theta)*stepsize

    graphics::symbols(x, y,
            star   = (dat <- dat*size_decay_rate),
            fg     = colss,
            bg     = colss,
            inches = FALSE,
            add    = TRUE
    )
  }

  invisible(NULL)
}


euclidean <- function(a, b) sqrt(sum((a - b) ^ 2))

rectKernel <- function(dist) 0.5 * (abs(dist) <= 1)
trKernel <- function(dist) (1 - abs(dist)) * (abs(dist) <= 1)
epKernel = function(dist) (3 / 4) * (1 - dist ^ 2) * (abs(dist) <= 1)
gaussKernel = function(dist) dnorm(dist) * (abs(dist) <= 1)

classify <- function (dset, point, labels, potentials, h, dist = euclidean, kernel = trKernel) {
  #cat(length(labels), dim(dset))
  distances <- apply(dset, 1, dist, point)
  #print(length(distances))

  weights <- potentials * kernel(distances / h)
  #print(length(weights))
  #print(potentials)
  names(weights) <- labels

  # print(potentials)
  # print(kernel(distances / h))
  # print(weights)

  classes <- unique(labels)
  classScores <- sapply(classes, function(class, w) sum(w[names(w) == class]), weights)
  classScores["undefined"] <- 0.000001

  #print(classScores)

  # if (length(unique(classScores)) == 1) {
  #   return(classes[sample(1:length(classes), 1)])
  # }

  #cat("CL RES", classes[which.max(classScores)], classScores, "\n")
  return (names(which.max(classScores)))
}

generateMaps <- function() {
  xs <- seq(from = 0.5, to = 7.5, by = 0.1)
  ys <- seq(from = -1, to = 3.5, by = 0.1)

  colors <- c("setosa" = "blue", "virginica" = "red", "versicolor" = "green", "undefined" = "grey")

  pp <- matrix(c(
    c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
    c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
    c(0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
    c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0)
  ), nrow = 4)
  # print(pp)
  kernels <- c("rectangular" = rectKernel, "triangular" = trKernel, "epachinnikov's" = epKernel, "gaussian" = gaussKernel)

  # par(mfrow = c(length(kernels) / 2, 2), pty="s", mar=c(1,1,1,1))

  index <- 1
  for (kernelName in names(kernels)) {
    kernel <- kernels[[kernelName]]
    png(sprintf("plot-%03d.png", index), width = 1024, height = 700, unit = "px", pointsize = 20)
    cat("Kernel:", kernelName, index, "of", length(kernels), "\n")
    plot(iris[, 3:4], col = colors[paste(iris$Species)], pch=16, asp=1)
    title(main = paste("Kernel:", kernelName))

    h <- rep(1, 150)
    #print(pp)
    p <- pp[index,]
    #potentials <- potentials(Util.petals, Util.classes, h = h, 5, kernel)

    all <- length(xs) * length(ys)
    progress = 1
    for (i in xs) {
      for (j in ys) {
        cat("\rProcessing point", progress, "of", all)
        progress <- progress + 1
        result <- classify(iris[3:4], c(i, j), paste(iris$Species), p, h, kernel = kernel)
        #print(paste(i, j, result))
        points(i, j, col = colors[result], pch = 21)
      }
    }
    cat("\rDone.                      \n")
    dev.off()
    index <- index + 1
  }
}

generateMaps()

3 - Potential functions method/maps-generation.r


cleanup()
OPTG
ref<-Read.reference.points()

    par(mfcol=c(4,3))
    par(mar=c(2,2,2,2))  # c(bottom, left, top, right)

    OPTG@SSBpenalty
for (s in(first.VPA:nsp)) {
  SSB<-seq(0,ref[s,'Bpa']*1.5,100)
  L50<-OPTG@SSBpenalty['SSB50',s-first.VPA+1]
  L75<-OPTG@SSBpenalty['SSB75',s-first.VPA+1]
  factor<-OPTG@SSBpenalty['factor',s-first.VPA+1]
  S1<-L50*log(3.0)/(L75-L50)

  cat(sp.names[s],"\tS1: ",S1," L50%:",round(L50)," L75%:",round(L75),'\n')
  penalty<- factor*(1-(1/(1+exp(S1-S1/L50*SSB))))
  SSB<-SSB/1000
  plot(SSB,penalty,main=sp.names[s])
  abline(v=L50/1000,lty=2,col='red')
  abline(v=ref[s,'Bpa']/1000,lty=2,col='blue')
  abline(v=ref[s,'Blim']/1000,lty=2,col='blue')
}

X11()
  par(mfcol=c(4,3))
    par(mar=c(2,2,2,2))  # c(bottom, left, top, right)

for (s in(first.VPA:nsp)) {
  SSB<-seq(0,ref[s,'Bpa']*1.5,100)/1000
  L50<-OPTG@SSB50['init',s-first.VPA+1]
  S1<-OPTG@S1['lower',s-first.VPA+1]

  cat(sp.names[s],"\tS1: ",S1," L50%:",round(L50),'\n')
  sel<-(1/(1+exp(S1-S1/L50*SSB)))
  plot(SSB,sel,main=sp.names[s],ylim=c(0,1))
  abline(v=L50,lty=2,col='red')
  abline(v=ref[s,'Bpa']/1000,lty=2,col='blue')
  abline(v=ref[s,'Blim']/1000,lty=2,col='blue')

  S1<-OPTG@S1['higher',s-first.VPA+1]
  cat(sp.names[s],"\tS1: ",S1," L50%:",round(L50),'\n')
  sel<-(1/(1+exp(S1-S1/L50*SSB)))
  points(SSB,sel,main=sp.names[s],col='blue')

}


# Load necessary libraries

year <- c(2018:2058)

data <- data.frame(year)
data$lngdppc <- 4.5 + .02*(year-2018)
data$sinv  <- .2
data$ky    <- 3.5
data$phil  <- .75

fig <- plot_ly(data, x = ~year, y = ~lngdppc, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP per capita',range=c(4,5.5)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-lngdppc")

fig <- plot_ly(data, x = ~year, y = ~sinv, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP capital formation/GDP', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Ratio of I/Y',range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-sinv")

fig <- plot_ly(data, x = ~year, y = ~phil, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP labor share of costs', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Ratio of W/(W+RK)',range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-phil")

fig <- plot_ly(data, x = ~year, y = ~ky, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP capital/output ratio', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Ratio of K/Y',range=c(1,5)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-ky")

year <- c(2018:2058)
dA <- data.frame(year)
noise <- rnorm(41)
dA$lngdppc <- 4.5 + .02*(year-2018) + .02*noise
dA$sinv  <- .8 + .03*noise - .01*(year-2018)
dA$ky    <- 5 + .1*noise - .05*(year-2018)
dA$phil  <- .6 + .03*noise
dA$id <- "A"

dB <- data.frame(year)
noise <- rnorm(41)
dB$lngdppc <- 5.3 + .0005*(year-2018)+ .02*noise
dB$sinv  <- .2 + .02*noise
dB$ky    <- 2 + .1*noise + .1*(year-2018)
dB$phil  <- .75 + .03*noise
dB$id <- "B"

dC <- data.frame(year)
noise <- rnorm(41)
dC$lngdppc <- 4 + .04*(year-2018)+ .02*noise
dC$sinv  <- .2 + .03*noise + .01*(year-2018)
dC$ky    <- 2.5 + .1*noise
dC$phil  <- .8 + .03*noise
dC$id <- "C"

dall <- rbind(dA,dB)
dall <- rbind(dall,dC)

fig <- plot_ly(dall, x = ~year, y = ~lngdppc, linetype = ~id, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "test-bgp-lny")

fig <- plot_ly(dall, x = ~year, y = ~sinv, linetype = ~id, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Gross capital formation share', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Gross capital formation share of GDP', range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "test-bgp-sinv")

fig <- plot_ly(dall, x = ~year, y = ~ky, linetype = ~id, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital/output ratio', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Capital/output ratio',range=c(1,6)),
              hovermode="x unified")
api_create(fig, filename = "test-bgp-ky")

fig <- plot_ly(dall, x = ~year, y = ~phil, linetype = ~id, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Labor share of costs', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Labor share of costs',range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "test-bgp-phil")

year <- c(0:40)
dA <- data.frame(year)
dA$f <- exp(-.1*dA$year)-exp(-.1*(dA$year-1))
dA$lngdppc <- 4.5 + .02*year
dA$g <- .02
dA$id <- "A"
dA$gid <- "C"

dB <- data.frame(year)
dB$f <- exp(-.1*dB$year)-exp(-.1*(dB$year-1))
dB$lngdppc <- 4.5*exp(-.1*dB$year) + 5*(1-exp(-.1*dB$year)) + .02*year
dB$g <- 4.5*dB$f + 5*(-1*dB$f) + .02
dB$id <- "B"
dB$gid <- "B"

dC <- data.frame(year)
dC$f <- exp(-.1*dC$year)-exp(-.1*(dC$year-1))
dC$lngdppc <- 4.5*exp(-.1*dC$year) + 4*(1-exp(-.1*dC$year)) + .02*year
dC$g <- 4.5*dC$f + 4*(-1*dC$f) + .02
dC$id <- "C"
dC$gid <- "D"

dD <- data.frame(year)
dD$f <- exp(-.1*dD$year)-exp(-.1*(dD$year-1))
dD$lngdppc <- 5.5*exp(-.1*dD$year) + 4.5*(1-exp(-.1*dD$year)) + .02*year
dD$g <- 5.5*dD$f + 4.5*(-1*dD$f) + .02
dD$id <- "D"
dD$gid <- "E"

dE <- data.frame(year)
dE$f <- exp(-.1*dE$year)-exp(-.1*(dE$year-1))
dE$lngdppc <- 3.5*exp(-.1*dE$year) + 4.5*(1-exp(-.1*dE$year)) + .02*year
dE$g <- 3.5*dE$f + 4.5*(-1*dE$f) + .02
dE$id <- "E"
dE$gid <- "A"

dall <- rbind(dA,dB)
dall <- rbind(dall,dC)
dall <- rbind(dall,dD)
dall <- rbind(dall,dE)

fig <- plot_ly(dall, x = ~year, y = ~lngdppc, linetype = ~id, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "test-bgp-choices")

dall <- rbind(dA,dE)
dall <- rbind(dall,dD)
fig <- plot_ly(dall, x = ~year, y = ~g, linetype = ~gid, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'Growth rate of GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Growth rate of GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "test-gy-choices")

year <- c(0:200)
dA <- data.frame(year)
dA$R <- 2*(1+.02)^year
dA$A <- ((1-.02)^year)*1*dA$R + (1- (1-.02)^year)*(.01/.02)*dA$R
dA$lnA <- log(dA$A)
dA$id <- "A"

dB <- data.frame(year)
dB$R <- 2*(1+.01)^year
dB$A <- ((1-.01)^year)*1*dB$R + (1- (1-.01)^year)*(.01/.01)*dB$R
dB$lnA <- log(dB$A)
dB$id <- "B"
dall <- rbind(dA,dB)

dC <- data.frame(year)
dC$R <- 2*(1+.001)^year
dC$A <- ((1-.001)^year)*1*dC$R + (1- (1-.001)^year)*(.01/.001)*dC$R
dC$lnA <- log(dC$A)
dC$id <- "C"
dall <- rbind(dall,dC)

dD <- data.frame(year)
dD$R <- 2*(1+.01)^year
dD$A <- ((1-.01)^year)*1*dD$R + (1- (1-.01)^year)*(.02/.01)*dD$R
dD$lnA <- log(dD$A)
dD$id <- "D"
dall <- rbind(dall,dD)

dE <- data.frame(year)
dE$R <- 2*(1+.01)^year
dE$A <- ((1-.01)^year)*1*dE$R + (1- (1-.01)^year)*(.005/.01)*dE$R
dE$lnA <- log(dE$A)
dE$id <- "E"
dall <- rbind(dall,dE)

fig <- plot_ly(dall, x = ~year, y = ~lnA, linetype = ~id, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'log Productivity (A)', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of productivity (A)'),
              hovermode="x unified")
api_create(fig, filename = "test-logA-choices")

year <- c(0:50)
dA <- data.frame(year)
dA$R <- 12*(1+.01)^year
dA$lnR <- log(dA$R)
dA$id <- "A"

dB <- data.frame(year)
dB$R <- 8*(1-.01)^year
dB$lnR <- log(dB$R)
dB$id <- "B"
dall <- rbind(dA,dB)

dC <- data.frame(year)
dC$R <- 20*(1-.03)^year
dC$lnR <- log(dC$R)
dC$id <- "C"
dall <- rbind(dall,dC)

fig <- plot_ly(dall, x = ~year, y = ~lnR, linetype = ~id, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'Resources per capita (X/L)', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of resources per capita (X/L)'),
              hovermode="x unified")
api_create(fig, filename = "test-logXL-choices")


# Selecting and transforming data

# A. Select
# 1. Select columns
# Glimpse the counties table
glimpse(counties)

counties %>%
  # Select state, county, population, and industry-related columns (the : allows for a range of columns to be selected that exist between the first:end columns)
  select(state, county, population, professional:production) %>%
  # Arrange service in descending order
  arrange(desc(service))

# 2. Select helpers
# ?select_helpers : code input to console provides overview
# contains(): include the column names that contain the word being referenced
# starts_with(): include the prefix for the column name
# ends_with(): include the suffix for the column name
# last_col(): returns the last column from the table

counties %>%
  # Select the state, county, population, and those ending with "work"
  select(state, county, population, ends_with("work")) %>%
  # Filter for counties that have at least 50% of people engaged in public work
  filter(public_work >= 50)

# 3. Exclude column from selection. Code will exclude column from the selection and return all other columns
counties %>%
  select(-census_id)

# B. Rename verb
# 1. Rename a column after count()
counties %>%
  # Count the number of counties in each state
  count(state) %>%
  # Rename the n column to num_counties. The column n is created by default when using the count() verb
  rename(num_counties = n)

# 2. Rename methods
# a. Rename within the select method
counties %>%
  # Select state, county, and poverty as poverty_rate
  select(state, county, poverty_rate = poverty)
# b. Rename within the rename method
counties %>%
  # Select state, county, and poverty as poverty_rate
  select(state, county, poverty) %>%
  rename(poverty_rate = poverty)

# C. Transmute verb
# Combines the select() and mutate() verbs

# 1. Using transmute
counties %>%
  # Keep the state, county, and populations columns, and add a density column
  transmute(state, county, population, density = population / land_area) %>%
  # Filter for counties with a population greater than one million
  filter(population > 1000000) %>%
  # Sort density in ascending order
  arrange(density)

# D. All the verbs together. Choosing the most appropriate
# Change the name of the unemployment column
counties %>%
  rename(unemployment_rate = unemployment)

# Keep the state and county columns, and the columns containing poverty
counties %>%
  select(state, county, contains("poverty"))

# Calculate the fraction_women column without dropping the other columns
counties %>%
  mutate(fraction_women = women / population)

# Keep only the state, county, and employment_rate columns
counties %>%
  transmute(state, county, employment_rate = employed / population)


# Assignment Requirements:
# 1) Read in a csv formatted file regrex1.csv. | DONE
# 2) Output a scatter plot | DONE
# 3) Add a button to model the data (linear model) | DONE
# 4) Output a plot of the linear model overlayed on the original data. | DONE
# 5) Output the slope, intercept, and correlation coefficient | DONE
# 6) Push the functional app to a Binder git repo.
# 7) Submit the git URLs for Shiny App.

# Additional Challenges (not graded)
# 1) create a button to export the plots | DONE
# 2) incorporate Plotly interactive graphs
# 3) Provide interactive controls to change the parameters of the linear model

# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
#    http://shiny.rstudio.com/
#

library(shiny)
library(ggplot2)

# Define UI for application that draws a histogram
ui <- fluidPage(

    # Application title
    titlePanel("Group 5 | Regrex1 Data | Shiny Dashboard"),

    # Sidebar with a slider input for number of bins
    sidebarLayout(
        sidebarPanel(

            # Input: File selecting option
            fileInput("file1", "Choose CSV File",
                      multiple = FALSE,
                      accept = c("text/csv",
                                 "text/comma-separated-values,text/plain",
                                 ".csv")),

            # Input: Checkbox if file has header
            checkboxInput("header", "Header", TRUE),

            # Input: Select separator
            radioButtons("sep", "Separator",
                         choices = c(Comma = ",",
                                     Semicolon = ";",
                                     Tab = "\t"),
                         selected = ","),

            # Input: Select quotes
            radioButtons("quote", "Quote",
                         choices = c(None = "",
                                     "Double Quote" = '"',
                                     "Single Quote" = "'"),
                         selected = '"'),

            # Input: Select number of rows to display
            radioButtons("disp", "Display",
                         choices = c(Head = "head",
                                     All = "all"),
                         selected = "head"),
            tags$hr(), # Horizontal line

            # Adding linear model button and download plot button
            actionButton("lmPlot", "Linear Model"),
            downloadButton("downloadPlot", "Download Plot"),
            tags$hr(), # Horizontal line

        ),

        # Show a plots and selected data
        mainPanel(
           plotOutput("distPlot"),
           plotOutput("lmPlot"),
           h5("Slope"),
           textOutput("Slope"),
           h5("Y-Intercept"),
           textOutput("Intercepts"),
           h5("Correlation Coefficient"),
           textOutput("R.squared")
        )
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

    # CSV file reactive modeling
    dataInput <- reactive({
        req(input$file1)
        df <- read.csv(input$file1$datapath,
                       header = input$header,
                       sep = input$sep,
                       quote = input$quote)
        return(df)
    })

    # Defining my lmPlot data as linear model
    LinearModel <- eventReactive(input$lmPlot, {
        y <- dataInput()$y
        x <- dataInput()$x
        lmPlot <- lm(y ~ x)
    })

    # Scatter data plot
    output$distPlot <- renderPlot({
        plot(dataInput()$x,dataInput()$y)
    })

    # Linear regression plot
    lmGraph <- function(){
        plot(dataInput()$x,dataInput()$y)
        abline(LinearModel())
    }

    output$lmPlot <- renderPlot({
       lmGraph()
    })

    # Display slope, intercept (coefficients), and correlation coefficient (r.squared)
    output$R.squared <- renderText({
        paste("Adjusted R^2 = ",signif(summary(LinearModel())$adj.r.squared, 3))
    })
    output$Intercepts <- renderText({
        paste("Intercept =",signif(LinearModel()$coef[[1]], 3))
    })
    output$Slope <- renderText({
        paste("Slope =",signif(LinearModel()$coef[[2]], 3))
    })

    # Download/Export linear model as png
    output$downloadPlot <- downloadHandler(
        filename = function() { paste(input$file1$datapath, '.png', sep='') },
        content = function(file) {
            png(file)
            lmGraph()
            dev.off()
    })
}

# Run the application
shinyApp(ui = ui, server = server)


#' C2F
#'
#' Convert temperature from Celsius degree to Fahrenheit degree.
#'
#' @param numeric C Temperature in Celsius degrees.
#' @return numeric  Temperature in Fahrenheit degrees.
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  Temperature
#'
#' @export
#'
#'
#'
#'

C2F<-function(t)
{
  return (t * 1.8+ 32.0);
}


library(shiny)
library(datasets)

# Define UI for application that draws a graphic
ui <- fluidPage(

  titlePanel("Design Pattern 9: Interactive Application in R (Shiny)"),

  # Sidebar with a select input for provinces
  sidebarLayout(
    sidebarPanel(
       selectInput("place", "Select one of 47 French-speaking provinces of Switzerland",
                   as.factor(row.names(swiss)), selected = as.factor("Courtelary"))
    ),

    # Show a plot
    mainPanel(
       plotOutput("distPlot")
    )
  )
)

# Define how and what should it be created
server <- function(input, output) {

  output$distPlot <- renderPlot({
    # format & prepare the "long" data
    swiss_Religion <- as.data.frame(swiss[,5])
    colnames(swiss_Religion)[1] <- "Catholic"
    swiss_Religion$Place <- row.names(swiss)
    swiss_Religion$Protestant <- round(100-swiss_Religion$Catholic,2)
    swiss_Religion$LabelCatholic <- paste("Catholic\n ", swiss_Religion$Catholic, "%")
    swiss_Religion$LabelProtestant <- paste("Protestant\n ", swiss_Religion$Protestant, "%")

    exactPlace <- input$place
    pie(as.numeric(swiss_Religion[swiss_Religion$Place == exactPlace,c(1,3)]),
        labels = c(swiss_Religion[swiss_Religion$Place == exactPlace,c(4,5)]),
        main=paste0("Distribution of Religion in Percent at about 1888 in ", exactPlace,
                    ", Switzerland.\n Source: Mosteller & Tukey (1977)"))
  })
}

shinyApp(ui = ui, server = server)


library(WGCNA)

load("BrainGVEx_human_brain_AdjustCombatandCovariants.rdata")
load("../tpmoverlapgenes.rdata")

datExpr <- AA_datExpr[genes,]

# Choose a set of soft-thresholding powers
powers = c(c(1:30), seq(from = 20, to=40, by=2))
# Call the network topology analysis function
sft = pickSoftThreshold(t(datExpr), powerVector = powers, networkType = "unsigned",verbose = 5)
# Plot the results:
pdf("./unsigned_softThresh.pdf")
par(mfrow = c(1,2));
cex1 = 0.9;
# Scale-free topology fit index as a function of the soft-thresholding power
plot(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2],
xlab="Soft Threshold (power)",ylab="Scale Free Topology Model Fit,signed R^2",type="n",
main = paste("Scale independence"));
text(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2],
labels=powers,cex=cex1,col="red");
# this line corresponds to using an R^2 cut-off of h
abline(h=0.80,col="red")
# Mean connectivity as a function of the soft-thresholding power
plot(sft$fitIndices[,1], sft$fitIndices[,5],
xlab="Soft Threshold (power)",ylab="Mean Connectivity", type="n",
main = paste("Mean connectivity"))
text(sft$fitIndices[,1], sft$fitIndices[,5], labels=powers, cex=cex1,col="red")
dev.off()

net = blockwiseModules(t(datExpr), power = 6,mergeCutHeight=0.25,nThreads=10,
                                maxBlockSize=50000,networkCalibration  = 'single quantile',
                                calibrationQuantile = 0.8,numericLabels = TRUE,
                                corType="bicor", useMean = T,
                                minModuleSize=20,pamStage=FALSE,networkType="signed",saveTOMs = TRUE,saveTOMFileBase = "./CAUCBrainSignedTOM",verbose = 3)

load("CNSBrainUnSignedTOM-block.1.RData")
dissTOM = 1-TOM
# Call the hierarchical clustering function
geneTree = hclust(as.dist(dissTOM), method = "average");
colors = vector(mode="list")
labels = vector(mode="list")

for (pam in c(TRUE,FALSE)) {
  for (minModSize in c(20,30,40,50)) {
    for (dthresh in c(0.1, 0.2)) {
      for(ds in c(1,2,3,4)) {
        print(paste("DS=", ds, ",MMS=", minModSize, ",DCOR=",dthresh,",PAM=",pam,sep=""))
        tree = cutreeHybrid(dendro = geneTree, minClusterSize= minModSize, pamStage=pam, cutHeight = 0.999, deepSplit=ds, distM=as.matrix(1-TOM))
        merged = mergeCloseModules(exprData= t(datExpr), colors = tree$labels, cutHeight=dthresh)
        colors = cbind(colors, labels2colors(merged$colors))

        labels = c(labels, paste("DS=", ds, ",MMS=", minModSize, ",DCOR=",dthresh,",PAM=",pam,sep=""))
      }
    }
  }
}
pdf("Fig2-UnSigned WGCNA different params.pdf", wi = 15)
plotDendroAndColors(geneTree, colors, groupLabels=labels, addGuide= TRUE, dendroLabels=FALSE, main="Dendrogram", cex.colorLabels=0.5)
dev.off()

colors = vector(mode="list")
labels = vector(mode="list")

minModSize = 100
pamStage = F
ds = 4
dthresh = 0.3

tree = cutreeHybrid(dendro = geneTree, minClusterSize= minModSize, pamStage=pamStage, cutHeight = 0.999, deepSplit=ds, distM=as.matrix(1-TOM));
merged = mergeCloseModules(exprData= t(datExpr), colors = tree$labels, cutHeight=dthresh)
colors = cbind(colors, labels2colors(merged$colors))
colors = labels2colors(merged$colors)
table(colors)
length(table(colors))

pdf("UnSigned Dendrogram and the Module Colors.pdf")
# Plot the dendrogram and the module colors underneath
plotDendroAndColors(geneTree, colors,
"Module colors",
dendroLabels = FALSE, hang = 0.03,
addGuide = TRUE, guideHang = 0.05)
dev.off()

moduleLabels = merged$colors
moduleColors = labels2colors(merged$colors)
MEs = merged$newMEs;
geneTree = geneTree;
save(minModSize,pamStage,ds ,dthresh, MEs, moduleLabels, moduleColors, geneTree,merged,file = "CNS-UnSigned-networkConstruction-auto.RData")


m <- 10; n <- 10; mat <- matrix(sample(1:20L, m*n, replace=TRUE), nrow=m);
x<-which(mat==20,arr.ind=TRUE,useNames=FALSE)
x<-x[order(x[,1]),]
for(i in mat[1:x[1,1]-1,]) print(i)
for(i in mat[x[1,1],1:x[1,2]]) print(i)


#Read in data
# Obtain data file as occurrence matrix from Fossilworks.
# Perform a standard search, select the generate diversity curves option, and download the 'presences.txt' file

occMatrix<-read.delim("presences.txt")

#Remove genus name and total occurrences columns
occMatrix<-occMatrix[,3:ncol(occMatrix)]

genera<-nrow(occMatrix)
bins<-ncol(occMatrix)
rangeFreq<-rep(0,bins)

# Replace all NAs with 0s
for (t in 1:nrow(occMatrix)){
  for (b in 1:bins){
    if(is.na(occMatrix[t,b])){
      occMatrix[t,b]=0
    }
  }
}

bins<-ncol(occMatrix)
twoTimers<-rep(0,10000)
threeTimers<-rep(0,10000)
partTimers<-rep(0,10000)
gapFillers<-rep(0,10000)
firstSeen<-rep(0,10000)
lastSeen<-rep(0,10000)

for (t in 1:nrow(occMatrix)){
  for (b in 1:bins){
    if (occMatrix[t,b]>0){
      if (firstSeen[t]==0){
        firstSeen[t]=b
      }
      lastSeen[t]=b
    }
    if (b>1){
      if ((occMatrix[t,b-1]>0) & (b<bins)){
        if (occMatrix[t,b]>0){
          twoTimers[b]<-twoTimers[b]+1
        }
        if ((occMatrix[t,b]>0) & (occMatrix[t,b+1]>0)){
          threeTimers[b]<-threeTimers[b]+1
        }
        else if((occMatrix[t,b]==0) & (occMatrix[t,b+1]>0)){
          partTimers[b]<-partTimers[b]+1
        }
      }
      if(b>1 & (occMatrix[t,b-1])>0 & b+1<bins){
        if((occMatrix[t,b+1]==0) & (occMatrix[t,b+2]>0)){
          gapFillers[b]<-gapFillers[b]+1
        }
      }
    }
  }
}

#plot(1:bins,log(gapFillers[1:13]),type="o",ylim=c(0,5),xlab="bins",ylab="log count")
#points(1:bins,log(partTimers[1:13]),col="green",type="o")
#points(1:bins,log(twoTimers[1:13]),col="red",type="o")
#points(1:bins,log(threeTimers[1:13]),col="blue",type="o")

#Calculate Foote rates (BC)
Nbt<-rep(0,14) # Crosses both boundaries
Nb<-rep(0,14) # Crosses bottom boundary
Nt<-rep(0,14) # Crosses top boundary

for (t in 1:nrow(occMatrix)){
  if(firstSeen[t]+1<lastSeen[t]){
    for (b in firstSeen[t]+1:lastSeen[t]-1){
      Nbt[b]<-Nbt[b]+1
    }
  }
  if (firstSeen[t]<lastSeen[t]){
    Nb[lastSeen[t]]<-Nb[lastSeen[t]]+1
    Nt[firstSeen[t]]<-Nt[firstSeen[t]]+1
  }
}

Nb
Nt
Nbt<-Nbt[1:14]

(Fext<-log((Nb+Nbt)/Nbt)) #Extinction rate
(Forig<-log((Nt+Nbt)/Nbt)) #Origination rate

#Calculate gap-filler estimates
twoTimers<-twoTimers[1:13]
partTimers<-partTimers[1:13]
threeTimers<-threeTimers[1:13]
gapFillers<-gapFillers[1:13]
GFest<-log((twoTimers+partTimers)/(threeTimers+partTimers+gapFillers))
GFest
median(GFest,na.rm=TRUE)

#Calculate three timer (3T) extinction rate
output=NULL
for (i in 1:bins){
  ThreeExt<-log(twoTimers[i]/threeTimers[i])+log(threeTimers[i+1]/(threeTimers[i+1]+partTimers[i+1]))
  output<-cbind(ThreeExt,output)
}
output
median(output,na.rm=TRUE)

# 3T origination rates
output=NULL
for (i in 1:bins){
  ThreeExt<-log(twoTimers[i+1]/threeTimers[i])+log(threeTimers[i+1]/(threeTimers[i+1]+partTimers[i+1]))
  output<-cbind(ThreeExt,output)
}
output

par(mfrow=c(2,2))
plot(Fext,type="o",xlab="bins")
plot(Forig, type="o",xlab="bins")
plot(gapFillers,type="o",xlab="bins")
plot(1:length(output),output,type="o",ylab="3T")


#############
# R script to #
# run simulation #
# of community tightness #
# an community distance metric #
##################################

# load libraries
library(ade4)
library(ggplot2)
library(gridExtra)
library(Matrix)

# now expand with positive or negative correlation
n_obs <- 53
n_col1 <- 10
n_col2 <- 10
n_col3 <- 10
n_col4 <- 10

# very tight communities
M <- matrix(rbeta(n_col1 * n_col2 * n_col3 * n_col4, 5, 1),
            ncol = n_col1 + n_col2 + n_col3 + n_col4,
            nrow = n_col1 + n_col2 + n_col3 + n_col4)
M <- M * ifelse(runif(length(M)) < 0.5, -1, 1) # add randomly negative corr
gdata::lowerTriangle(M) <- gdata::upperTriangle(M, byrow=TRUE)
diag(M) <- 1
# turn into PD
M_pd <- nearPD(M, corr = TRUE)$mat
M_pm <- melt(as.matrix(M_pd))
M_pm$type <- "tight"
M_pm$value[M_pm$value == 1] <- NA

# Cholesky decomposition
L = chol(M_pd)
nvars = dim(L)[1]
r = t(L) %*% matrix(rnorm((n_col1 + n_col2 + n_col3 + n_col4)*n_obs),
                    nrow=n_col1+n_col2+n_col3+n_col4,
                    ncol=n_obs)
r = t(r)

comm1 <- as.matrix(r)[,1:n_col1]
comm2 <- as.matrix(r)[,(n_col1 + 1):(n_col1 + n_col2)]
comm3 <- as.matrix(r)[,(n_col1 + n_col2 + 1):(n_col1 + n_col2 + n_col3)]
comm4 <- as.matrix(r)[,(n_col1 + n_col2 + n_col3 + 1):(n_col1 + n_col2 + n_col3 + n_col4)]

# run mcoa
d1 <- dudi.pca(comm1, scannf = FALSE)
d2 <- dudi.pca(comm2, scannf = FALSE)
d3 <- dudi.pca(comm3, scannf = FALSE)
d4 <- dudi.pca(comm4, scannf = FALSE)

ktt <- ktab.list.dudi(list(d1, d2, d3, d4))

mm <- mcoa(ktt, scannf = FALSE, nf = 2)

# get the dist for each plots
vhb_xy <- mm$Tl1
vhb_xy$id_plot <- rep(1:53, 4)
vhb_xy$ref_x <- mm$SynVar[rep(1:53, 4),1]
vhb_xy$ref_y <- mm$SynVar[rep(1:53, 4),2]
vhb_xy$d <- with(vhb_xy, sqrt((Axis1-ref_x) ** 2 + (Axis2-ref_y) ** 2))
vhb_xy$type <- "tight - w. negative"
vhb_xy %>%
  group_by(type, id_plot) %>%
  summarise(d = sum(d)) -> vhb_dd

# now with loose communities
M <- matrix(rbeta(n_col1 * n_col2 * n_col3 * n_col4, 1, 6),
            ncol = n_col1 + n_col2 + n_col3 + n_col4,
            nrow = n_col1 + n_col2 + n_col3 + n_col4)
gdata::lowerTriangle(M) <- gdata::upperTriangle(M, byrow=TRUE)
M <- M * ifelse(runif(length(M)) < 0.5, -1, 1) # add randomly negative corr
diag(M) <- 1
# turn into PD
M_pd <- nearPD(M, corr = TRUE)$mat
# to plot the correlation matrix
M_pm2 <- melt(as.matrix(M_pd))
M_pm2$type <- "loose"
M_pm2$value[M_pm2$value == 1] <- NA

# Cholesky decomposition
L = chol(M_pd)
nvars = dim(L)[1]
r = t(L) %*% matrix(rnorm((n_col1 + n_col2 + n_col3 + n_col4)*n_obs),
                    nrow=n_col1+n_col2+n_col3+n_col4,
                    ncol=n_obs)
r = t(r)

comm1 <- as.matrix(r)[,1:n_col1]
comm2 <- as.matrix(r)[,(n_col1 + 1):(n_col1 + n_col2)]
comm3 <- as.matrix(r)[,(n_col1 + n_col2 + 1):(n_col1 + n_col2 + n_col3)]
comm4 <- as.matrix(r)[,(n_col1 + n_col2 + n_col3 + 1):(n_col1 + n_col2 + n_col3 + n_col4)]

# run mcoa
d1 <- dudi.pca(comm1, scannf = FALSE)
d2 <- dudi.pca(comm2, scannf = FALSE)
d3 <- dudi.pca(comm3, scannf = FALSE)
d4 <- dudi.pca(comm4, scannf = FALSE)

ktt <- ktab.list.dudi(list(d1, d2, d3, d4))

mm <- mcoa(ktt, scannf = FALSE, nf = 2)

# get the dist for each plots
vhb_xy <- mm$Tl1
vhb_xy$id_plot <- rep(1:53, 4)
vhb_xy$ref_x <- mm$SynVar[rep(1:53, 4),1]
vhb_xy$ref_y <- mm$SynVar[rep(1:53, 4),2]
vhb_xy$d <- with(vhb_xy, sqrt((Axis1-ref_x) ** 2 + (Axis2-ref_y) ** 2))
vhb_xy$type <- "loose - w. negative"
vhb_xy %>%
  group_by(type, id_plot) %>%
  summarise(d = sum(d)) -> vhb_dd2

# now tight within but loose across
M <- matrix(rbeta(n_col1 * n_col2 * n_col3 * n_col4, 1, 6),
            ncol = n_col1 + n_col2 + n_col3 + n_col4,
            nrow = n_col1 + n_col2 + n_col3 + n_col4)
gdata::lowerTriangle(M) <- gdata::upperTriangle(M, byrow=TRUE)
M <- M * ifelse(runif(length(M)) < 0.5, -1, 1) # add randomly negative corr
# go through the different within community corr
gdata::lowerTriangle(M[1:10, 1:10]) <- rbeta(45, 5, 1)
M[1:10, 1:10] <- M[1:10, 1:10] * ifelse(runif(100) < 0.5, -1, 1)
gdata::upperTriangle(M[1:10, 1:10]) <- gdata::lowerTriangle(M[1:10, 1:10], byrow = TRUE)
gdata::lowerTriangle(M[11:20, 11:20]) <- rbeta(45, 5, 1)
M[11:20, 11:20] <- M[11:20, 11:20] * ifelse(runif(100) < 0.5, -1, 1)
gdata::upperTriangle(M[11:20, 11:20]) <- gdata::lowerTriangle(M[11:20, 11:20], byrow = TRUE)
gdata::lowerTriangle(M[21:30, 21:30]) <- rbeta(45, 5, 1)
M[21:30, 21:30] <- M[21:30, 21:30] * ifelse(runif(100) < 0.5, -1, 1)
gdata::upperTriangle(M[21:30, 21:30]) <- gdata::lowerTriangle(M[21:30, 21:30], byrow = TRUE)
gdata::lowerTriangle(M[31:40, 31:40]) <- rbeta(45, 5, 1)
M[31:40, 31:40] <- M[31:40, 31:40] * ifelse(runif(100) < 0.5, -1, 1)
gdata::upperTriangle(M[31:40, 31:40]) <- gdata::lowerTriangle(M[31:40, 31:40], byrow = TRUE)
diag(M) <- 1

M_pd <- nearPD(M, corr = TRUE)$mat
# to plot the correlation matrix
M_pm3 <- melt(as.matrix(M_pd))
M_pm3$type <- "tight within\nloose between"
M_pm3$value[M_pm3$value == 1] <- NA

# Cholesky decomposition
L = chol(M_pd)
nvars = dim(L)[1]
r = t(L) %*% matrix(rnorm((n_col1 + n_col2 + n_col3 + n_col4)*n_obs),
                    nrow=n_col1+n_col2+n_col3+n_col4,
                    ncol=n_obs)
r = t(r)

comm1 <- as.matrix(r)[,1:n_col1]
comm2 <- as.matrix(r)[,(n_col1 + 1):(n_col1 + n_col2)]
comm3 <- as.matrix(r)[,(n_col1 + n_col2 + 1):(n_col1 + n_col2 + n_col3)]
comm4 <- as.matrix(r)[,(n_col1 + n_col2 + n_col3 + 1):(n_col1 + n_col2 + n_col3 + n_col4)]

# run mcoa
d1 <- dudi.pca(comm1, scannf = FALSE)
d2 <- dudi.pca(comm2, scannf = FALSE)
d3 <- dudi.pca(comm3, scannf = FALSE)
d4 <- dudi.pca(comm4, scannf = FALSE)

ktt <- ktab.list.dudi(list(d1, d2, d3, d4))

mm <- mcoa(ktt, scannf = FALSE, nf = 2)

# get the dist for each plots
vhb_xy <- mm$Tl1
vhb_xy$id_plot <- rep(1:53, 4)
vhb_xy$ref_x <- mm$SynVar[rep(1:53, 4),1]
vhb_xy$ref_y <- mm$SynVar[rep(1:53, 4),2]
vhb_xy$d <- with(vhb_xy, sqrt((Axis1-ref_x) ** 2 + (Axis2-ref_y) ** 2))
vhb_xy$type <- "tight within\nloose between - w. negative"
vhb_xy %>%
  group_by(type, id_plot) %>%
  summarise(d = sum(d)) -> vhb_dd3

# a plot comparing the correlation
M_a <- rbind(M_pm, M_pm2, M_pm3)
gg_1 <- ggplot(M_a, aes(x=Var1, y = Var2, fill = value)) +
  geom_raster() +
  facet_wrap(~ type) +
  scale_fill_gradient2(low = "red", high = "blue") +
  labs(x = "", y = "",
       title = "Simulated correlation structure between 4 communities") +
  theme(axis.text = element_blank(), axis.ticks = element_blank(),
        panel.background = element_blank())

# a plot comparing the d-metric
vhb_a <- rbind(vhb_dd, vhb_dd2, vhb_dd3)
gg_2 <- ggplot(vhb_a, aes(x=type, y=d))+
  geom_jitter(width = 0.1, alpha = 0.3, size = 0.5) +
  stat_summary(fun.data = "mean_cl_boot", color = "red") +
  labs(x = "Type of correlation structure",
       y = "Community distance index",
       title = "Effect of correlation structure between communities\non community distance index")
# nice!

gg_a <- grid.arrange(gg_1, gg_2, nrow = 2)
ggsave("~/PostDoc_Ghent/Synthesis_3/figures/simulation_res_wneg.png", gg_a,
       width = 8, height = 9, units = "in")


fisher_test_2x2 <- function(groupA, groupB, gene.universe, verbose=FALSE) {
  if(verbose) message("fisher_test_2x2()")
  groupA            <- unique(as.character(groupA))
  groupB            <- unique(as.character(groupB))
  gene.universe     <- unique(as.character(gene.universe))

  # First, restrict both groups to the provided universe of genes
  groupA <- groupA[groupA %in% gene.universe]
  groupB <- groupB[groupB %in% gene.universe]

  if(length(groupA) == 0 | length(groupB) == 0) {
    message("Zero elements after universe filtering. groupA: ", length(groupA), " groupB: ", length(groupB))
    result.df <- data.frame(test_type="Enrichment",
                            pvalue=1,
                            overlap = 0,
                            totalA  = length(groupA),
                            totalB  = length(groupB),
                            universe = length(gene.universe),
                            enrichment = 1)
    return(result.df)
  }

  # Calculate the 4 values for the contingency table
  count.Aonly   <- length(groupA[!(groupA %in% groupB)])
  count.overlap <- length(groupA[groupA %in% groupB])
  count.neither <- length(gene.universe[!(gene.universe %in% groupA) & !(gene.universe %in% groupB)])
  count.Bonly   <- length(groupB[!(groupB %in% groupA)])

  if(verbose) {
    message(" Universe size: ", length(gene.universe))
    message(" A only: ", count.Aonly)
    message(" Overlap A & B: ", count.overlap)
    message(" Neither A nor B: ", count.neither)
    message(" B only: ", count.Bonly)
  }

  # Build the 2x2 matrix
  m <- matrix(c(count.overlap, count.Aonly, count.Bonly, count.neither), nrow=2, byrow=T)

  # Decide on enrichment test or depletion test
  prop1 <- count.overlap / length(groupA)
  prop2 <- count.Bonly / (length(gene.universe) - length(groupA))
  if(is.na(prop2)) prop2 <- -1

  if(verbose) {
    message("Proportion 1: ", ifelse(is.numeric(prop1), round(prop1, 4), "<not numeric>"))
    message("Proportion 2: ", ifelse(is.numeric(prop2), round(prop2, 4), "<not numeric>"))
  }

  alt.test <- ifelse(prop1 > prop2, "greater", "less")

  # Perform the test
  result <- fisher.test(m, alternative=alt.test)

  obs <- count.overlap / length(groupA)
  exp <- length(groupB) / length(gene.universe)

  enrichment <- obs / exp

  # Return the result
  result.df <- data.frame(test_type=ifelse(alt.test == "greater", "Enrichment", "Depletion"),
                          pvalue=result$p.value,
                          overlap = as.integer(count.overlap),
                          totalA  = length(groupA),
                          totalB  = length(groupB),
                          universe = length(gene.universe),
                          enrichment = enrichment)
  result.df
}


physics.precalculated.earth.mass = (5.98e+24)
physics.precalculated.earth.radius = physics.convert.to.meters(6378)
physics.precalculated.earth.density = physics.density.calculate(physics.precalculated.earth.mass, physics.volume.calculate.sphere(physics.precalculated.earth.radius))
physics.precalculated.earth.gravity = physics.gravity.calculate.acceleration(physics.precalculated.earth.mass, physics.precalculated.earth.radius)

physics.precalculated.mercury.mass = (3.30e+23)
physics.precalculated.mercury.radius = physics.convert.to.meters(2439)
physics.precalculated.mercury.density = physics.density.calculate(physics.precalculated.mercury.mass, physics.volume.calculate.sphere(physics.precalculated.mercury.radius))
physics.precalculated.mercury.gravity = physics.gravity.calculate.acceleration(physics.precalculated.mercury.mass, physics.precalculated.mercury.radius)


library(VGAM)

#description:

args=commandArgs()
print(args)
startInd=6

file=args[startInd]
dnaOnly=args[startInd+1]

pbetabin.ab=pbetabinom.ab

#fit distribution
logLik.bb <- function(ab){
  a = ab[1]
  b = ab[2]
  logL = sum(lchoose(ns,ks) + lbeta(ks+a,ns-ks+b))
  logL = logL - length(ns)*lbeta(a,b)
  -logL
}

pinch=function(x){
  #pinch p-value range
  if(!is.na(x) & x<=0){
    return(1e-16)
  }
  if(!is.na(x) & x >= 1){
    return( 1 - 1e-16)
  }
  return(x)
}

#check duplicates.

d=read.csv(pipe(paste("grep  '^#INIT' ",file, " | cut -d, -f 9,13,23,27,54,55",sep="")),skip=1,header=F)#header=T)
head(d)
for(i in 1:4){
  d[,i] = as.numeric(as.character(d[,i]))
}

#test
#sn=10000
#s=sample(1:100,sn,replace=T)
#v=rbetabinom.ab(sn, s, 0.2, 200, .dontuse.prob = NULL)

#d=cbind(s,v)

#DNA
	ind=which(d[,5]==1)
	ks=d[ind,2]
	ns=apply(d[ind,1:2],1,sum,na.rm=T)
	if(sum(d[ind,2]>ns,na.rm=T)>0){
	  message("dna error, k > n");
	  q();
	}
	summary(ks)
	summary(ns)
	op = optim(par=c(1,10), fn=logLik.bb,control=list(maxit=5000))
	op
	a_d = op$par[1]
	b_d = op$par[2]
	print("DNA")
	print(op)
	print(as.character(a_d))
	print(as.character(b_d))

#RNA
a_r=NA
b_r=NA
if(dnaOnly != "1"){
	ind=which(d[,6]==1)
	ks=d[ind,4]
	ns=apply(d[ind,3:4],1,sum,na.rm=T)
	if(sum(d[ind,4]>ns,na.rm=T)>0){
	  message("rna error, k > n");
	  q();
	}
	summary(ks)
	summary(ns)
	op = optim(par=c(1,10), fn=logLik.bb,control=list(maxit=5000))
	a_r = op$par[1]
	b_r = op$par[2]
	print("RNA")
	print(op)
	print(as.character(a_r))
	print(as.character(b_r))
}

m=rbind(
	c("dna",a_d,b_d),
	c("rna",a_r,b_r))

#write out.
mf=paste(file,".fit",sep="")
write.table(m,sep=",",row.names=F,col.names=F,quote=F,file=mf)


source("calculate/distance.r")
source("calculate/norms.r")

# Renderable data.frame of nearest neighbours
neighbours_table <- function(word, distance_type, count, radius) {

  if (radius <= 0) { radius = Inf }

  mx = distance_matrix(vector_for_word(word), matrix_for_words(all_words), distance_type)
  argsort <- order(mx)
  nearest_idxs <- argsort[2:(count+1)]  # Skip the guaranteed nearest neighbour: the word itself
  nearest_words <- all_words[nearest_idxs]
  nearest_distances <- mx[nearest_idxs]

  if (!is.infinite(radius)) {
    nearest_distances <- nearest_distances[nearest_distances <= radius]
    nearest_words <- nearest_words[1:length(nearest_distances)]
  }

  table <- data.frame(order = 1:length(nearest_words),
                      Concept = nearest_words,
                      distance = nearest_distances)
  names(table) <- c("Order", "Concept", distance_col_name(distance_type))

  return(table)
}


model_vernalizationprogress <- function (dayLength = 12.3037621834005,
         deltaTT = 20.3429985011972,
         cumulTT = 112.330110409888,
         leafNumber_t1 = 0.0,
         calendarMoments_t1 = c('Sowing'),
         calendarDates_t1 = c('2007/3/21'),
         calendarCumuls_t1 = c(0.0),
         minTvern = 0.0,
         intTvern = 11.0,
         vAI = 0.015,
         vBEE = 0.01,
         minDL = 8.0,
         maxDL = 15.0,
         maxTvern = 23.0,
         pNini = 4.0,
         aMXLFNO = 24.0,
         vernaprog_t1 = 0.5517254187376879,
         currentdate = '2007/3/27',
         isVernalizable = 1,
         minFinalNumber_t1 = 5.5){
    #'- Name: VernalizationProgress -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: VernalizationProgress Model
    #'            * Author: Pierre MARTRE
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA Montpellier
    #'            * Abstract: Calculate progress (VernaProg) towards vernalization, but there
    #'        			is no vernalization below minTvern
    #'        			and above maxTvern . The maximum value of VernaProg is 1.
    #'        			Progress towards full vernalization is a linear function of shoot
    #'        			temperature (soil temperature until leaf # reach MaxLeafSoil and then
    #'        			 canopy temperature)
    #'
    #'- inputs:
    #'            * name: dayLength
    #'                          ** description : day length
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 12.3037621834005
    #'                          ** unit : mm2 m-2
    #'                          ** inputtype : variable
    #'            * name: deltaTT
    #'                          ** description : difference cumul TT between j and j-1 day
    #'                          ** variablecategory : auxiliary
    #'                          ** inputtype : variable
    #'                          ** datatype : DOUBLE
    #'                          ** min : -20
    #'                          ** max : 100
    #'                          ** default : 20.3429985011972
    #'                          ** unit : °C d
    #'            * name: cumulTT
    #'                          ** description : cumul thermal times at currentdate
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -200
    #'                          ** max : 10000
    #'                          ** default : 112.330110409888
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: leafNumber_t1
    #'                          ** description : Actual number of phytomers
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default : 0
    #'                          ** unit : leaf
    #'                          ** inputtype : variable
    #'            * name: calendarMoments_t1
    #'                          ** description : List containing appearance of each stage
    #'                          ** variablecategory : state
    #'                          ** datatype : STRINGLIST
    #'                          ** default : ['Sowing']
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: calendarDates_t1
    #'                          ** description : List containing  the dates of the wheat developmental phases
    #'                          ** variablecategory : state
    #'                          ** datatype : DATELIST
    #'                          ** default : ['2007/3/21']
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: calendarCumuls_t1
    #'                          ** description : list containing for each stage occured its cumulated thermal times
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** default : [0.0]
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: minTvern
    #'                          ** description : Minimum temperature for vernalization to occur
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : -20
    #'                          ** max : 60
    #'                          ** default : 0.0
    #'                          ** unit : °C
    #'                          ** inputtype : parameter
    #'            * name: intTvern
    #'                          ** description : Intermediate temperature for vernalization to occur
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : -20
    #'                          ** max : 60
    #'                          ** default :  11.0
    #'                          ** unit : °C
    #'                          ** inputtype : parameter
    #'            * name: vAI
    #'                          ** description : Response of vernalization rate to temperature
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default :  0.015
    #'                          ** unit : d-1 °C-1
    #'                          ** inputtype : parameter
    #'            * name: vBEE
    #'                          ** description : Vernalization rate at 0°C
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 0.01
    #'                          ** unit : d-1
    #'                          ** inputtype : parameter
    #'            * name: minDL
    #'                          ** description : Threshold daylength below which it does influence vernalization rate
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 12
    #'                          ** max : 24
    #'                          ** default : 8.0
    #'                          ** unit : h
    #'                          ** inputtype : parameter
    #'            * name: maxDL
    #'                          ** description : Saturating photoperiod above which final leaf number is not influenced by daylength
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 24
    #'                          ** default : 15.0
    #'                          ** unit : h
    #'                          ** inputtype : parameter
    #'            * name: maxTvern
    #'                          ** description : Maximum temperature for vernalization to occur
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : -20
    #'                          ** max : 60
    #'                          ** default :  23.0
    #'                          ** unit : °C
    #'                          ** inputtype : parameter
    #'            * name: pNini
    #'                          ** description : Number of primorida in the apex at emergence
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 24
    #'                          ** default : 4.0
    #'                          ** unit : primordia
    #'                          ** inputtype : parameter
    #'            * name: aMXLFNO
    #'                          ** description : Absolute maximum leaf number
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default : 24.0
    #'                          ** unit : leaf
    #'                          ** inputtype : parameter
    #'            * name: vernaprog_t1
    #'                          ** description : progression on a 0  to 1 scale of the vernalization
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default :  0.5517254187376879
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: currentdate
    #'                          ** description : current date
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DATE
    #'                          ** default : 2007/3/27
    #'                          ** inputtype : variable
    #'                          ** unit :
    #'            * name: isVernalizable
    #'                          ** description : true if the plant is vernalizable
    #'                          ** parametercategory : species
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 1
    #'                          ** unit :
    #'                          ** inputtype : parameter
    #'            * name: minFinalNumber_t1
    #'                          ** description : minimum final leaf number
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default : 5.5
    #'                          ** unit : leaf
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'- outputs:
    #'            * name: vernaprog
    #'                          ** description : progression on a 0  to 1 scale of the vernalization
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit :
    #'            * name: minFinalNumber
    #'                          ** description : minimum final leaf number
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : leaf
    #'            * name: calendarMoments
    #'                          ** description : List containing appearance of each stage
    #'                          ** variablecategory : state
    #'                          ** datatype : STRINGLIST
    #'                          ** unit :
    #'            * name: calendarDates
    #'                          ** description : List containing  the dates of the wheat developmental phases
    #'                          ** variablecategory : state
    #'                          ** datatype : DATELIST
    #'                          ** unit :
    #'            * name: calendarCumuls
    #'                          ** description : list containing for each stage occured its cumulated thermal times
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** unit :
    calendarMoments <- vector()
    calendarDates <- vector()
    calendarCumuls <- vector()
    calendarMoments <- calendarMoments_t1
    calendarCumuls <- calendarCumuls_t1
    calendarDates <- calendarDates_t1
    minFinalNumber <- minFinalNumber_t1
    vernaprog <- vernaprog_t1
    if (isVernalizable == 1 && vernaprog_t1 < 1.0)
    {
        tt <- deltaTT
        if (tt >= minTvern && tt <= intTvern)
        {
            vernaprog <- vernaprog_t1 + (vAI * tt) + vBEE
        }
        else
        {
            vernaprog <- vernaprog_t1
        }
        if (tt > intTvern)
        {
            maxVernaProg <- vAI * intTvern + vBEE
            dLverna <- max(minDL, min(maxDL, dayLength))
            vernaprog <- vernaprog + max(0.0, maxVernaProg * (1.0 + ((intTvern - tt) / (maxTvern - intTvern) * ((dLverna - minDL) / (maxDL - minDL)))))
        }
        primordno <- 2.0 * leafNumber_t1 + pNini
        minLeafNumber <- minFinalNumber_t1
        if (vernaprog >= 1.0 || primordno >= aMXLFNO)
        {
            minFinalNumber <- max(primordno, minFinalNumber_t1)
            calendarMoments <- c(calendarMoments, 'EndVernalisation')
            calendarCumuls <- c(calendarCumuls, cumulTT)
            calendarDates <- c(calendarDates, currentdate)
            vernaprog <- max(1.0, vernaprog)
        }
        else
        {
            potlfno <- aMXLFNO - ((aMXLFNO - minLeafNumber) * vernaprog)
            if (primordno >= potlfno)
            {
                minFinalNumber <- max((potlfno + primordno) / 2.0, minFinalNumber_t1)
                vernaprog <- max(1.0, vernaprog)
                calendarMoments <- c(calendarMoments, 'EndVernalisation')
                calendarCumuls <- c(calendarCumuls, cumulTT)
                calendarDates <- c(calendarDates, currentdate)
            }
        }
    }
    return (list ("vernaprog" = vernaprog,"minFinalNumber" = minFinalNumber,"calendarMoments" = calendarMoments,"calendarDates" = calendarDates,"calendarCumuls" = calendarCumuls))
}


library(cellrangerRkit)
context('Normalization')

gene_names = c('a', 'b')
sample_names = c('sample1', 'sample2', 'sample3')

# Generate a test dataset
test_matrix = Matrix(matrix(c(1,2,10,20,100,200), ncol=3))
row.names(test_matrix) = gene_names
colnames(test_matrix) = sample_names

test_genes = data.frame(id=gene_names, symbol=gene_names)
row.names(test_genes) = gene_names

test_sample_data = data.frame(barcode=sample_names)
row.names(test_sample_data) = sample_names

# Create GBM from it
test_gbm <- newGeneBCMatrix(test_matrix, test_genes, test_sample_data)

# Test median normalization
test_gbm_bcnorm <- normalize_barcode_sums_to_median(test_gbm)

test_that("bc normalization gives correct result", {
  expect_true(all(colSums(test_gbm_bcnorm) == 30))
})

# Test log normalization
test_gbm <- newGeneBCMatrix(test_matrix, test_genes, test_sample_data)
test_gbm_log2 <- log_gene_bc_matrix(test_gbm, base=2)
test_that("bc normalization gives correct result", {
  expect_true(all(test_gbm_log2 == log2(1+test_gbm)))
})


all_global_data <- read.table("global-dump.txt",
                   header = TRUE,
                   sep="\t",
                   col.names=c("ap", "pr","au", "gt",
                               "rms", "pklv", "rssi", "snr", "loc"),
                   fill=FALSE,
                   strip.white=TRUE)

global_data <- all_global_data[c("ap", "pr", "gt", "rms", "pklv", "rssi")]
phone_data_gt <- all_global_data[c("gt", "ap", "rms", "pklv", "rssi")]
phone_data_pr <- all_global_data[c("pr", "ap", "rms", "pklv", "rssi")]

# all models
# 1. Linear
model1.gt <- lm(gt~., phone_data_gt)
summary(model1.gt)
predictions <- predict(model1.gt, phone_data_gt)
rmse <- sqrt(mean((phone_data_gt$gt - predictions)^2))
print(rmse)

model1.pr <- lm(pr~., phone_data_pr)
summary(model1.pr)
predictions <- predict(model1.pr, phone_data_pr)
rmse <- sqrt(mean((phone_data_pr$pr - predictions)^2))
print(rmse)

# 2. Multivariate Adaptive Regression Splines
library(earth)
model2.gt <- earth(gt~., phone_data_gt)
summary(model2.gt)
evimp(model2.gt)
predictions <- predict(model2.gt, phone_data_gt)
rmse <- sqrt(mean((phone_data_gt$gt - predictions)^2))
print(rmse)

model2.pr <- earth(pr~., phone_data_pr)
summary(model2.pr)
evimp(model2.pr)
predictions <- predict(model2.pr, phone_data_pr)
rmse <- sqrt(mean((phone_data_pr$pr - predictions)^2))
print(rmse)

# 3. SVM
library(kernlab)
model3.gt <- ksvm(gt~., phone_data_gt)
summary(model3.gt)
model3.gt
predictions <- predict(model3.gt, phone_data_gt)
rmse <- sqrt(mean((phone_data_gt$gt - predictions)^2))
print(rmse)

model3.pr <- ksvm(pr~., phone_data_pr)
summary(model3.pr)
model3.pr
predictions <- predict(model3.pr, phone_data_pr)
rmse <- sqrt(mean((phone_data_pr$pr - predictions)^2))
print(rmse)

# 4. kNN
library(caret)
model4.gt <- knnreg(phone_data_gt[,2:5], phone_data_gt[,1], k=3)
summary(model4.gt)
model4.gt
predictions <- predict(model4.gt, phone_data_gt[,2:5])
rmse <- sqrt(mean((phone_data_gt$gt - predictions)^2))
print(rmse)

model4.pr <- knnreg(phone_data_pr[,2:5], phone_data_pr[,1], k=1)
summary(model4.pr)
model4.pr
predictions <- predict(model4.pr, phone_data_pr[,2:5])
rmse <- sqrt(mean((phone_data_pr$pr - predictions)^2))
print(rmse)

# 5. Neural Network
library(nnet)
x <- phone_data_gt[,2:5]
y <- phone_data_gt[,1]
model5.gt <- nnet(gt~., phone_data_gt, size=50, maxit=1000, linout=T, decay=0.1)
summary(model5.gt)
predictions <- predict(model5.gt, x, type="raw")
rmse <- sqrt(mean((y - predictions)^2))
print(rmse)

x <- phone_data_pr[,2:5]
y <- phone_data_pr[,1]
model5.pr <- nnet(pr~., phone_data_pr, size=50, maxit=1000, linout=T, decay=0.1)
summary(model5.pr)
predictions <- predict(model5.pr, x, type="raw")
rmse <- sqrt(mean((y - predictions)^2))
print(rmse)


colSums(iris[,-5]) #column wise sum for col 1 to 4

R Community/R functions Assignments/Assignment3.r


# load the ggplot libraries
library(tidyverse)

# read in the data
temp <- read_tsv("average_fractionMissing.txt")

# make a basic plot
ggplot(temp, aes(x = AverageSpC, y = FracMissing)) +
  geom_point() +
  geom_smooth(method = "loess", span = 0.05) +
  ggtitle("Fraction Missing Data versus Average SpC") +
  labs(x = "Average SpC", y = "Fraction Missing")

# expanded x-axis plot
ggplot(temp, aes(x = AverageSpC, y = FracMissing)) +
  coord_cartesian(xlim = c(0, 50)) +
  geom_line() +
#  geom_smooth(method = "loess", span = 0.05) +
  ggtitle("Missing versus Average SpC") +
  labs( x = "Average SpC", y = "Fraction Missing") +
  geom_vline(xintercept = 2.5, linetype = "dotted") +
  geom_vline(xintercept = 5.0, linetype = "dashed")

sessionInfo()


#' Function to plot telomere on plot
#'
#' @param location Position to plot telomere at
#' @param x Circle parameter
#' @param y Circle parameter
#' @param r Radius of half circle
#' @param start Start value of calculation (Default: 0)
#' @param end End value of calculation (Default: pi)
#' @param nsteps Number od steps in between for calculation (Default: 1000)
#' @importFrom graphics lines
#' @export
telomere <- function(location, x, y, r, start = 0, end = pi, nsteps = 1000) {
  rs <- seq(start, end, len = nsteps)

  if(location == "top"){
    xc <- x + r * cos(rs)
    yc <- y + r * sin(rs)
  } else if(location == "bottom"){
    xc <- x - r * cos(rs)
    yc <- y - r * sin(rs)
  }
  lines(xc, yc)
}