######################################################################################################
# CS171 BioVis Project
# Spring 2013
# Author: John Mercer
# Code: Testing Data to figure out how to convert R datasets to JSON format easily
# http://stackoverflow.com/questions/3600431/is-it-possible-to-write-a-table-to-a-file-in-json-format-in-r
# http://theweiluo.wordpress.com/2011/09/30/r-to-json-for-d3-js-and-protovis/
######################################################################################################################

set.seed(1)
tbl <- table(round(runif(100, 1, 5)))

## 1  2  3  4  5
## 9 24 30 23 14

library(rjson)
sink("json.txt")
cat(toJSON(tbl))
sink()

file.show("json.txt")
## {"1":9,"2":24,"3":30,"4":23,"5":14}

## now try real data
sink("try_real_data.txt")
table_other_prin_comps <- as.table(other_prin_comps)
cat(toJSON(other_prin_comps))
sink()
json_version <- toJSON(other_prin_comps)
file.show("try_real_data.txt")

#############################################
toJSONarray <- function(dtf){
  clnms <- colnames(dtf)

  name.value <- function(i){
    quote <- '';
    if(class(dtf[, i])!='numeric'){
      quote <- '"';
    }

    paste('"', i, '" : ', quote, dtf[,i], quote, sep='')
  }

  objs <- apply(sapply(clnms, name.value), 1, function(x){paste(x, collapse=', ')})
  objs <- paste('{', objs, '}')

  res <- paste('[', paste(objs, collapse=', '), ']')

  return(res)
}

colname<-colnames(other_prin_comps)[1]

x<- list(pc1 = other_prin_comps[,1])
json <- toJSON(x)
sink("try_real_data.txt")
x<- list(pc1 = other_prin_comps[,1])
json <- toJSON(x)
cat(json)
sink()
file.show("try_real_data.txt")

plot.d <- defmacro( df, var, DOTS, col="red", title="", expr=
                      plot( df$var ~ df$Grp, type="b", col=col, main=title, ... )
)
plot.d( d, V1, col="blue" )

toJSON(c("foo","bar"))
data(iris)
toJSON(iris[1:5,])
toJSON(list(m=matrix(1:6,2)))


library(limma)
# function
venn4markerlist<-function(df_1, df_2){
	len_1<-length(levels(df_1$cluster))
	len_2<-length(levels(df_2$cluster))
	for(i in c(1:len_1)){
		gene_1<-subset(df_1,cluster==levels(df_1$cluster)[i])$gene;
		value_1<-rep(1,length(subset(df_1,cluster==levels(df_1$cluster)[i])$gene));
		dataL<-data.frame(gene=gene_1,value=value_1);
		for(j in c(1:len_2)){
			gene_2<-subset(df_2,cluster==levels(df_2$cluster)[j])$gene;
			value_2<-rep(1,length(subset(df_2,cluster==levels(df_2$cluster)[j])$gene));
			dataR<-data.frame(gene=gene_2,value=value_2);
			data_m<-merge(dataL,dataR,by="gene",all=T);
			row.names(data_m)<-data_m$gene;
			data_m<-data_m[,-1];
			data_m[is.na(data_m)]<-0;
			venn_counts <- vennCounts(data_m);
			filename=paste("venn_",levels(df_1$cluster)[i],"_",levels(df_2$cluster)[j],".pdf",sep="",collapse=NULL)
			pdf(filename);
			vennDiagram(venn_counts, cex=c(2,1),names = c(levels(df_1$cluster)[i],levels(df_2$cluster)[j]),circle.col = c("red","blue"),counts.col=NULL,show.include=NULL);
			dev.off()
		}
	}
}

# all in one
venn4markerlist.allinone<-function(df_1, df_2){
	len_1<-length(levels(df_1$cluster))
	len_2<-length(levels(df_2$cluster))
	filename="venn.allinone.pdf";
	pdf(filename);
	par(mfrow=c(len_1,len_2));
	for(i in c(1:len_1)){
		gene_1<-subset(df_1,cluster==levels(df_1$cluster)[i])$gene;
		value_1<-rep(1,length(subset(df_1,cluster==levels(df_1$cluster)[i])$gene));
		dataL<-data.frame(gene=gene_1,value=value_1);
		for(j in c(1:len_2)){
			gene_2<-subset(df_2,cluster==levels(df_2$cluster)[j])$gene;
			value_2<-rep(1,length(subset(df_2,cluster==levels(df_2$cluster)[j])$gene));
			dataR<-data.frame(gene=gene_2,value=value_2);
			data_m<-merge(dataL,dataR,by="gene",all=T);
			row.names(data_m)<-data_m$gene;
			data_m<-data_m[,-1];
			data_m[is.na(data_m)]<-0;
			venn_counts <- vennCounts(data_m);
			vennDiagram(venn_counts,names = c(levels(df_1$cluster)[i],levels(df_2$cluster)[j]),circle.col = c("red","blue"),counts.col=NULL,show.include=NULL,cex=c(0.5,0.5,0.5));
		}
	}
	dev.off()
}


# Figure 5: Comparing our measure to UK manifestos for post-1945 period.
# NOTE: you will need an API key for the Manifesto project. See:
# https://manifestoproject.wzb.eu/information/documents/api

rm(list=ls())

#load package and grab the dataset, subset to UK
require(manifestoR)
mp_setapikey("foo/your_api_key.txt") # change path to your key here.
mpds <- mp_maindataset()
mdata <- subset(mpds, countryname == "United Kingdom")

#grab RILE estimates
wparty <- which(mdata$partyname%in%c("Labour Party","Conservative Party"))
party.name <- mdata$partyname[wparty]
wdate  <- mdata$edate[wparty]
wrile  <- rile(mdata)[wparty]

dframe <- data.frame(wdate, party.name, wrile)

#colors
cols <- as.character(dframe$party.name)
cols[dframe$party.name=="Labour Party"] <- "red"
cols[dframe$party.name=="Conservative Party"] <- "lightblue"

#pchs
pchs <- as.character(dframe$party.name)
pchs[dframe$party.name=="Labour Party"] <- 22
pchs[dframe$party.name=="Conservative Party"] <- 21
pchs <- as.numeric(pchs)

#create difference plot -- 'polarization'
polar <- c()
for(i in 1:length(unique(dframe$wdate))){
  sub <- subset(dframe, dframe$wdate==unique(dframe$wdate)[i])
  diffe <- abs(sub$wrile[sub$party.name=="Conservative Party"] - sub$wrile[sub$party.name=="Labour Party"])
  polar <- c(polar, diffe)
}

x11()
#put everything on same plot
par(bg='cornsilk1')
plot(wdate, wrile, col="black" , bg=cols, pch=pchs,  ylim=c(min(wrile),max(polar) ), cex=2,
     xlab="year", ylab="RILE")
lines(unique(dframe$wdate), polar, type="l", lwd="2" )
#looks v similar to our plot, though 1945/50 looks a bit different.

#put on a lowess
low <- lowess(polar ~ 1:length(unique(dframe$wdate)), f=1/4)
lines(unique(dframe$wdate), low$y, lwd=3, lty=2, col="purple")

legend('topright', pch=c(21,22), pt.cex=2, col='black', pt.bg=c("lightblue","red"), legend=c("Conservative", "Labour"))

#check correlation between the tseries for polarization estimates
# (needs bit of work bec the dates are different)

#grab dates from estimation of polarization from machine
wd <- getwd() # assumes this is run from the replication folder, with data in a subdirectory.
data.dir <- paste0(wd, "/data/")

out<- read.csv(paste0(data.dir, "acc_j27_allmembers.csv"))
out$max.mean <- apply(out[,3:6], FUN=max, MARGIN=1)
month <- out$yrmth
est.dates <- as.Date(paste(month,"-01",sep=""))

#grab dates from manifesto ests
uwdate <- unique(dframe$wdate)

vec.dates <- c()

for(i in 1:length(uwdate)){

  vec.dates <- c(vec.dates, which(abs(est.dates-uwdate[i]) == min(abs(est.dates - uwdate[i]))) )

}

#now do the correlations (~.16)
corr  <- cor(out$max.mean[vec.dates], polar)

#NBthat this is much higher when we exclude first couple of points:
vec.dates2 <- vec.dates[3: length(vec.dates)]
corr2  <- cor(out$max.mean[vec.dates2], polar[3:length(polar)])


items <- c(1,2,3,2,4,3,2)
unique (items)


optim_path='/home/z***/script/v8/utmost/'

#args = commandArgs(trailingOnly=TRUE)
### optimization part ###
grad_prep <- function(X, Y){
  ## pre-calculate some metrics for gradient
  ## args
  ## X: a list of covariate matrices corresponding to each response
  ## Y: a list of response vectors
  ## value
  ## XY: a list of matrices X^TY for each response
  ll = length(Y)
  P = ncol(X[[1]])
  XY = matrix(0,P,ll)
  for(i in 1:ll){
    XY[,i] = t(X[[i]])%*%Y[[i]]/nrow(X[[i]])
  }
  XY
}

cv_helper <- function(N, fold){
  ## helper function for generating cross-validation sets
  ## args
  ## N: number of sample size
  ## fold: number of folds
  ## values
  ## perm: a permutation of 1 to N
  ## idx: matrix of fold by 2 with first col being starting index and second col being ending index
  valid_num = floor(N/fold)
  set.seed(123)
  perm = sample(1:N, size = N)
  idx1 = seq(1,N,valid_num)
  idx2 = c(idx1[-1]-1,N)
  list(perm=perm, idx=cbind(idx1,idx2))
}

minmax_lambda <- function(lst){
  ## get the minimum and maximum of lambda searched in cross-validation of an elastic net model
  ## args
  ## lst: an object returned by glmnet
  ## value
  ## min_lam: smallest lambda searched in glmnet cross-validation
  ## max_lam: largest lambda searched in glmnet cross-validation
  max_lam = max(unlist(lapply(lst, function(x){max(x$lambda)})))
  min_lam = min(unlist(lapply(lst, function(x){min(x$lambda)})))
  c(min_lam, max_lam)
}

elastic_net_mse <- function(lst, X_tune, Y_tune, X_test, Y_test){
  ## evaluate the performance of elastic net on each response
  ## args
  ## lst: a list of glmnet object (fitted elastic net model for each response)
  ## X_tune: a list of covariate matrices corresponding for each response (for tuning lambda)
  ## Y_tune: a list of response vectors (for tuning lambda)
  ## X_test: a list of covariate matrices corresponding for each response (for testing performance)
  ## Y_test: a list of response vectors (for testing performance)
  ## value
  ## lam: best performing lambda (on (X_tune,Y_tune)) for each response
  ## mse: list of matrices with each element being a matrix of predicted vs observed response
  ## est: estimated effect sizes for each response (B matrix)

  #lst<-single_summary
  P = length(lst)  #N of tissues
  M = ncol(X_tune[[1]]) #N of SNPs
  lam_V = rep(0, P)
  test_res = list()
  test_beta = matrix(0, M, P)
  for(t in 1:P){
    ncv = length(lst[[t]]$lambda)  #no of cv, i.e. no of tested lambdas
    tmp_mse = rep(0, ncv)
    for(k in 1:ncv){
      tmp_mse[k] = mean((Y_tune[[t]] - X_tune[[t]]%*%lst[[t]]$glmnet.fit$beta[,k])^2) #mean error in tuning set (apply beta to tuning set)
    }
    ss = which.min(tmp_mse)
    test_beta[,t] = lst[[t]]$glmnet.fit$beta[,ss]
    lam_V[t] = lst[[t]]$lambda[ss]
    predicted = X_test[[t]]%*%lst[[t]]$glmnet.fit$beta[,ss]
    test_res[[t]] = cbind(Y_test[[t]], predicted)
  }
  list(lam = lam_V, mse = test_res, est = test_beta)
}

multi_mse <- function(theta_est, X_test, Y_test){
  answer = list()
  P = ncol(theta_est)
  for(t in 1:P){
    predicted = X_test[[t]]%*%theta_est[,t]
    answer[[t]] = cbind(Y_test[[t]], predicted)
  }
  answer
}

avg_perm <- function(mse_lst){
  fd = length(mse_lst)
  P = length(mse_lst[[1]])
  rsq = mse = adj_mse = matrix(0, fd, P)
  for(f in 1:fd){
    for(t in 1:P){
      rsq[f,t] = (cor(mse_lst[[f]][[t]])[1,2])^2
      mse[f,t] = mean((mse_lst[[f]][[t]][,1]-mse_lst[[f]][[t]][,2])^2)
      adj_mse[f,t] = mse[f,t]/var(mse_lst[[f]][[t]][,1])
    }
  }
  cbind(apply(rsq, 2, mean), apply(mse, 2, mean), apply(adj_mse, 2, mean))

  #list(rsq = apply(rsq, 2, mean), mse = apply(mse, 2, mean), adj_mse = apply(adj_mse, 2, mean))
}

pred_test <- function(Y){
  if(sum(Y[,2]==0)==nrow(Y)|var(Y[,2])==0){
    return(2)
  }else{
    summary(lm(Y[,1]~Y[,2]))$coefficients[2,4]
  }
}

glasso <- function(X, Y, X1, Y1, XX, XY, Xnorm, lambda1, lambda2, theta, stepsize = 1e-4, maxiter = 50, eps = 1e-3){
  bgt = Sys.time()
  M = nrow(XY)
  P = length(X)
  NN = unlist(lapply(X, nrow))
  old_objV1 = rep(0,P)
  for(t in 1:P){
    old_objV1[t] = 1/2*mean((Y[[t]]-X[[t]]%*%theta[,t])^2)  #average error, appling st weight on training set
  }
  old_objV2 = rep(0,P)
  for(t in 1:P){
    old_objV2[t] = 1/2*mean((Y1[[t]]-X1[[t]]%*%theta[,t])^2) #average error, appling st weight on tuning set
  }
  beta_j_lasso = rep(0, P)
  tmp_XYj = 0
  if(!is.loaded("wrapper")){
    dyn.load(paste0(optim_path,"optim.so"))
  }
  for(i in 1:maxiter){  #iterations to get the lowest error.
    bgt = Sys.time()
    res = .Call("wrapper", XX, XY, theta, M, P, beta_j_lasso, lambda1, lambda2, Xnorm)
    edt = Sys.time()
    #print(edt-bgt)
    new_objV1 = new_objV2 = rep(0,P)
    for(t in 1:P){
      new_objV1[t] = 1/2*mean((Y[[t]]-X[[t]]%*%theta[,t])^2)
    }
    #cat("Training error: ", new_objV1, '\n')
    for(t in 1:P){
      new_objV2[t] = 1/2*mean((Y1[[t]]-X1[[t]]%*%theta[,t])^2)
    }
    #cat("Testing error: ", new_objV2, '\n')
    if(mean(new_objV2) > mean(old_objV2)|mean(new_objV1) > mean(old_objV1)){
      break
    }else{
      old_objV2 = new_objV2
    }
    if(max(abs(new_objV1-old_objV1)) < eps){
      break
    }else{
      old_objV1 = new_objV1
    }
  }
  #print(paste0('iterations: ',i))
  #edt = Sys.time()
  #print(edt-bgt)
  list(est = theta, avg_tune_err = mean(new_objV2), tune_err=new_objV2)
}

glasso_no_early_stopping <- function(X, Y, XX, XY, Xnorm, lambda1, lambda2, theta, stepsize = 1e-4, maxiter = 50, eps = 1e-3){
  M = nrow(XY)
  P = length(X)
  NN = unlist(lapply(X, nrow))
  old_objV1 = rep(0,P)
  for(t in 1:P){
    old_objV1[t] = 1/2*mean((Y[[t]]-X[[t]]%*%theta[,t])^2)
  }
  cat("Training error: ", mean(old_objV1), '\n')
  beta_j_lasso = rep(0, P)
  tmp_XYj = 0
  if(!is.loaded("wrapper")){
    dyn.load(paste0(optim_path,"optim.so"))
  }
  for(i in 1:maxiter){
    res = .Call("wrapper", XX, XY, theta, M, P, beta_j_lasso, lambda1, lambda2, Xnorm)
    new_objV1 = rep(0,P)
    for(t in 1:P){
      new_objV1[t] = 1/2*mean((Y[[t]]-X[[t]]%*%theta[,t])^2)
    }
    cat("Training error: ", mean(new_objV1), '\n')
    if(max(abs(new_objV1-old_objV1)) < eps|mean(new_objV1) > mean(old_objV1)){
      break
    }else{
      old_objV1 = new_objV1
    }
  }
  #print(paste0('iterations: ',i))
  list(est = theta, avg_train_err = mean(new_objV1), train_err = new_objV1,iter=i)
}

### command line input ###

glasso_mod <- function(X, Y, X1, Y1, XX, XY, Xnorm, lambda1, lambda2, theta, stepsize = 1e-4, maxiter = 50, eps = 1e-3){
  bgt = Sys.time()
  M = nrow(XY)
  P = length(X)
  NN = unlist(lapply(X, nrow))
  old_objV1 = rep(0,P)
  for(t in 1:P){
    old_objV1[t] = 1/2*mean((Y[[t]]-X[[t]]%*%theta[,t])^2)  #average error, appling st weight on training set
  }
  old_objV2 = rep(0,P)
  for(t in 1:P){
    old_objV2[t] = 1/2*mean((Y1[[t]]-X1[[t]]%*%theta[,t])^2) #average error, appling st weight on tuning set
  }
  beta_j_lasso = rep(0, P)
  tmp_XYj = 0
  if(!is.loaded("wrapper")){
    dyn.load(paste0(optim_path,"optim.so"))
  }

  beta_list<-list()
  beta_list[[1]]<-as.numeric(theta)

  for(i in 1:maxiter){  #iterations to get the lowest error.
    beta_matrix<-matrix(beta_list[[i]],M,P)

    bgt = Sys.time()
    res = .Call("wrapper", XX, XY, beta_matrix, M, P, beta_j_lasso, lambda1, lambda2, Xnorm)
    edt = Sys.time()
    #print(edt-bgt)
    new_objV1 = new_objV2 = rep(0,P)
    for(t in 1:P){
      new_objV1[t] = 1/2*mean((Y[[t]]-X[[t]]%*%beta_matrix[,t])^2)
    }
    #cat("Training error: ", new_objV1, '\n')
    for(t in 1:P){
      new_objV2[t] = 1/2*mean((Y1[[t]]-X1[[t]]%*%beta_matrix[,t])^2)
    }
    #cat("Testing error: ", new_objV2, '\n')
    if(mean(new_objV2) > mean(old_objV2)|mean(new_objV1) > mean(old_objV1)){
      beta_output<-beta_list[[i]]
      break
    }else{
      old_objV2 = new_objV2
      beta_list[[i+1]]<-as.numeric(beta_matrix)
    }
    if(max(abs(new_objV1-old_objV1)) < eps){
      beta_output<-beta_list[[i]]
      break
    }else{
      old_objV1 = new_objV1
      beta_list[[i+1]]<-as.numeric(beta_matrix)
    }
  }
  #print(paste0('iterations: ',i))
  #edt = Sys.time()
  #print(edt-bgt)
  list(est = matrix(beta_output,M,P), avg_tune_err = mean(new_objV2), tune_err=new_objV2)
}

glasso_no_early_stopping_mod <- function(X, Y, XX, XY, Xnorm, lambda1, lambda2, theta, stepsize = 1e-4, maxiter = 50, eps = 1e-3){
  M = nrow(XY)
  P = length(X) #n of tissues i.e. 49
  NN = unlist(lapply(X, nrow))
  old_objV1 = rep(0,P)
  for(t in 1:P){
    old_objV1[t] = 1/2*mean((Y[[t]]-X[[t]]%*%theta[,t])^2) #error of single tissue
  }
  cat("Training error: ", mean(old_objV1), '\n')
  beta_j_lasso = rep(0, P) #???
  tmp_XYj = 0
  if(!is.loaded("wrapper")){
    dyn.load(paste0(optim_path,"optim.so"))
  }

  beta_list<-list()
  beta_list[[1]]<-as.numeric(theta)

  for(i in 1:maxiter){

    beta_matrix<-matrix(beta_list[[i]],M,P)
    res = .Call("wrapper", XX, XY, beta_matrix, M, P, beta_j_lasso, lambda1, lambda2, Xnorm)

    new_objV1 = rep(0,P)
    for(t in 1:P){
      new_objV1[t] = 1/2*mean((Y[[t]]-X[[t]]%*%beta_matrix[,t])^2) #error after optimization
    }
    cat("Training error: ", mean(new_objV1), '\n')
    if(max(abs(new_objV1-old_objV1)) < eps|mean(new_objV1) > mean(old_objV1)){
      beta_output<-beta_list[[i]]
      break
    }else{
      old_objV1 = new_objV1
      beta_list[[i+1]]<-as.numeric(beta_matrix)
    }
  }
  #print(paste0('iterations: ',i))
  list(est = matrix(beta_output,M,P), avg_train_err = mean(new_objV1), train_err = new_objV1,iter=i)
}

### command line input ###


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     21.10.2019
#modificado: 04.11.2019

setwd("2019/2019.08.13_formacao_RCD2019/bin/")
library("tidyverse")

#1.1.
?geom_freqpoly
?geom_density
?geom_boxplot
?geom_histogram

#1.2.
ggplot(data=mpg)

#1.3.
print(mpg)
dim(mpg)
str(mpg)
nrow(mpg)
ncol(mpg)

#1.4.
?mpg

#1.5.
?mpg

#1.6.
ggplot(data=mpg) +
  geom_point(mapping=aes(x=cyl,y=hwy))
ggplot(data=mpg) +
  geom_boxplot(mapping=aes(x=as.factor(cyl),y=hwy))
library("hexbin")
ggplot(data=mpg) +
  geom_hex(mapping=aes(x=cyl,y=hwy))

#1.7.
print(diamonds)
dim(diamonds)
str(diamonds)
nrow(diamonds)
ncol(diamonds)

#1.8.
ggplot(data=diamonds) +
  geom_bar(mapping=aes(x=cut,fill=color),position="fill")

#1.9.
ggplot(data=diamonds) +
  geom_boxplot(mapping=aes(x=color,y=price))
ggplot(data=diamonds) +
  geom_freqpoly(mapping=aes(x=price,y=..density..,color=color),binwidth=500)


// Generate n random networks using the igraph package and save edge lists. Also saves a list of attributes
// for each random network generated.
// Parameters
// n: # of networks
// Example execution: genrand50 100

genrand50<-function(n) {
nodes<-numeric(n)
edges<-numeric(n)
extraZero<-"00"
for (i in 1:n) {
  if (i < 100 & i > 9) {
    extraZero <- "0"
  }
  if (i >= 100) {
    extraZero <- ""
  }
  net<-paste("rand_", extraZero ,i,".txt",sep="")
  g<-erdos.renyi.game(50,0.05,directed=TRUE)
  nodes[i]<-vcount(g)
  edges[i]<-ecount(g)
  write.graph(g, net, "edgelist")
}
data<-data.frame(nodes, edges)
write.table(data, "attributes.txt", sep="\t", row.names = FALSE, col.names = FALSE)
}


# If you use this code or parts of it, please cite the following paper
# Bruhin A., E. Fehr, D. Schunk (2018): "The Many Faces of Human Sociality: Uncovering the Distribution and Stability of Social Preferences",
# Journal of the European Economic Association, forthcoming.
# ===========================================================================================================================================

rm(list=ls()) # Clear the memory
source("99_estim_functions_aggregate_individual.r") # Load the required functions for performing the estimations
set.seed(51)

# SESSION 1
cat("\n---- SESSION 1 -------------\n")

dat     <- read.table("choices_exp1.csv",  sep=",", header=T) # Load choice data
dropped <- read.table("dropped_subjects_section4paragraph2.csv", sep=",", header=F)[,1] # dropped subjects (see 2nd paragraph of section 4; to replicate estimate individual parameters)
dat     <- dat[(dat$sid %in% dropped) == F, ] # Eliminate dropped subjects

cat("\nEstimation Results without Clustered Standard Errors:\n\n")
pe.exp1 <- f.estim(dat, "choice_x", c("s_x","r_x","q","v"), c("s_y","r_y","q","v"), "self_x", "other_x", "self_y", "other_y", silent=F, comp.se=T) # Aggregate estimation

cat("\nEstimation Results with Clustered Standard Errors:\n")
clust.exp1 <- f.clusterse(pe.exp1, dat, "choice_x", "self_x", "other_x", "self_y", "other_y", c("s_x","r_x","q","v"), c("s_y","r_y","q","v"), "sid")

write.table(pe.exp1$out[,1],"svExp1_1cl.csv",col.names=F, row.names=F) # Save point estimates as start values for finite mixture model

# SESSION 2
cat("\n---- SESSION 2 -------------\n")

dat     <- read.table("choices_exp2.csv",  sep=",", header=T) # Load choice data
dropped <- read.table("dropped_subjects_section4paragraph2.csv", sep=",", header=F)[,1] # dropped subjects (see 2nd paragraph of section 4; to replicate estimate individual parameters)
dat     <- dat[(dat$sid %in% dropped) == F, ] # Eliminate dropped subjects

cat("\nEstimation Results without Clustered Standard Errors:\n\n")
pe.exp2 <- f.estim(dat, "choice_x", c("s_x","r_x","q","v"), c("s_y","r_y","q","v"), "self_x", "other_x", "self_y", "other_y", silent=F, comp.se=T) # Aggregate estimation

cat("\nEstimation Results with Clustered Standard Errors:\n")
clust.exp2 <- f.clusterse(pe.exp2, dat, "choice_x", "self_x", "other_x", "self_y", "other_y", c("s_x","r_x","q","v"), c("s_y","r_y","q","v"), "sid")

write.table(pe.exp2$out[,1],"svExp2_1cl.csv",col.names=F, row.names=F) # Save point estimates as start values for finite mixture model


#install.packages('holdem', repos='http://cran.us.r-project.org')
#install.packages('caret', repos='http://cran.us.r-project.org',dependencies = T)
library(caret)
#library(IRdisplay)
#options(jupyter.plot_mimetypes = 'image/png')

library(e1071)
library(cowplot)
library(gbm)
#install.packages('mxnet', repos='http://cran.us.r-project.org')
library(mxnet)

sink("v3runoutput.txt", append=TRUE,split=TRUE)

as.numeric.factor <- function(x) {as.numeric(levels(x))[x]}

#source('https://bioconductor.org/biocLite.R')
#biocLite("EBImage")
#library(EBImage)

# Set seed for reproducibility
mx.set.seed(100)

print("Loading Data...")
hands<-read.fwf(file='hand_data//npdata_5M.txt',widths=c(rep(1,53)))

print("Preparing Data as imagettes...")

hands[] <- lapply(hands, as.numeric)
colnames(hands)[names(hands) == 'V53']<-"score"
#str(hands)

intrain<-createDataPartition(y=hands$score,p=0.8,list=FALSE)
training<-hands[intrain,]
testing<-hands[-intrain,]

training <-data.matrix(training)

#We want to move the card data down to the middle of the image array for processing in the neural network
#This shifts the data to the mid-point of the image
leftzeros <- matrix(0, ncol = 98, nrow = nrow(training))
midcolumn <- matrix(0, ncol = 3, nrow = nrow(training))
rightzeros <- matrix(0, ncol = 97, nrow = nrow(training))

#Paste the zeros in the right places to make this work as a 28 by 28 array and then reshape for training
training2 <- cbind(leftzeros,training[,1:13],midcolumn,
                   training[,14:26],midcolumn,
                   training[,27:39],midcolumn,
                   training[,40:52],rightzeros)
train2<-t(data.matrix(training2))
train_array <-train2
dim(train_array)<-c(16,16,1,ncol(train2))
train_y <-training[,53]

#print(training[30005,])
#display(Image(train_array[,,,30005],dim=c(16,16)))

testing <-data.matrix(testing)
#Do the same thing with the test array
leftzeros <- matrix(0, ncol = 98, nrow = nrow(testing))
midcolumn <- matrix(0, ncol = 3, nrow = nrow(testing))
rightzeros <- matrix(0, ncol = 97, nrow = nrow(testing))

#Paste the zeros in the right places to make this work as a 28 by 28 array and then reshape for training
testing2 <- cbind(leftzeros,testing[,1:13],midcolumn,
                   testing[,14:26],midcolumn,
                   testing[,27:39],midcolumn,
                   testing[,40:52],rightzeros)
testing2<-t(data.matrix(testing2))
test_array <-testing2
dim(test_array)<-c(16,16,1,ncol(testing2))
test_y <-testing[,53]

print(table(train_y))
print(table(test_y))

# Set up the symbolic model
#-------------------------------------------------------------------------------

data <- mx.symbol.Variable('data')
# 1st convolutional layer
conv_1 <- mx.symbol.Convolution(data = data, kernel = c(5, 5), num_filter = 20)
tanh_1 <- mx.symbol.Activation(data = conv_1, act_type = "tanh")
pool_1 <- mx.symbol.Pooling(data = tanh_1, pool_type = "max", kernel = c(2, 2), stride = c(2, 2))
# 2nd convolutional layer
conv_2 <- mx.symbol.Convolution(data = pool_1, kernel = c(5, 5), num_filter = 50)
tanh_2 <- mx.symbol.Activation(data = conv_2, act_type = "tanh")
pool_2 <- mx.symbol.Pooling(data=tanh_2, pool_type = "max", kernel = c(2, 2), stride = c(2, 2))
# 1st fully connected layer
flatten <- mx.symbol.Flatten(data = pool_2)
fc_1 <- mx.symbol.FullyConnected(data = flatten, num_hidden = 500)
tanh_3 <- mx.symbol.Activation(data = fc_1, act_type = "tanh")
# 2nd fully connected layer
fc_2 <- mx.symbol.FullyConnected(data = tanh_3, num_hidden = 40)
# Output. Softmax output since we'd like to get some probabilities.
NN_model <- mx.symbol.SoftmaxOutput(data = fc_2)

# Pre-training set up
#-------------------------------------------------------------------------------

# Device used. CPU in my case.

n.gpu<-4
devices <- lapply(0:(n.gpu-1), function(i) {
  mx.gpu(i)
})

#devices <- c(mx.gpu(0),mx.gpu(1))

# Training
#-------------------------------------------------------------------------------

# Train the model
model <- mx.model.FeedForward.create(NN_model,
                                     X = train_array,
                                     y = train_y,
                                     ctx = devices,
                                     num.round = 600,
                                     array.batch.size = 4000,
                                     learning.rate = 0.01,
                                     momentum = 0.9,
                                     eval.metric = mx.metric.accuracy,
                                     epoch.end.callback = mx.callback.log.train.metric(100))

# Testing
#-------------------------------------------------------------------------------

# Predict labels
predicted <- predict(model, test_array)
# Assign labels
predicted_labels <- max.col(t(predicted)) - 1
# Get accuracy
sum(diag(table(test_y, predicted_labels)))/40

print(table(test_y))
print(table(predicted_labels))

u = union(predicted_labels, test_y)
t = table(factor(predicted_labels, u), factor(test_y, u))
print(confusionMatrix(t))

mx.model.save(model, 'pokerhands5M_3.model', 600)

newmodel <- mx.model.FeedForward.create(model$symbol,
                                     X = train_array,
                                     y = train_y,
                                     ctx = mx.cpu(),
                                     num.round = 1,
                                     array.batch.size = 4000,
                                     learning.rate = 0.01,
                                     momentum = 0.9,
                                     eval.metric = mx.metric.accuracy,
                                     epoch.end.callback = mx.callback.log.train.metric(100),
				     arg.params=model$arg.params,
				     aux.params=model$aux.params)

mx.model.save(newmodel, 'pokerhands5M_3_cpu.model', 601)


pdf_file<-"pdf/tablecharts_treemap_2b_inc.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11.69,height=7.5)

par(omi=c(0.65,0.25,1.25,0.75),mai=c(0.3,2,0.35,0),family="Lato Light",las=1)
library(treemap)
library(RColorBrewer)

# Daten einlesen und Grafik vorbereiten

load("myData/hnp.RData")
myData<-subset(daten,daten$gni>0)
attach(myData)
kgni<-cut(gni,c(0,40000,80000))
levels(kgni)<-c("low","middle","high")
myData$kgni<-kgni
myData$nkgni<-as.numeric(kgni)

# Grafik definieren und weitere Elemente

plot(1:1,type="n",axes=F)
treemap(myData,title="",index=c("kontinent","iso3"), vSize="pop",vColor="nkgni",type="value",palette="Blues",aspRatio=2.5,fontsize.labels=c(0.1,20),position.legend="none")
legend(0.35,0.6,levels(kgni)[1:3],cex=1.65,ncol=3,border=F,bty="n",fill= brewer.pal(9,"Blues")[7:9],text.col="black",xpd=NA)

# Betitelung

mtext("Within Continent: Country Level",3,line=2,adj=0,cex=2.4,outer=T,family="Lato Black")
mtext("Size: population - Colour: GNI per capita. Atlas method (current US $), 2010",3,line=0,adj=0,cex=1.75,outer=T,font=3)
mtext("Source: data.wordlbank.org",1,line=1,adj=1.0,cex=1.25,outer=T,font=3)
dev.off()


setwd(file.path(paste0(mainDataDir, subDir)))

tnmc=length(keep.samples)

if(plot.lower==TRUE)theta=array(NA,c(n.chains,n.pars,S,tnmc))
if(plot.weights==TRUE)weights=array(NA,c(n.chains,S,tnmc))

for(q in 1:n.chains){
if(plot.lower==TRUE){
for(j in 1:S){
temp=t(as.matrix(read.table(paste("chain",q,"_sub",j,"_lower.txt",sep=""),header=F)))
theta[q,,j,]=temp[,1:tnmc]
}}
if(plot.weights==TRUE){
temp=t(as.matrix(read.table(paste("chain",q,"_weights.txt",sep=""),header=F)))
weights[q,,]=temp[,1:tnmc]
}
print(round(q/n.chains*100))
}

setwd(file.path(mainDir))

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

breaks=50

if(plot.lower==TRUE){
#par(mfrow=c(2,2),ask=T)
for(j in 1:S){
for(k in 1:n.pars){
matplot(t(theta[,k,j,start:tnmc]),type="l",lty=1,main=paste("Subject ",j),ylab=par.names[k])
#abline(h=true$vec[k],lwd=3)
hist(theta[,k,j,start:tnmc],prob=T,breaks=breaks,main=paste("Subject ",j),xlab=par.names[k])
#abline(v=true$vec[k],lwd=3,col="red")
}}}

if(plot.weights==TRUE){
#par(mfrow=c(2,2),ask=T)
for(j in 1:S){
matplot(t(weights[,j,start.weights:tnmc]),type="l",lty=1,main=paste("Subject ",j),ylab="log likelihood")
}}


rm(list=ls())

file_entire_collection  <- commandArgs()[4]
file_perbatch <- commandArgs()[5]
FDR_index_remove_variants  <- as.integer(commandArgs()[6])+1

# ------------------------------------------- #
# -- SNP QCI: HWE across entire collection -- #
# ------------------------------------------- #

fdr.hwe.allbatches  <- read.table(file=paste(file_entire_collection, sep=""), header=T)

fdr  <- -log10(fdr.hwe.allbatches$FDR)
pval <- -log10(fdr.hwe.allbatches$HWE_pval_worstbatchremoved)

png(file=paste(file_entire_collection, ".png", sep=""), width=720, height=720)

plot(fdr, fdr.hwe.allbatches$Fail_worstbatchremoved/1000, xlim=c(1,10), ylim=c(0,40), xlab="-log10(FDR threshold)", ylab="# SNPs failed (x 1,000)", pch=17, col="black", type="b", xaxt="n", cex=1.5)
lines(fdr, fdr.hwe.allbatches$Fail_allbatches/1000, type="b", pch=20, col="black", cex=1.5)
axis(1, at=seq(1,10,by=1), labels=fdr)
axis(3, at=seq(1,10,by=1), labels=round(pval, digits=1), xlab="")
mtext("-log10(p-value threshold)", side=3, line=2.5)
legend("topright", legend=c("All batches","Worst batch removed"), pch=c(20,17), col=c("black","black"), text.col=rep("black", 2), bty="y", inset=.05, cex=1.5)

# FDR threshold
lines(x=c(FDR_index_remove_variants,FDR_index_remove_variants), y=c(0,25), lty=2, col="red")
text(fdr[FDR_index_remove_variants], fdr.hwe.allbatches$Fail_worstbatchremoved[FDR_index_remove_variants]/1000, labels=c(fdr.hwe.allbatches$Fail_worstbatchremoved[FDR_index_remove_variants]/1000), pos=4)

dev.off()

# --------------------------------- #
# -- SNP QCI: HWE for each batch -- #
# --------------------------------- #

fdr.hwe.perbatch    <- read.table(file=paste(file_perbatch, sep=""), header=T)

fdr  <- -log10(fdr.hwe.perbatch$FDR)

png(file=paste(file_perbatch, ".png", sep=""), width=720, height=720)

plot(fdr, fdr.hwe.perbatch$Fail_2plusbatches/1000, xlim=c(1,10), ylim=c(0,25), xlab="-log10(FDR threshold)", ylab="# SNPs failed (x 1,000)", pch=17, col="black", type="b", xaxt="n", cex=1.5)
axis(1, at=seq(1,10,by=1), labels=fdr)
legend("topright", legend=c("Fail in 2+ batches"), pch=c(17), col=c("black"), text.col=rep("black"), bty="y", inset=.05, cex=1.5)
mtext("corresponding -log(p-values thresholds) different for any batch", side=3, line=1.5)

# FDR threshold
lines(x=c(FDR_index_remove_variants,FDR_index_remove_variants), y=c(0,25), lty=2, col="red")
text(fdr[FDR_index_remove_variants], fdr.hwe.perbatch$Fail_2plusbatches[FDR_index_remove_variants]/1000, labels=c(fdr.hwe.perbatch$Fail_2plusbatches[FDR_index_remove_variants]/1000), pos=4)

dev.off()


#' @export
#' @title devianceGLM
#' @description couldn't accurately describe
#' @family statistical
#' @param \code{x} the glm model object
#' @param \code{data}
#' @param \code{test} defaults to FALSE
#' @param \code{digits} defaults to 2
#' @return \code{result}
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
devianceGLM <- function (x, data=NULL, test = "F", digits = 2) {
        if(is.null(data)) data = x$data
    #deviance explained by glm model
    nexpl <- x$deviance
    tot <- x$null.deviance
    expl <- tot - nexpl
    ratio <- round((expl/tot * 100), digits = digits)
    expl <- round(expl, digits = digits)
    tot <- round(tot, digits = digits)
    cat("Deviance explained: ", expl, "/", tot, "(", ratio, "percent)\n\n")
    formula0 <- paste(names(x$model)[1], "~ 1")
    model0 <- glm(as.formula(formula0), family = x$family, data = na.omit(data))
    result <- anova(model0, x, test = test)
    return(result)
    }


#  James Rekow

isDisconnectedSubgraph = function(vVec, g){

  #  ARGS: vVec - numerical vector of vertices
  #        g - graph
  #
  #  RETURNS: TRUE if the subgraph of g formed by the vertices in vVec has no edges, FALSE otherwise

  #  NOTE: this function is meant primarily for testing purposes, not for use
  #        in other functions, as it is probably too slow to apply many times.

  subgraph = induced.subgraph(g, vVec)

  adjMat = as.matrix(get.adjacency(subgraph))

  disconnected = all(adjMat == 0)

  return(disconnected)

} #  end isCompletelyDisconnected function


library(rgl)
x <- c(-1, -1, 1)
y <- c(0, -1, -1)
z <- c(0, 0, 0)
M <- cbind(x,y,z)
rgl.bg(color="gray15")
triangles3d(M, col=rainbow(8))


#!/usr/bin/Rscript

# plots the value size distribution of Facebook workload based on the paper
# "Workload Analysis of a Large-Scale Key-Value Store"

library(ggplot2)
library(gridExtra)
RTT <- 7.75e-6 #seconds
C <- 1e10 #Gb/s

ETHERNET_PREAMBLE_SIZE <- 8
ETHERNET_HDR_SIZE <- 14
MAX_ETHERNET_PAYLOAD_BYTES <- 1500
MIN_ETHERNET_PAYLOAD_BYTES <- 46
IP_HEADER_SIZE <- 20
UDP_HEADER_SIZE <- 8
ETHERNET_CRC_SIZE <- 4
INTER_PKT_GAP <- 12
HOMA_HDR_SIZE <- 16

msgSizeOnWire <- function(msgDataBytes)
{
    bytesOnWire <- 0
    maxDataInHomaPkt <- MAX_ETHERNET_PAYLOAD_BYTES - IP_HEADER_SIZE
            - UDP_HEADER_SIZE - HOMA_HDR_SIZE

    numFullPkts <- msgDataBytes %/%  maxDataInHomaPkt
    bytesOnWire <- bytesOnWire + numFullPkts * (MAX_ETHERNET_PAYLOAD_BYTES + ETHERNET_HDR_SIZE
            + ETHERNET_CRC_SIZE + ETHERNET_PREAMBLE_SIZE + INTER_PKT_GAP)
    numPartialBytes <- msgDataBytes - numFullPkts * maxDataInHomaPkt

    ## if all msgDataBytes fit in full pkts, we should return at this point
    if ((numFullPkts > 0) & (numPartialBytes == 0)) {
        return (bytesOnWire)
    }
    numPartialBytes <- numPartialBytes +  HOMA_HDR_SIZE + IP_HEADER_SIZE +
            UDP_HEADER_SIZE

    if (numPartialBytes < MIN_ETHERNET_PAYLOAD_BYTES) {
        numPartialBytes <- MIN_ETHERNET_PAYLOAD_BYTES
    }
    numPartialBytesOnWire <- numPartialBytes + ETHERNET_HDR_SIZE +
            ETHERNET_CRC_SIZE + ETHERNET_PREAMBLE_SIZE + INTER_PKT_GAP

    bytesOnWire <- bytesOnWire + numPartialBytesOnWire
    return (bytesOnWire)
}

maxUnsched <- RTT*C/8
unschedVec <- seq(0, 2*maxUnsched, maxUnsched/1000)

getUnschedFrac <- function(prob, msgSizes)
{
    unschedFrac <- c()
    for (unsched in unschedVec) {
        unschedFrac <- c(unschedFrac, sum(prob*sapply(pmin(unsched, msgSizes), msgSizeOnWire)))
    }
    unschedFrac <- unschedFrac / sum(prob*sapply(msgSizes, msgSizeOnWire))
    return(unschedFrac)
}
unschedFracFrame <- data.frame(Unsched=c(), CumUnschedFrac=c(), Workload=c())

predefProb <- read.table("FacebookKeyValueMsgSizeDist.txt", col.names=c('msgSize', 'CDF'), skip=1)
x<-10^(seq(log10(tail(predefProb$msgSize, 1) + 1), log10(100000), length.out=300))
sigma <- 214.476
k <- 0.348238
y0 <- 0.47
x0 <- 15
y<-(1-(1+k*(x-x0)/sigma)^(-1/k))*(1-y0)+y0
value <- c(predefProb$msgSize,x)
cumProb <- c(predefProb$CDF, y)
prob = cumProb-c(0,cumProb[1:length(cumProb)-1])
byteFrac = prob*sapply(value, msgSizeOnWire)
cumBytes <- cumsum(byteFrac)/sum(byteFrac)
cdfFrame <- data.frame(MessageSize=value, CDF=cumProb, CBF=cumBytes,
        WorkLoad="Facebook KeyValue-Servers")
unschedFracFrame <- rbind(unschedFracFrame,
    data.frame(Unsched=unschedVec, CumUnschedFrac=getUnschedFrac(prob, value),
    Workload="Facebook KeyValue-Servers"))

predefProb <- read.table("DCTCP_MsgSizeDist.txt", col.names=c('MessageSize', 'CDF'), skip=1)
predefProb$MessageSize <-  predefProb$MessageSize*1500
predefProb <- rbind(data.frame(MessageSize=c(0,predefProb$MessageSize[1]-1), CDF=c(0,0)), predefProb)
predefProb$WorkLoad <- "Web Search"
prob = predefProb$CDF-c(0,predefProb$CDF[1:length(predefProb$CDF)-1])
byteFrac = prob * sapply(predefProb$MessageSize, msgSizeOnWire)
cumBytes <- cumsum(byteFrac)/sum(byteFrac)
predefProb$CBF <- cumBytes
cdfFrame <- rbind(predefProb, cdfFrame)
unschedFracFrame <- rbind(unschedFracFrame,
    data.frame(Unsched=unschedVec, CumUnschedFrac=getUnschedFrac(prob, predefProb$MessageSize),
    Workload="Web Search"))

predefProb <- read.table("Facebook_CacheFollowerDist_IntraCluster.txt",
        col.names=c('MessageSize', 'CDF'), skip=1)
predefProb <- rbind(data.frame(MessageSize=c(0,predefProb$MessageSize[1]-1), CDF=c(0,0)), predefProb)
predefProb$WorkLoad <- "Facebook Cache-Servers"
prob = predefProb$CDF-c(0,predefProb$CDF[1:length(predefProb$CDF)-1])
byteFrac = prob * sapply(predefProb$MessageSize, msgSizeOnWire)
cumBytes <- cumsum(byteFrac)/sum(byteFrac)
predefProb$CBF <- cumBytes
cdfFrame <- rbind(predefProb, cdfFrame)
unschedFracFrame <- rbind(unschedFracFrame,
    data.frame(Unsched=unschedVec, CumUnschedFrac=getUnschedFrac(prob, predefProb$MessageSize),
    Workload="Facebook Cache-Servers"))

predefProb <- read.table("Facebook_WebServerDist_IntraCluster.txt",
        col.names=c('MessageSize', 'CDF'), skip=1)
predefProb <- rbind(data.frame(MessageSize=c(0,predefProb$MessageSize[1]-1), CDF=c(0,0)), predefProb)
predefProb$WorkLoad <- "Facebook Web-Servers"
prob = predefProb$CDF-c(0,predefProb$CDF[1:length(predefProb$CDF)-1])
byteFrac = prob * sapply(predefProb$MessageSize, msgSizeOnWire)
cumBytes <- cumsum(byteFrac)/sum(byteFrac)
predefProb$CBF <- cumBytes
cdfFrame <- rbind(predefProb, cdfFrame)
unschedFracFrame <- rbind(unschedFracFrame,
    data.frame(Unsched=unschedVec, CumUnschedFrac=getUnschedFrac(prob, predefProb$MessageSize),
    Workload="Facebook Web-Servers"))

predefProb <- read.table("Facebook_HadoopDist_All.txt",
        col.names=c('MessageSize', 'CDF'), skip=1)
predefProb <- rbind(data.frame(MessageSize=c(0,predefProb$MessageSize[1]-1), CDF=c(0,0)), predefProb)
predefProb$WorkLoad <- "Facebook Hadoop-Servers"
prob = predefProb$CDF-c(0,predefProb$CDF[1:length(predefProb$CDF)-1])
byteFrac = prob * sapply(predefProb$MessageSize, msgSizeOnWire)
cumBytes <- cumsum(byteFrac)/sum(byteFrac)
predefProb$CBF <- cumBytes
cdfFrame <- rbind(predefProb, cdfFrame)
unschedFracFrame <- rbind(unschedFracFrame,
    data.frame(Unsched=unschedVec, CumUnschedFrac=getUnschedFrac(prob, predefProb$MessageSize),
    Workload="Facebook Hadoop-Servers"))

predefProb <- read.table("Fabricated_Heavy_Middle.txt",
        col.names=c('MessageSize', 'CDF'), skip=1)
predefProb <- rbind(data.frame(MessageSize=c(0,predefProb$MessageSize[1]-1), CDF=c(0,0)), predefProb)
predefProb$WorkLoad <- "Fabricated Heavy Middle"
prob = predefProb$CDF-c(0,predefProb$CDF[1:length(predefProb$CDF)-1])
byteFrac = prob * sapply(predefProb$MessageSize, msgSizeOnWire)
cumBytes <- cumsum(byteFrac)/sum(byteFrac)
predefProb$CBF <- cumBytes
cdfFrame <- rbind(predefProb, cdfFrame)
unschedFracFrame <- rbind(unschedFracFrame,
    data.frame(Unsched=unschedVec, CumUnschedFrac=getUnschedFrac(prob, predefProb$MessageSize),
    Workload="Fabricated Heavy Middle"))

predefProb <- read.table("Google_SearchRPC.txt",
        col.names=c('MessageSize', 'CDF'), skip=1)
predefProb <- rbind(data.frame(MessageSize=c(0,predefProb$MessageSize[1]-1), CDF=c(0,0)), predefProb)
predefProb$WorkLoad <- "Google Search RPC"
prob = predefProb$CDF-c(0,predefProb$CDF[1:length(predefProb$CDF)-1])
byteFrac = prob * sapply(predefProb$MessageSize, msgSizeOnWire)
cumBytes <- cumsum(byteFrac)/sum(byteFrac)
predefProb$CBF <- cumBytes
cdfFrame <- rbind(predefProb, cdfFrame)
unschedFracFrame <- rbind(unschedFracFrame,
    data.frame(Unsched=unschedVec, CumUnschedFrac=getUnschedFrac(prob, predefProb$MessageSize),
    Workload="Google Search RPC"))

predefProb <- read.table("Google_AllRPC.txt",
        col.names=c('MessageSize', 'CDF'), skip=1)
predefProb <- rbind(data.frame(MessageSize=c(0,predefProb$MessageSize[1]-1), CDF=c(0,0)), predefProb)
predefProb$WorkLoad <- "Google All RPC"
prob = predefProb$CDF-c(0,predefProb$CDF[1:length(predefProb$CDF)-1])
byteFrac = prob * sapply(predefProb$MessageSize, msgSizeOnWire)
cumBytes <- cumsum(byteFrac)/sum(byteFrac)
predefProb$CBF <- cumBytes
cdfFrame <- rbind(predefProb, cdfFrame)
unschedFracFrame <- rbind(unschedFracFrame,
    data.frame(Unsched=unschedVec, CumUnschedFrac=getUnschedFrac(prob, predefProb$MessageSize),
    Workload="Google All RPC"))

predefProb <- read.table("Fabricated_Heavy_Head.txt",
        col.names=c('MessageSize', 'CDF'), skip=1)
predefProb <- rbind(data.frame(MessageSize=c(0,predefProb$MessageSize[1]-1), CDF=c(0,0)), predefProb)
predefProb$WorkLoad <- "Fabricated Heavy Head"
prob = predefProb$CDF-c(0,predefProb$CDF[1:length(predefProb$CDF)-1])
byteFrac = prob * sapply(predefProb$MessageSize, msgSizeOnWire)
cumBytes <- cumsum(byteFrac)/sum(byteFrac)
predefProb$CBF <- cumBytes
cdfFrame <- rbind(predefProb, cdfFrame)
unschedFracFrame <- rbind(unschedFracFrame,
    data.frame(Unsched=unschedVec, CumUnschedFrac=getUnschedFrac(prob, predefProb$MessageSize),
    Workload="Fabricated Heavy Head"))

cdfFrame$WorkLoad <- factor(cdfFrame$WorkLoad)
cdfCbf = list()
cdfCbf[[1]] <- ggplot(cdfFrame, aes(x=MessageSize,y=CDF)) +
        geom_line(aes(color=WorkLoad), size = 2, alpha = 1) +
        labs(title = "Message Size Distribution Used In Simulation") +
        theme(axis.text=element_text(size=30),
            axis.title=element_text(size=30, face="bold"),
            panel.grid.major =
                element_line(size = 0.75, linetype = 'solid', colour = "black"),
            panel.grid.minor =
                element_line(size = 0.5, linetype = 'solid', colour = "gray"),
            legend.text=element_text(size=30),
            legend.title=element_text(size=20, face="bold"),
            legend.position="top",
        plot.title = element_text(size=20, face="bold")) +
        scale_x_log10("Message Sizes (Bytes)")+
        scale_y_continuous(breaks = round(seq(min(cdfFrame$CDF), max(cdfFrame$CDF), by = 0.1),1))

cdfCbf[[2]] <- ggplot(cdfFrame, aes(x=MessageSize,y=CBF)) +
        geom_line(aes(color=WorkLoad), size = 2, alpha = 1) +
        labs(title = "Message Byte Distribution Used In Simulation") +
        theme(axis.text=element_text(size=30),
            axis.title=element_text(size=30, face="bold"),
            panel.grid.major =
                element_line(size = 0.75, linetype = 'solid', colour = "black"),
            panel.grid.minor =
                element_line(size = 0.5, linetype = 'solid', colour = "gray"),
            legend.text=element_text(size=30),
            legend.title=element_text(size=20, face="bold"),
            legend.position="top",
        plot.title = element_text(size=20, face="bold")) +
        scale_x_log10("Message Sizes (Bytes)")+
        scale_y_continuous(breaks = round(seq(min(cdfFrame$CBF), max(cdfFrame$CBF), by = 0.1),1))

cdfCbf[[3]] <- ggplot(cdfFrame, aes(x=MessageSize, y=pmin(C*RTT*(1-CBF)/8, MessageSize))) +
        geom_line(aes(color=WorkLoad), size = 2, alpha = 1) +
        labs(title = "Upper bound for unsched bytes") +
        theme(axis.text=element_text(size=30),
            axis.title=element_text(size=30, face="bold"),
            panel.grid.major =
                element_line(size = 0.75, linetype = 'solid', colour = "black"),
            panel.grid.minor =
                element_line(size = 0.5, linetype = 'solid', colour = "gray"),
            legend.text=element_text(size=30),
            legend.title=element_text(size=20, face="bold"),
            legend.position="top",
        plot.title = element_text(size=20, face="bold")) +
        scale_x_log10("Message Sizes (Bytes)")+
        scale_y_continuous(breaks = seq(0, C*RTT/8, by = 0.1*C*RTT/8))

cdfCbf[[4]] <- ggplot(unschedFracFrame, aes(x=Unsched, y=CumUnschedFrac)) +
        geom_line(aes(color=Workload), size = 2, alpha = 1) +
        labs(title = "Fraction of transmitted bytes in unsched. pkts (normalized by the max)") +
        theme(axis.text=element_text(size=30),
            axis.title=element_text(size=30, face="bold"),
            panel.grid.major =
                element_line(size = 0.75, linetype = 'solid', colour = "black"),
            panel.grid.minor =
                element_line(size = 0.5, linetype = 'solid', colour = "gray"),
            legend.text=element_text(size=30),
            legend.title=element_text(size=20, face="bold"),
            legend.position="top",
        plot.title = element_text(size=20, face="bold")) +
        scale_x_log10("Unsched. Limit (Bytes)")+
        scale_y_continuous(breaks = seq(0, 1, by = 0.1))

png(file='WorkloadCDFsCBFs.png', width=3000, height=5000)
args.list <- list()
args.list <- c(cdfCbf, list(ncol=1))
do.call(grid.arrange, args.list)
dev.off()


# lsei
example(lsei)

# parsimonious (simplest) solution of mink diet problem
example(Minkdiet)
example(varsample)

# Chemtax by lsei
example(Chemtax)

# E.coli core metabolism
example(E_coli)


# By Yea-Hung Chen

# function for defining survival variables
define_survival_variables<-function(dd=ii){
  # convert all end dates to days
  end<-grep('\\.end$|^end$',names(dd),value=TRUE)
  dd[,end]<-lapply(end,function(ee){
    if(class(dd[,ee])=='Date'){
      ee<-as.numeric(dd[,ee]-dd$start)
      is.na(ee)<-(ee<0)
      ee
    }
  })
  # define end variables
  oend<-paste(ovar,'.end',sep='')
  cend<-c(paste(cvar,'.end',sep=''),'end')
  # define custom function for finding minimum
  cmin<-function(vv){
    if(sum(is.na(vv))==length(vv)){
      mm<-9999
      is.na(mm)<-TRUE
      mm
    } else { min(vv,na.rm=TRUE) }
  }
  # define survival variables
  dd$oend<-apply(dd[,oend,drop=FALSE],1,cmin)/365.25
  dd$cend<-apply(dd[,cend,drop=FALSE],1,cmin)/365.25
  dd$rend<-pmin(dd$oend,dd$cend,na.rm=TRUE)
  dd$o<-!is.na(dd$oend)&(dd$oend==dd$rend)
  # output data
  dd
}


#' crossprod
#'
#' Croddproducts.
#'
#' @details
#' If \code{y} is a numeric matrix, then \code{x} will be promoted to a numeric
#' matrix, and the return will therefore be numeric (not float).
#'
#' @param x
#' A float vector/matrix.
#' @param y
#' Either \code{NULL}, or a numeric/float matrix.
#'
#' @return
#' A float matrix (unless \code{y} is numeric; see details section).
#'
#' @examples
#' library(float)
#'
#' s = flrunif(10, 3)
#' crossprod(s)
#' tcrossprod(s)
#'
#' @useDynLib float R_crossprod_spm R_crossprod_spmspm R_tcrossprod_spm R_tcrossprod_spmspm
#' @name crossprod
#' @rdname crossprod
NULL

cp_float32 = function(x, y=NULL)
{
  if (is.float(x))
  {
    if (is.null(y))
      d = .Call(R_crossprod_spm, DATA(x))
    else if (is.float(y))
      d = .Call(R_crossprod_spmspm, DATA(x), DATA(y))
    else
      return(base::crossprod(dbl(x), y))
  }
  else if (is.matrix(x) && is.float(y))
    return(base::crossprod(x, dbl(y)))
  else
    return(base::crossprod(x, y))

  float32(d)
}

tcp_float32 = function(x, y=NULL)
{
  if (is.float(x))
  {
    if (is.null(y))
      d = .Call(R_tcrossprod_spm, DATA(x))
    else if (is.float(y))
      d = .Call(R_tcrossprod_spmspm, DATA(x), DATA(y))
    else
      return(base::tcrossprod(dbl(x), y))
  }
  else if (is.matrix(x) && is.float(y))
    return(base::tcrossprod(x, dbl(y)))
  else
    return(base::tcrossprod(x, y))

  float32(d)
}

#' @rdname crossprod
#' @export
setMethod("crossprod", signature(x="Mat", y="ANY"), cp_float32)

#' @rdname crossprod
#' @export
setMethod("tcrossprod", signature(x="Mat", y="ANY"), tcp_float32)


##biomass plots with polygon
spwn_ratio <- function (dat,color="light blue",main="Model 1c")
{
  titl<-"Spawning Biomass relative to unfished"
  typ <- "SSB_NoFishR"
  ylim=c(0,1.04)
  cl<-paste(color)
  attach(dat)
  Data<-get(typ)
  #windows(12,8)
  plot(Data[,1],Data[,2],
  ylim=ylim,
  main=main,
  type="l",lwd=2,
  xlab="Year",ylab=paste(titl),lab=c(10,10,7),xlim=c(min(Data[,1]),max(Data[,1])))
  x=c(Data[,1],Data[length(Data[,1]):1,1])
  y=c(Data[,4],Data[length(Data[,1]):1,5])
  polygon(x,y,col=cl,lty=3,border="grey")
  points(Data[,1],Data[,2],ylim=c(0,max(Data[,2]*1.5)),type="l",lwd=2)
  detach(dat)
}


## just an R-script

print("Hello World!")

print("I am a simple R Script and do whatever you want me do to")

rv = round(sqrt(1823489372))
print(paste("For instance, I may compute the square root of 1823489372 for you:", rv))


# Empirically check which soil depth is best to use

source("pixel-based/utils/load-sampling-data.r")

SoilDataT = st_read("../data/pixel-based/soil/soilgrids-raw.gpkg", "Training")
Training = LoadGlobalTrainingData()

TrainingAndCovars = merge(Training, as.data.frame(SoilDataT), by.x=c("x","y"), by.y=c("X", "Y"))
rm(SoilDataT, Training)

# Pure agriculture
Agri = TrainingAndCovars[TrainingAndCovars$crops == 100, ]
# Pure trees
Tree = TrainingAndCovars[TrainingAndCovars$tree == 100, ]
# Pure grass
Gras = TrainingAndCovars[TrainingAndCovars$grassland == 100, ]
# Pure shrub
Shrb = TrainingAndCovars[TrainingAndCovars$shrub == 100, ]

PrettyDepth = function(Depth)
{
    switch(Depth, "1"="0-5 cm", "2"="5-15cm", "3"="15-30 cm", "4"="30-60 cm", "5"="60-100 cm", "6"="100-200cm")
}

PlotSoilParam = function(Var, Depth)
{
    MyData = rbind(
        data.frame(value=Agri[[paste0(Var,".M.sl", Depth)]], type="crops"),
        #data.frame(value=Tree[[paste0(Var,".M.sl", Depth)]], type="trees"),
        data.frame(value=Gras[[paste0(Var,".M.sl", Depth)]], type="grass"),
        data.frame(value=Shrb[[paste0(Var,".M.sl", Depth)]], type="shrub"))

    boxplot(Agri[[paste0(Var,".M.sl", Depth)]],
            #Tree[[paste0(Var,".M.sl", Depth)]],
            Gras[[paste0(Var,".M.sl", Depth)]],
            Shrb[[paste0(Var,".M.sl", Depth)]],
            main=paste(Var, PrettyDepth(Depth)),
            names=c("Crop",
                    #"Tree",
                    "Grass",
                    "Shrub"))
    print(TukeyHSD(aov(value~type, MyData)))
}

# Most interesting covars: BLDFIE, AWCh/WWP, ORCDRC/OCSTHA
PlotSoilParam("BLDFIE", 1) # Big difference for trees, this is the biggest one
PlotSoilParam("BLDFIE", 2) # Biggest difference in grass vs crops
PlotSoilParam("BLDFIE", 3)
PlotSoilParam("BLDFIE", 4)
PlotSoilParam("BLDFIE", 5)
PlotSoilParam("BLDFIE", 6)

PlotSoilParam("ORCDRC", 1) # Small difference
PlotSoilParam("ORCDRC", 2) # Much bigger difference, mostly tree vs crop, but also biggest overall; grass vs crop
PlotSoilParam("ORCDRC", 3)
PlotSoilParam("ORCDRC", 4)
PlotSoilParam("ORCDRC", 5)
PlotSoilParam("ORCDRC", 6) # There is a difference between all three, but small

for (level in 1:6) { Agri[[paste0("PHIHOX.M.sl", level)]][Agri[[paste0("PHIHOX.M.sl", level)]] == 255] = NA }
for (level in 1:6) { Gras[[paste0("PHIHOX.M.sl", level)]][Gras[[paste0("PHIHOX.M.sl", level)]] == 255] = NA }
for (level in 1:6) { Shrb[[paste0("PHIHOX.M.sl", level)]][Shrb[[paste0("PHIHOX.M.sl", level)]] == 255] = NA }
for (level in 1:6) { Tree[[paste0("PHIHOX.M.sl", level)]][Tree[[paste0("PHIHOX.M.sl", level)]] == 255] = NA }

PlotSoilParam("PHIHOX", 1) # Largest difference overall, shrubs stand out
PlotSoilParam("PHIHOX", 2) # Good compromise
PlotSoilParam("PHIHOX", 3)
PlotSoilParam("PHIHOX", 4)
PlotSoilParam("PHIHOX", 5)
PlotSoilParam("PHIHOX", 6) # Technically largest difference between non-trees, shrubs very acidic

for (level in 1:6) { Agri[[paste0("PHIKCL.M.sl", level)]][Agri[[paste0("PHIKCL.M.sl", level)]] == 255] = NA }
for (level in 1:6) { Gras[[paste0("PHIKCL.M.sl", level)]][Gras[[paste0("PHIKCL.M.sl", level)]] == 255] = NA }
for (level in 1:6) { Shrb[[paste0("PHIKCL.M.sl", level)]][Shrb[[paste0("PHIKCL.M.sl", level)]] == 255] = NA }
for (level in 1:6) { Tree[[paste0("PHIKCL.M.sl", level)]][Tree[[paste0("PHIKCL.M.sl", level)]] == 255] = NA }

PlotSoilParam("PHIKCL", 1)
PlotSoilParam("PHIKCL", 2) # Biggest, but without trees increases going down; shrubs stand out
PlotSoilParam("PHIKCL", 3)
PlotSoilParam("PHIKCL", 4)
PlotSoilParam("PHIKCL", 5)
PlotSoilParam("PHIKCL", 6) # Even bigger, but not for shrubs

PlotSoilParam("AWCh1", 1) # Most are fine, shrub vs crop is indistinguishable
PlotSoilParam("AWCh1", 2)
PlotSoilParam("AWCh1", 3)
PlotSoilParam("AWCh1", 4)
PlotSoilParam("AWCh1", 5) # This is the best for non-trees, grass > crop
PlotSoilParam("AWCh1", 6)

PlotSoilParam("AWCh2", 1) # Gets successively worse
PlotSoilParam("AWCh2", 2) # Both the first two are good for all non-trees
PlotSoilParam("AWCh2", 3)
PlotSoilParam("AWCh2", 4)
PlotSoilParam("AWCh2", 5)
PlotSoilParam("AWCh2", 6)

PlotSoilParam("AWCh3", 1) # Same, less of a difference than AWCh2
PlotSoilParam("AWCh3", 2)
PlotSoilParam("AWCh3", 3)
PlotSoilParam("AWCh3", 4)
PlotSoilParam("AWCh3", 5)
PlotSoilParam("AWCh3", 6)

PlotSoilParam("WWP", 1) # Biggest difference
PlotSoilParam("WWP", 2)
PlotSoilParam("WWP", 3)
PlotSoilParam("WWP", 4)
PlotSoilParam("WWP", 5)
PlotSoilParam("WWP", 6)

# Layer 2 seems a good compromise


scVEGs <- function(data, pVal, pFlag, species, tmpName) {
  require(locfit)
  require(MASS)
  require(hydroGOF)
  require(calibrate)
  require(locfit)
  geneName <- rownames(data)
  infoFlag <- 1
  if (species == 'hsa') {
    geneLength <- read.delim('hg19_genes_length.tsv', header = TRUE, stringsAsFactors = TRUE)
  } else if (species == 'mmu') {
    geneLength <- read.delim('mm9_genes_length.tsv', header = TRUE, stringsAsFactors = TRUE)
  } else {
    print('no gene length information')
    infoFlag <- 0
  }
  # Calculate TPM
  if(infoFlag == 1) {
    rpk <- data
    gLength <- vector(mode="numeric", length=dim(data)[1])
    for (i in 1:dim(data)[1]) {
      dx <- which(geneLength$geneName == geneName[i])
      if(length(dx) > 0) {
        gLength[i] <- max(geneLength$geneLength[dx])
      } else {
        gLength[i] <- -1
      }
    }
    dx <- which(gLength == -1)
    rpk[dx, ] <- 0
    rpk <- rpk * 1000/kronecker(matrix(1, 1, dim(data)[2]), gLength)
    sscale <- apply(rpk, 2, sum)/10^6
    tpm <- rpk / kronecker(matrix(1, dim(data)[1], 1), sscale)
    flag <- matrix(0, dim(data)[1], dim(data)[2])
    flag[tpm >= 1] <- 1
    num <- apply(flag, 1, sum)
    ix <- which(num > 0.01*dim(data)[2])
    data <- data[ix, ]
    geneName <- geneName[ix]
  }

  m <- dim(data)[1]
  std <- apply(data, 1, sd)
  avg <- apply(data, 1, mean)
  cv <- std / avg
  # over dispersion sigma  (var = u(1 + u * sigma^2))
  rm(tpm)
  rm(flag)
  xdata <- (avg)
  ydata <- log10(cv)
  xdata <- xdata[is.na(ydata) != "TRUE"]
  ydata <- ydata[is.na(ydata) != "TRUE"]

  fitLoc <- locfit.robust(ydata ~ lp(log10(xdata), nn = .2))
  xSeq <- seq(min(log10(xdata)), max(log10(xdata)), 0.005)
  gapNum <- matrix(0, length(xSeq), 1)
  for(i in 1:length(xSeq)) {
    cdx <- which((log10(xdata) >= xSeq[i] - 0.05) & (log10(xdata) < xSeq[i] + 0.05))
    gapNum[i,1] <- length(cdx)
  }
  cdx <- which(gapNum > m*0.005)
  xSeq <- 10 ^ xSeq
  ySeq <- predict(fitLoc,log10(xSeq))
  yDiff <- diff(ySeq)
  ix <- which(yDiff > 0 & log10(xSeq[-1]) > 0)
  if(length(ix) == 0)
  ix <- length(ySeq) - 1
  xSeq_all <- 10^seq(min(log10(xdata)), max(log10(xdata)), 0.001)
  xSeq <- xSeq[cdx[1]:ix[1] + 1]
  ySeq <- ySeq[cdx[1]:ix[1] + 1]

  b <- 1
  a <- 0
  df <- data.frame(x=xSeq, y = ySeq)
  fit = nls(y ~ 0.5 * log10(b / x + a), data = df,
            start=list(b = b,a = a), nls.control(maxiter = 500), na.action =  'na.exclude')
  newdf <- data.frame(x = xSeq_all)
  ydataFit <- predict(fit,newdata = newdf)

  # Calculate CV difference
  logX <- log10(xdata)

  logXseq <- log10(xSeq_all)
  cvDist <- matrix(0,length(xdata),1)
  for (i in 1:length(logX)) {
    cx <- which(logXseq >= logX[i] - 0.2 & logXseq < logX[i] + 0.2)
    tmp <- sqrt((logXseq[cx] - logX[i])^2 + (ydataFit[cx] - ydata[i])^2)
    tx <- which.min(tmp)

    if(logXseq[cx[tx]] > logX[i]) {
      if(ydataFit[cx[tx]] > ydata[i]) {
        cvDist[i] <- -1*tmp[tx]
      } else {
        cvDist[i] <- tmp[tx]
      }
      cvDist[i] <- -1*tmp[tx]
    } else if (logXseq[cx[tx]] <= logX[i]) {
      if(ydataFit[cx[tx]] < ydata[i]) {
        cvDist[i] <- tmp[tx]
      } else {
        cvDist[i] <- -1*tmp[tx]
      }
    }
  }
  cvDist <- log2(10^cvDist)

  # use kernel density estimate to find the peak
  dor <- density(cvDist, kernel = "gaussian")
  distMid <-dor$x[which.max(dor$y)]
  dist2 <- cvDist - distMid
  tmpDist <- c(dist2[dist2 <= 0], abs(dist2[dist2 < 0])) + distMid
  distFit <- fitdistr(tmpDist, "normal")
  pRaw <- pnorm(cvDist, mean = distFit$estimate[1], sd = distFit$estimate[2], lower.tail = FALSE)
  pAdj <- p.adjust(pRaw, 'hochberg')
  if (pFlag == 1) {
    dx <- which(pAdj < pVal)
  } else {
    dx <- which(pRaw < pVal)
  }

  # Plot CV-mean figure with 2 fitted lines
  filename <- paste(tmpName,"cv",sep="_")
  pdf_filename<-paste(filename,".pdf",sep="")
  pdf(pdf_filename)
  # eps_filename <- paste(filename,".eps",sep="")
  # setEPS()
  # postscript(eps_filename)
  plot(log10(avg), log10(cv), type = 'p', pch = 20, cex = 0.5)
  abline(0,-0.5)
  lines(log10(xSeq), ySeq, col = 'cyan3')
  lines(log10(xSeq_all), ydataFit, col = 'firebrick')
  points(log10(xdata[dx]), ydata[dx], type = 'p', pch = 20, cex = 0.5, col = 'palegreen3')
  textxy(-1.5, min(log10(cv), na.rm = TRUE) + 0.3,
         paste('alpha = ', round(coef(fit)[2], digit = 3), sep=''), cex = 1, offset = 0)
  textxy(-1.5, min(log10(cv), na.rm = TRUE) + 0.2,
         paste('beta = ', round(coef(fit)[1], digit = 3), sep=''), cex = 1, offset = 0)
  textxy(-1.5, min(log10(cv), na.rm = TRUE) + 0.1,
         paste('variable genes = ', length(dx), sep=''), cex = 1, offset = 0)
  dev.off()
  # plot CV difference histogram and fitted normal distribution
  filename <- paste(tmpName,"cvHist",sep="_")
  pdf_filename<-paste(filename,".pdf",sep="")
  pdf(pdf_filename)
#   eps_filename <- paste(filename,".eps",sep="")
#   setEPS()
#   postscript(eps_filename)
  hist(cvDist, freq = FALSE, breaks = 200, xlim = c(-1, 2), ylim = c(0, max(dor$y) + 1), xlab = "CV difference")
  du <- distFit$estimate[1]
  ds <- distFit$estimate[2]
  # curve(dnorm(x, mean = du, sd = ds)*max(dor$y)/dnorm(du, mean = du, sd = ds)
  #       , col = "red", add = TRUE)
  lines(dor$x, dnorm(dor$x, mean = du, sd = ds)*max(dor$y)/dnorm(du, mean = du, sd = ds)
        , col = "red")
  lines(dor, col = "blue")
  dev.off()
  sig <- data[dx, ]
  # curve(dgamma(x, shape = distFit$estimate[1], rate = distFit$estimate[2]), col = "red", add = TRUE)
}


## data prep functions

#' Interpolate air pressure for metabolism models
#'
#' In many cases we don't have air pressure precisely at the locations where other stream
#' metabolism measurements are made. This function takes as input pressure readings from weather
#' stations, along with desired output locations and times. Output is matrix, with output sites
#' in the rows, output times in the columns.
#'
#' `pressure` must be a data.frame with at least 3 columns, named:
#'      * 'station' (by default, or the value assigned to stn_id), station name
#' 		* 'pressure', pressure observations (hPa)
#' 		* 'time', a POSIXct column giving the times of measurements
#'
#' `stations`: Spatial object, in addition to locations has at least 2 columns, named:
#'      * 'station' (by default, or the value assigned to stn_id), station name
#' 		* 'elevation', Elevation (m) of the station
#'
#' It is recommended that the input air pressure data represent a continuous record with no
#' substantial gaps in the time series. If this is not the case, interpolation may be unreliable.
#'
#' Elevation is required for both control and output points so that corrections to air pressure
#' can be applied.
#'
#' @param pressure Data.frame required columns are 'station' 'pressure' (hPa), 'time' (see details)
#' @param stations Spatial (sp or sf), station locations where pressure was recorded (see details)
#' @param out_sites Spatial (sp or sf) object with output locations, 'elevation' is a required
#'  	column
#' @param out_times A list, with one element per out_site; each element is a vector of type
#'		POSIXct giving times at which to compute pressure
#' @param parallel Boolean, should we use multiple threads to speed computation? Mac/Linux only
#' @param stn_id Character, the column name where pressure station names are stored in both
#' 		`pressure` and `stations`
#' @param site_id Character or numeric, the column in out_sites where site names are stored
#' @param ... Additional parameters to pass to [approx()].
#'
#' @return A data frame with three columns: site name, time, and interpolated pressure
#' @export
interpolate_air_pressure = function(pressure, stations, out_sites, out_times,
			parallel = TRUE, stn_id = "station", site_id = "site", ...) {
	if(!is(stations, "sf"))
		stations = sf::st_as_sf(stations)
	if(!is(out_sites, "sf"))
		out_sites = sf::st_as_sf(out_sites)
	.check_pressure_args(pressure, stations, out_sites, out_times)

	do_pressure = function(i)
		.pr_site(pressure, stations, out_sites[i,], out_times[[i]], stn_id, site_id, ...)

	res = if(parallel && requireNamespace("parallel")) {
		parallel::mclapply(1:nrow(out_sites), do_pressure)
	} else {
		lapply(1:nrow(out_sites), do_pressure)
	}
	res = do.call(rbind, res)
	res
}

#' get a vector of pressure for a single site
#' @keywords internal
.pr_site = function(pr, st, si, times, stn_id, site_id, ...) {
	days = unique(lubridate::date(times))
	pr = pr[lubridate::date(pr$time) %in% days,]
	pr$elevation = st$elevation[match(pr[[stn_id]], st[[stn_id]])]

	# correct observed pressure to the elevation of the site
	pr$pressure_corr = pressureCorrection(pr$pressure, pr$elevation, si$elevation)
	pr_out = by(pr, pr[[stn_id]], function(x)
		approx(as.integer(x$time), x$pressure_corr, as.integer(times), ...)$y)
	pr_out = do.call(rbind, pr_out)
	dmat = sf::st_distance(st, si)
	rownames(dmat) = st[[stn_id]]
	dmat = dmat[rownames(pr_out),]
	res = data.frame(time= times, pressure = idw_matrix(pr_out, dmat))
	res[[site_id]] = si[[site_id]]
	res
}

#' Validate input data for the air pressure function
#' @keywords internal
.check_pressure_args = function(pressure, stations, out_sites, out_times) {
	if(!all(c("pressure", 'time') %in% names(pressure)))
		stop("pressure must be a data.frame with columns 'time' and 'pressure'")
	if(!all(c('elevation') %in% names(stations)))
		stop("stations must be a spatial object with 'elevation' column")
	if(length(out_times) != nrow(out_sites))
		stop("out_times must be a list with one element per site in out_sites")
	if(!is.POSIXct(pressure$time) | !all(sapply(out_times, is.POSIXct)))
		stop("pressure$time and all out_times elements must be of class POSIXct")
}


context("Calibration")
library("NSmetabolism")
library(rstan)
# library(lubridate)

test_that("One station calibration working", {
	skip_on_cran()
	dat = readRDS(system.file("testdata/do_calib.rds", package="NSmetabolism"))
	expect_error(mod <- onestation(dat$DO, dat$temp, dat$light, dat$pressure, dat$z, dat$delta_t, nsamples = 1000), regex=NA)
	pars = as.matrix(mod)
	expect_true(all(pars[,'er'] <= 0))
	expect_true(all(pars[, 'gpp'] >= 0))
})


library(cellrangerRkit)
context('Util')

gene_names = c('gene_a', 'gene_b', 'gene_c')
sample_names = c('sample_a', 'sample_b', 'sample_c')

test_matrix = Matrix(matrix(c(1,0,3,10,0,30,100,0,300), ncol=3))
row.names(test_matrix) = gene_names
colnames(test_matrix) = sample_names

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

test_samples = data.frame(barcode=sample_names)
row.names(test_samples) = test_samples$barcode

test_gbm <- newGeneBCMatrix(test_matrix, test_gene_matrix, test_samples)
test_genes <- get_nonzero_genes(test_gbm)

test_that("get_nonzero_genes gives correct result", {
  expect_equal(length(test_genes), 2)
  expect_equal(test_genes[1], 1)
  expect_equal(test_genes[2], 3)
})

pipestance_path <- system.file("extdata", "test_pipestance", package="cellrangerRkit")
filt_gbm <- load_cellranger_matrix(pipestance_path, barcode_filtered=T)

test_that("can get mean reads per cell", {
  get_mean_mapped_reads_per_cell(filt_gbm)
})


#' Population Pyramid in MSDem ??
#'
#' This function generates a pyramid for a cntry x Time
#' @param df1 with five colums age, sex (male/female), edu, varfacet,value
#' @param year year
#' @param area region
#' @param scen specific scenario
#' @param varfacet variable to be faceted
#' @popunit unit of value (default '000)
#' @caption Full list else year area scen will be pasted
#' @nmlegend  legends for 'edu' else variable's unique values will be used
#' @return pyramid
#' @keywords pyramid
#' @export
#' @examples
#' pyredufacet(df1=df1,year=2015,area="ARM",scen="Baseyear",nmlegend="Education")

pyredufacet <- function(df1,year,
                        area,
                        scen,
                        popunit = "Thousands",
                        caption=NULL,nmlegend,ipal=1,
                        ixlab="Age",
                        iylab="Population",
                        female_nm="female") {
  # df1 <<- df1
  # year
  # area
  # scen
  # popunit = "Thousands"
  # caption=NULL
  # nmlegend
  # ipal=1
  # ixlab="Age"
  # iylab="Population"
  # female_nm=female_nm

  # stop("")
  if(is.null(caption)) caption = paste(area,scen,year,sep="-")

  gg1 <-df1%>%arrange(age) %>%
    ggplot(mapping = aes(x = age,
                         y = ifelse(sex == female_nm, value, -value),
                         fill = edu)) +
    geom_bar(stat = "identity", position = "stack")+
    coord_flip()+facet_wrap(~varfacet)+
    ggtitle(caption) +
    labs(x = ixlab,
         y = iylab,
         fill = "Educational attainment")  +
    scale_fill_manual(name=legend.title,
                      breaks=edu.nm,
                      labels=legend.labels,
                      values=ipal,
                      guide = guide_legend(reverse = TRUE))+
    # scale_fill_brewer(name=nmlegend,type="seq",palette=ipal,guide = guide_legend(reverse = TRUE))+
    scale_y_continuous(labels = abs)+
    geom_hline(yintercept = 0, color = "black") + theme_bw()

  # #fixing the limits of pop
  # breaks <- ggplot_build(gg1)$layout$panel_params[[1]]$x$breaks
  # breaks <- breaks[!is.na(breaks)]
  #
  # absbreaks = abs(breaks)
  # lim.max = max(absbreaks)
  #
  #
  # lim.main = max(abs(ggplot_build(gg1)$layout$panel_params[[1]]$x.range))
  # lim.main  = ceiling(lim.main/max(unique(diff(breaks))))*max(unique(diff(breaks)))#had to add max as it was giving same value many times
  #
  #
  # if(length(absbreaks)%%2==0) {
  #   if(lim.max==absbreaks[1]){
  #     breaks = c(breaks,lim.max)
  #     absbreaks = abs(breaks)
  #   }else{
  #     breaks = c(-lim.max,breaks)
  #     absbreaks = abs(breaks)
  #   }
  # }
  #
  # limits = c(-lim.main,lim.main)
  #
  #
  # # if(length(absbreaks)%%2==0) {if(grep(lim.max,absbreaks)==1){
  # #    breaks = c(breaks,lim.max)
  # #    absbreaks = abs(breaks)
  # #   }else{
  # #     breaks = c(-lim.max,breaks)
  # #     absbreaks = abs(breaks)
  # #   }
  # # }
  #
  # # limits = c(-lim.max,lim.max)
  # print(gg1+scale_y_continuous(limits=limits,breaks=breaks,labels = absbreaks))

  print(gg1)
}


# Comparing pictures from literature with those made directly

# libs ----
library("Momocs")

# input ----
inNProf <- list.files("./Obr/Porovnani/Prof/", full.names = T)
inNSide <- list.files("./Obr/Porovnani/Side/", full.names = T)
inNTop <- list.files("./Obr/Porovnani/Top/", full.names = T)

inProf <- import_jpg(jpg.path = inNProf, auto.notcentered = TRUE,
                     threshold = 0.5, verbose = TRUE)

inSide <- import_jpg(jpg.path = inNSide, auto.notcentered = TRUE,
                     threshold = 0.5,verbose = TRUE)

inTop <- import_jpg(jpg.path = inNTop, auto.notcentered = TRUE,
                    threshold = 0.5, verbose = TRUE)

# fac ----
facSlot <- data.frame(factor(c(rep("Lit", 10), rep("Orig", 10))))
names(facSlot) <- "Puv"
facSlot$Nr <- factor(rep(0:9, 2))

# outlines ----
outProf <- Out(inProf, fac = facSlot)
outSide <- Out(inSide, fac = facSlot)
outTop <- Out(inTop, fac = facSlot)

panel(outProf, fac = "Puv", names = "Nr")
panel(outSide, fac = "Puv", names = "Nr")
panel(outTop, fac = "Puv", names = "Nr")

# manipulate outlines ----
manProf <- outProf %>%
  coo_slidedirection("S") %>% coo_center() %>% coo_scale() %>%
  coo_smooth(50) %>% coo_sample(200)

manSide <- outSide %>%
  coo_alignxax() %>% coo_slidedirection("W") %>% coo_center() %>%
  coo_smooth(200) %>% coo_sample(200)

manTop <- outTop %>%
  coo_alignxax() %>% coo_slidedirection("W") %>% coo_center() %>%
  coo_smooth(200) %>% coo_sample(400)

panel(manProf, fac = "Puv", names = "Nr")
panel(manTop, fac = "Puv", names = "Nr")
panel(manSide, fac = "Puv", names = "Nr")

# stack(filter(manProf, Nr == 5))
#
# stack(filter(manTop, Nr == 1))
# stack(filter(manTop, Nr == 2))
# stack(filter(manTop, Nr == 3))

# efourier ----
efProf <- efourier(manProf, nb.h = 10, norm = FALSE, smooth.it = 0,
                   start = FALSE, verbose = TRUE)

efSide <- efourier(manSide, nb.h = 11, norm = TRUE, smooth.it = 0,
                   start = FALSE, verbose = TRUE)

efTop <- efourier(manTop, nb.h = 12, norm = TRUE, smooth.it = 0,
                  start = FALSE, verbose = TRUE)

# centroid size ----
# coo_centsize(manProf)
# coo_centsize(manSide)
# coo_centsize(manTop)

# mean shapes ----
Prof <- mshapes(efProf, 1)
Side <- mshapes(efSide, 1)
Top <- mshapes(efTop, 1)

# t-test
# lit <- filter(manProf, Puv == "Lit")
# orig <- filter(manProf, Puv == "Orig")
#
# t.test(Prof$shp$Lit, Prof$shp$Orig)
# t.test(Prof$shp$Lit, Prof$shp$Orig, paired = T)
#
# t.test(lit$coo$LitProf0, orig$coo$OrigProf0)

# stack plots of meanshapes ----
# pdf(file = "./Obr/prof.pdf")
# LitProf <- Prof$shp$Lit    %T>% coo_plot(border="blue")
# KreProf <- Prof$shp$Orig  %T>% coo_draw(border="red")
# dev.off()
#
# pdf(file = "./Obr/side.pdf")
# LitSide <- Side$shp$Lit    %T>% coo_plot(border="blue")
# KreSide <- Side$shp$Orig  %T>% coo_draw(border="red")
# dev.off()
#
# pdf(file = "./Obr/top.pdf")
# LitTop <- Top$shp$Lit    %T>% coo_plot(border="blue")
# KreTop <- Top$shp$Orig  %T>% coo_draw(border="red")
# dev.off()

# difference plots of meanshapes ----
pdf(file = "./Obr/panProf.pdf")
efProf %>% mshapes("Puv") %>% plot_mshapes(col2="#0000FF")
dev.off()

pdf(file = "./Obr/panSide.pdf")
efSide %>% mshapes("Puv") %>% plot_mshapes(col2="#0000FF")
dev.off()

pdf(file = "./Obr/panTop.pdf")
efTop %>% mshapes("Puv") %>% plot_mshapes(col2="#0000FF")
dev.off()

# tps plots ----
pdf(file = "./Obr/isoProf.pdf", width = 10, height = 10)
tps_iso(LitProf, KreProf, cont.col = "gray40", grid = F,
        shp.border = c("black", "blue"), shp.lwd = c(4, 3), shp.lty = c(3, 3),
        legend.text = c("Lit", "Orig"))
dev.off()

pdf(file = "./Obr/isoSide.pdf", width = 9, height = 3)
tps_iso(LitSide, KreSide, cont.col = "gray40", grid = F,
        shp.border = c("black", "blue"), shp.lwd = c(4, 3), shp.lty = c(3, 3),
        legend.text = c("Lit", "Orig"))
dev.off()

pdf(file = "./Obr/isoTop.pdf", width = 11, height = 4)
tps_iso(LitTop, KreTop, cont.col = "gray40", grid = F,
        shp.border = c("black", "blue"), shp.lwd = c(4, 3), shp.lty = c(3, 3),
        legend.text = c("Lit", "Orig"))
dev.off()

# indiv.
tps_iso(manProf$coo$LitProf1, manProf$coo$OrigProf1)

coo_lolli(LitProf, KreProf)
coo_lolli(LitSide, KreSide)
coo_lolli(LitTop, KreTop)
# or?
coo_arrows(LitProf, KreProf)
coo_arrows(LitSide, KreSide)
coo_arrows(LitTop, KreTop)

# coo_plot(LitProf)
# coo_ruban(LitProf, edm(LitProf, KreProf), lwd=8)
# coo_ruban(LitTop, edm(LitTop, KreTop), lwd=8)

# a <- efourier(manTop)
# ms.Top <- mshapes(a, fac = "Puv", nb.pts = 80)$shp
# fr <- ms.Top$Lit
# to <- ms.Top$Orig
# tps_iso(fr, to)

# end
rm(list = ls())
graphics.off()


library(ggplot2)

# emakina colors
tangerine<-"#ff7f41" #orange
tangerine_transparent<-"#ff7f4185"
chartreuse<- "#8cc63f" #green
chartreuse_transparent<- "#8cc63f85"
azure<- "#008fd4" #blue
colors <- c(tangerine, chartreuse)
black<-"#000000"
grey1<-"#c8c8c8" # light grey
grey2<-"#969696" # middle grey
grey3<-"#646464" # dark grey

names<-c("timesheet","github pages","templating","deployment updates","environment cleanup")
tediousness<-c(10, 5,4,10,5)
frequency<- c(4,9,4,10,1)

data <-data.frame(names, frequency, tediousness)
data$annoyance<-data$frequency + data$tediousness

#showPoints: if TRUE, then the points are plotted with their corresponding labels
# outFile: the path where to save the generated graph
get_graph<-function(showPoints,outFile){
 p<-ggplot(data, aes(x=frequency,y=tediousness)) +
   #color labels and breaks (put in the legend)
   # no coloring after all, it's duplicate information
   # scale_colour_gradient(low=chartreuse, high=tangerine,breaks=c(min(data$annoyance), max(data$annoyance)),labels = c("Low", "High")) + # color coding of points
   # Axis labels and legend label
   xlab('Frequency') + ylab('Tediousness') +  labs(color="Annoyance") +
   # lim is the range of the x-axis, breaks defines which ticks to display, and labels are the labels of the ticks
   scale_x_continuous(lim=c(0,max(data$frequency)+1), breaks=c(0, max(data$frequency)+1), labels=c('Low', 'High')) +
   # same as for x-axis :)
   scale_y_continuous(lim=c(0,max(data$tediousness)+1), breaks=c(0, max(data$tediousness)+1), labels=c('Low', 'High'))
 if(showPoints){
  p<-p+geom_point(size=6, color=azure,alpha=1)+
  geom_text(aes(label=names),hjust="inward",vjust=2,colour=azure)
 }
 # label sizes
 titleSize<-18
 labelSize<-14

 p<-p+theme(
  text=element_text(size=16),
  # set colour to NA otherwise you have a small white border - ANNOYING!
  plot.background=element_rect(fill=black,colour=NA),
  legend.background=element_rect(fill=black),
  panel.background = element_rect(fill = black,
                                size = 2, linetype = "solid"),
  panel.grid.major = element_line(size = 0.5, linetype = 'solid',
                                colour = NA),
  panel.grid.minor = element_line(size = 0.25, linetype = 'dashed',
                                colour = grey3)
  ,legend.text=element_text(color=grey3)
  ,legend.title=element_text(color=grey3)

  ,axis.title.x = element_text( color=grey3, face='bold')
  ,axis.title.y = element_text( color=grey3, face='bold')
  #,plot.margin=grid::unit(c(0,0,0,0), "mm")
)

 # add rectangles to highlight the interesting areas
 p<-p +
  # horizontal bar
  annotate("rect",xmin=0,xmax=max(data$frequency)+1,ymax=max(data$tediousness)+1,ymin=0.8*(max(data$tediousness)+1),alpha=0.4,fill=tangerine)+
  # vertical bar
  annotate("rect",xmin=(1-0.2)*(max(data$frequency)+1),xmax=max(data$frequency)+1,ymax=max(data$tediousness)+1,ymin=0,alpha=0.4,fill=tangerine)

 ggsave(outFile, p)
}

# Generate graph with points
get_graph(TRUE,"./assets/scatterplot.png")
# Generate graph without points - used in introduction
get_graph(FALSE,"./assets/scatterplot_intro.png")


# apply a binary operation with appropriate type promotion
binop = function(e1, e2, fun, floatfun)
{
  if ((!is.float(e1) && !is.atomic(e1)) || (!is.float(e2) && !is.atomic(e2)))
    stop("non-numeric argument to binary operator")

  if (is.float(e1))
  {
    if (is.integer(e2))
      e2 = fl(e2)

    if (is.float(e2))
      ret = floatfun(e1, e2)
    else
      ret = fun(dbl(e1), e2)
  }
  else
  {
    if (is.float(e2))
    {
      if (is.integer(e1))
        ret = floatfun(fl(e1), e2)
      else
        ret = fun(e1, dbl(e2))
    }
    else
      ret = fun(e1, e2)
  }

  ret
}

# -----------------------------------------------------------------------------
# arithmetic
# -----------------------------------------------------------------------------

#' arithmetic
#'
#' Binary arithmetic numeric/float matrices.
#'
#' @param e1,e2
#' Numeric/float vectors/matrices.
#'
#' @return
#' A matrix of the same type as the highest precision input.
#'
#' @examples
#' library(float)
#'
#' s1 = flrunif(5, 5)
#' s2 = flrunif(5, 5)
#' x = matrix(1:25, 5)
#'
#' s1 + s2 # float
#'
#' typeof(x) # integer
#' x + s2 # float
#'
#' storage.mode(x) = "double"
#' x + s2 # double
#'
#' @useDynLib float R_add_spm R_mul_spm R_sub_spm R_div_spm R_pow_spm
#' @name arithmetic
#' @rdname arithmetic
NULL

add_floatfloat = function(e1, e2)
{
  ret = .Call(R_add_spm, DATA(e1), DATA(e2))
  float32(ret)
}

mul_floatfloat = function(e1, e2)
{
  ret = .Call(R_mul_spm, DATA(e1), DATA(e2))
  float32(ret)
}

sub_floatfloat = function(e1, e2)
{
  ret = .Call(R_sub_spm, DATA(e1), DATA(e2))
  float32(ret)
}

div_floatfloat = function(e1, e2)
{
  ret = .Call(R_div_spm, DATA(e1), DATA(e2))
  float32(ret)
}

pow_floatfloat = function(e1, e2)
{
  ret = .Call(R_pow_spm, DATA(e1), DATA(e2))
  float32(ret)
}

add.float = function(e1, e2)
{
  binop(e1, e2, `+`, add_floatfloat)
}

mul.float = function(e1, e2)
{
  binop(e1, e2, `*`, mul_floatfloat)
}

sub.float = function(e1, e2)
{
  binop(e1, e2, `-`, sub_floatfloat)
}

div.float = function(e1, e2)
{
  binop(e1, e2, `/`, div_floatfloat)
}

pow.float = function(e1, e2)
{
  binop(e1, e2, `^`, pow_floatfloat)
}

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="float32", e2="float32"), add.float)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="float32", e2="float32"), mul.float)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="float32", e2="float32"), sub.float)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="float32", e2="float32"), div.float)

#' @rdname arithmetic
#' @export
setMethod("^", signature(e1="float32", e2="float32"), pow.float)

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="float32", e2="BaseLinAlg"), add.float)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="float32", e2="BaseLinAlg"), mul.float)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="float32", e2="BaseLinAlg"), sub.float)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="float32", e2="BaseLinAlg"), div.float)

#' @rdname arithmetic
#' @export
setMethod("^", signature(e1="float32", e2="BaseLinAlg"), pow.float)

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="BaseLinAlg", e2="float32"), add.float)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="BaseLinAlg", e2="float32"), mul.float)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="BaseLinAlg", e2="float32"), sub.float)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="BaseLinAlg", e2="float32"), div.float)

#' @rdname arithmetic
#' @export
setMethod("^", signature(e1="BaseLinAlg", e2="float32"), pow.float)

# -----------------------------------------------------------------------------
# Comparisons
# -----------------------------------------------------------------------------

#' comparison
#'
#' Binary comparison operators for numeric/float matrices.
#'
#' @param e1,e2
#' Numeric/float vectors/matrices.
#'
#' @return
#' A vector/matrix of logicals.
#'
#' @examples
#' \dontrun{
#' library(float)
#' s = flrunif(5, 5)
#' x = matrix(1:25, 5)
#'
#' s > x
#' s <= 0
#' }
#'
#' @useDynLib float R_lt_spm R_le_spm R_eq_spm R_gt_spm R_ge_spm
#' @name comparison
#' @rdname comparison
NULL

lt_floatfloat = function(e1, e2)
{
  .Call(R_lt_spm, DATA(e1), DATA(e2))
}

le_floatfloat = function(e1, e2)
{
  .Call(R_le_spm, DATA(e1), DATA(e2))
}

eq_floatfloat = function(e1, e2)
{
  .Call(R_eq_spm, DATA(e1), DATA(e2))
}

gt_floatfloat = function(e1, e2)
{
  .Call(R_gt_spm, DATA(e1), DATA(e2))
}

ge_floatfloat = function(e1, e2)
{
  .Call(R_ge_spm, DATA(e1), DATA(e2))
}

lt.float = function(e1, e2)
{
  binop(e1, e2, `<`, lt_floatfloat)
}

le.float = function(e1, e2)
{
  binop(e1, e2, `<=`, le_floatfloat)
}

eq.float = function(e1, e2)
{
  binop(e1, e2, `==`, eq_floatfloat)
}

gt.float = function(e1, e2)
{
  binop(e1, e2, `>`, gt_floatfloat)
}

ge.float = function(e1, e2)
{
  binop(e1, e2, `>=`, ge_floatfloat)
}

#' @rdname arithmetic
#' @export
setMethod("<", signature(e1="float32", e2="float32"), lt.float)

#' @rdname arithmetic
#' @export
setMethod("<=", signature(e1="float32", e2="float32"), le.float)

#' @rdname arithmetic
#' @export
setMethod("==", signature(e1="float32", e2="float32"), eq.float)

#' @rdname arithmetic
#' @export
setMethod(">", signature(e1="float32", e2="float32"), gt.float)

#' @rdname arithmetic
#' @export
setMethod(">=", signature(e1="float32", e2="float32"), ge.float)

#' @rdname arithmetic
#' @export
setMethod("<", signature(e1="float32", e2="BaseLinAlg"), lt.float)

#' @rdname arithmetic
#' @export
setMethod("<=", signature(e1="float32", e2="BaseLinAlg"), le.float)

#' @rdname arithmetic
#' @export
setMethod("==", signature(e1="float32", e2="BaseLinAlg"), eq.float)

#' @rdname arithmetic
#' @export
setMethod(">", signature(e1="float32", e2="BaseLinAlg"), gt.float)

#' @rdname arithmetic
#' @export
setMethod(">=", signature(e1="float32", e2="BaseLinAlg"), ge.float)

#' @rdname arithmetic
#' @export
setMethod("<", signature(e1="BaseLinAlg", e2="float32"), lt.float)

#' @rdname arithmetic
#' @export
setMethod("<=", signature(e1="BaseLinAlg", e2="float32"), le.float)

#' @rdname arithmetic
#' @export
setMethod("==", signature(e1="BaseLinAlg", e2="float32"), eq.float)

#' @rdname arithmetic
#' @export
setMethod(">", signature(e1="BaseLinAlg", e2="float32"), gt.float)

#' @rdname arithmetic
#' @export
setMethod(">=", signature(e1="BaseLinAlg", e2="float32"), ge.float)


coef_in = read.csv("Data_in/log_reg_coefs.csv")

coef_df = coef_in[,2:4]
comps = as.vector(coef_in[,1])
row.names(coef_df) = comps
coef_df = t(coef_df)
coef_df = as.data.frame(coef_df)

coefs = table(coef_df$"VS_vs_BLS", coef_df$"VS_vs_BC", coef_df$"BC_vs_BL")
barplot(coefs, main="Logistic Regression Coef (abs val)")


# model_summary generic function ----
model_summary <- function(input, ...) UseMethod("model_summary", input)

# model_summary mod_vcov method ----
model_summary.mod_vcov <- function(input, show = TRUE, sg = FALSE, ...) {

  # get data ----
  model <- input$model
  vcov_mat <- input$vcov_mat

  # compute se and p-values ----
  coef <- model$coefficients
  se <- lmtest::coeftest(model, vcov_mat)[,2]
  t_value <- coef / se
  p_value <- 2 * pt(-abs(t_value), df = model$df.residual)

  # export data ----
  out <- data.frame(Variables = names(coef),
                    Estimate = coef,
                    Std_Error = se,
                    t_value,
                    p_value,
                    row.names = NULL)
  class(out) <- c("model_summary", class(out))

  # prepare output ----
  if (show & sg) {
    warning("'show' == TRUE overrules 'sg' == TRUE")
  }
  if (show) {
    print(x = out)
  } else {
    if (sg) {
      out <- list(model, out$se)
    } else if (requireNamespace("tibble", quietly = TRUE)) {
      out <- tibble::as_tibble(out)
    }
    return(out)
  }
}

# model_summary lm and glm method ----
model_summary.lm <- model_summary.glm <- function(input, type = 0, var_cluster = NULL, show = TRUE, sg = FALSE, ...) {
  out <- model_vcov(model = input, type = type, var_cluster = var_cluster)
  out <- model_summary(input = out, show = FALSE)
  class(out) <- c("model_summary", class(out))

  # prepare output ----
  if (show & sg) {
    warning("'show' == TRUE overrules 'sg' == TRUE")
  }
  if (show) {
    print(x = out)
  } else {
    if (sg) {
      out <- list(input, out$Std_Error)
    } else if (requireNamespace("tibble", quietly = TRUE)) {
      out <- tibble::as_tibble(out)
    }
    return(out)
  }
}

# model_summary lmer and glmer method ----
model_summary.lmerMod <- model_summary.glmerMod <- function(input, randfe = FALSE, show = TRUE, sg = FALSE, ...) {

  # compute se and p-values ----
  name <- attributes(input@pp$X)$dimnames[[2]]
  coef <- input@beta
  se <- sqrt(Matrix::diag(vcov(input)))
  t_value <- coef / se
  p_value <- 2 * pt(-abs(t_value), df = nrow(input@frame) - 1)
  out <- data.frame(Variables = name,
                    Estimate = coef,
                    Std_Error = se,
                    t_value,
                    p_value,
                    row.names = NULL)

  class(out) <- c("model_summary", class(out))

  # get random fixed effects ----
  if (randfe) {
    out_randfe <- lme4::ranef(input)
    out_randfe <- purrr::map(seq(length(out_randfe)), ~{
      out <- as.data.frame(out_randfe[[.x]])
      names(out) <- "Estimate"
      out$Group <- row.names(out)
      row.names(out) <- NULL
      out$Effect <- names(out_randfe)[[.x]]
      out <- out[,c(3:1)]
      return(out)
    })
    out_randfe <- dplyr::bind_rows(out_randfe)
    class(out_randfe) <- c("model_randfe", class(out_randfe))
  }

  # prepare output ----
  if (show & sg) {
    warning("'show' == TRUE overrules 'sg' == TRUE")
  }
  if (show) {
    if (!randfe) {
      print(x = out)
    } else {
      purrr::map(list(Variables = out, RandFE = out_randfe), print)
    }
  } else {
    if (sg) {
      out <- list(input)
    } else if (requireNamespace("tibble", quietly = TRUE)) {
      out <- tibble::as_tibble(out)
      if (randfe) {
        out_randfe <- tibble::as_tibble(out_randfe)
      }
    } else {
      class(out) <- "data.frame"
      class(out_randfe) <- "data.frame"
    }
    if (!randfe) {
      return(out)
	} else if (sg & randfe) {
	  warning("'sg' == TRUE overrules 'randfe' == TRUE")
	  return(out)
    } else {
      out <- list(Variables = out, RandFE = out_randfe)
      return(out)
    }
  }
}


# assign 's' a list of ten functions
s <- sapply (1:10,  # integers 1..10 become argument 'x' below
    function (x) {
        x  # force evaluation of promise x
	function (i=x) i*i   # this *function* is the return value
    })

s[[5]]()  # call the fifth function in the list of returned functions
[1] 25    # returns vector of length 1 with the value 25


#' @title midg is an abalone tagging data-set from the Actaeons
#'
#' @description midg is a tagging data-set for blacklip abalone
#'     (\emph{Haliotis rubra}) from the middle ground in the Actaeons
#'     in Tasmania's Block 13. All individuals were recaptured in 2003,
#'     the site number was 478, at Latitude -43.54 longitude 146.99,
#'     and there are 347 observations. All Dt = 1 year.
#'
#' @name midg
#'
#' @docType data
#'
#' @format A data.frame of abalone tagging data
#' \describe{
#'   \item{RecapL}{the length at recapture}
#'   \item{Lt}{the length at tagging}
#'   \item{Dt}{The time interval between tagging and recapture, in this
#'       instance they are all listed as 1 year}
#'   \item{DL}{the growth increment in mm}
#' }
#'
#' @section Subjects:
#'  \itemize{
#'    \item growth curves
#'    \item inverse logistic, von Bertalanffy, Gompertz
#'    \item Static model fitting
#'  }
#'
#' @source Thanks to the Institute of Marine and Antarctic Science,
#'     which is part of the University of Tasmania, and especially to
#'     Dr Craig Mundy, leader of the Abalone Group, for permission to use
#'     this data collected in 2003.
#'
#' @examples
#'  data(midg)
#'  head(midg,20)
#'  oldpar <- par(no.readonly=TRUE)
#'  plot(midg$Lt,midg$DL,type="p",pch=16,cex=1.0,xlim=c(5,180))
#'  abline(h=0,col=1)
#'  par(oldpar)
NULL

#' @title tasab is a matrix of abalone maturity-at-length data
#'
#' @description tasab is a 715 x 4 matrix of maturity-at-length data
#'     for blacklip abalone (\emph{Haliotis rubra}) from two sites
#'     along the Tasmanian west coast. All data was collected in
#'     February 1995, but details, such as site name, accurate
#'     location, statistical block, year, month, and other
#'     details have been omitted for brevity.
#'
#' @name tasab
#'
#' @docType data
#'
#' @format A data.frame of maturity-at-length data
#' \describe{
#'   \item{site}{an identifier for the two different sites sampled}
#'   \item{sex}{I = immature, M = male, F = female}
#'   \item{length}{the shell length in mm}
#'   \item{mature}{was the animal mature = 1 or not = 0}
#' }
#'
#' @section Subjects:
#'  \itemize{
#'    \item maturity ogives or logistic curves
#'    \item Binomial likelihoods
#'  }
#'
#' @source Thanks to the Institute of Marine and Antarctic Science,
#'     which is part of the University of Tasmania, and especially to
#'     Dr Craig Mundy, leader of the Abalone Group, for permission to use
#'     this data collected in February 1995.
#'
#' @examples
#'  data(tasab)
#'  head(tasab,20)
#'  table(tasab$site,tasab$sex)
NULL


score <- function(input) {
    var0 <- exp(subroutine0(input))
    var1 <- exp(subroutine1(input))
    var2 <- exp(subroutine2(input))
    var3 <- ((var0) + (var1)) + (var2)
    return(c((var0) / (var3), (var1) / (var3), (var2) / (var3)))
}
subroutine0 <- function(input) {
    return(((0) + (subroutine3(input))) + (subroutine4(input)))
}
subroutine1 <- function(input) {
    return(((0) + (subroutine5(input))) + (subroutine6(input)))
}
subroutine2 <- function(input) {
    return(((0) + (subroutine7(input))) + (subroutine8(input)))
}
subroutine3 <- function(input) {
    if ((input[3]) > (3.1500000000000004)) {
        var0 <- -1.1736122903444903
    } else {
        if ((input[2]) > (3.35)) {
            var0 <- -0.9486122853153485
        } else {
            var0 <- -0.9598622855668056
        }
    }
    return(var0)
}
subroutine4 <- function(input) {
    if ((input[3]) > (3.1500000000000004)) {
        if ((input[3]) > (4.450000000000001)) {
            var0 <- -0.07218200074594171
        } else {
            var0 <- -0.0725391787456957
        }
    } else {
        if ((input[2]) > (3.35)) {
            var0 <- 0.130416969124648
        } else {
            var0 <- 0.12058330491181404
        }
    }
    return(var0)
}
subroutine5 <- function(input) {
    if ((input[3]) > (1.8)) {
        if ((input[4]) > (1.6500000000000001)) {
            var0 <- -1.1840003561812273
        } else {
            var0 <- -0.99234128317334
        }
    } else {
        var0 <- -1.1934739985732523
    }
    return(var0)
}
subroutine6 <- function(input) {
    if ((input[4]) > (0.45000000000000007)) {
        if ((input[4]) > (1.6500000000000001)) {
            var0 <- -0.06203313079859976
        } else {
            var0 <- 0.11141505233015861
        }
    } else {
        if ((input[3]) > (1.4500000000000002)) {
            var0 <- -0.0720353255122301
        } else {
            var0 <- -0.07164473223425313
        }
    }
    return(var0)
}
subroutine7 <- function(input) {
    if ((input[4]) > (1.6500000000000001)) {
        if ((input[3]) > (5.3500000000000005)) {
            var0 <- -0.9314095846701695
        } else {
            var0 <- -0.9536869036452162
        }
    } else {
        if ((input[3]) > (4.450000000000001)) {
            var0 <- -1.115439610985773
        } else {
            var0 <- -1.1541827744206368
        }
    }
    return(var0)
}
subroutine8 <- function(input) {
    if ((input[3]) > (4.750000000000001)) {
        if ((input[3]) > (5.150000000000001)) {
            var0 <- 0.12968922424213622
        } else {
            var0 <- 0.07468384042736965
        }
    } else {
        if ((input[2]) > (2.7500000000000004)) {
            var0 <- -0.07311533184609437
        } else {
            var0 <- -0.06204412771870974
        }
    }
    return(var0)
}


library(tidyverse)
library(dplyr)
library(stringr)
library(lintr)
table_of_data <- read.csv("data/mental_health_in_tech/survey.csv") %>%
  select(-Timestamp) %>%
  drop_na(state) %>%
  select(-Country) %>%
  select(-comments) %>%
  mutate(family_history_of_mental_illness = family_history) %>%
  select(-family_history) %>%
  mutate(previous_treatment_for_mental_illness = treatment) %>%
  select(-treatment) %>%
  mutate(mental_illness_effects_work = work_interfere) %>%
  select(-work_interfere) %>%
  mutate(company_employee_total = no_employees) %>%
  select(-no_employees) %>%
  mutate(majority_of_worktime_remote = remote_work) %>%
  select(-remote_work) %>%
  mutate(mental_health_benefits_provided = benefits) %>%
  select(-benefits) %>%
  select(-Gender) %>%
  mutate(aware_of_mental_health_care_provided = care_options) %>%
  select(-care_options) %>%
  select(-wellness_program) %>%
  select(-seek_help) %>%
  select(-anonymity) %>%
  mutate(easy_to_take_leave = leave) %>%
  select(-leave) %>%
  select(-mental_health_consequence) %>%
  select(-phys_health_consequence) %>%
  mutate(comfortable_discussing_mental_health_with_coworkers = coworkers) %>%
  select(-coworkers) %>%
  mutate(comfortable_discussing_mental_health_with_supervisor = supervisor) %>%
  select(-supervisor) %>%
  select(-mental_health_interview) %>%
  select(-phys_health_interview) %>%
  select(-mental_vs_physical) %>%
  select(-obs_consequence) %>%
  arrange(state, by_group = T)

order <- c("1-5", "6-25", "26-100", "100-500", "500-1000", "More than 1000")

summary_table <- table_of_data %>%
  mutate(has_history = if_else(family_history_of_mental_illness == "Yes", 1, 0)) %>%
  mutate(got_treatment = if_else(previous_treatment_for_mental_illness == "Yes", 1, 0)) %>%
  mutate(benefits = if_else(mental_health_benefits_provided == "Yes", 1, 0)) %>%
  mutate(comfortable_coworkers = if_else(comfortable_discussing_mental_health_with_coworkers == "Yes" |
    comfortable_discussing_mental_health_with_coworkers == "Some of them", 1, 0)) %>%
  mutate(comfortable_supervisor = if_else(comfortable_discussing_mental_health_with_supervisor == "Yes" |
    comfortable_discussing_mental_health_with_supervisor == "Some of them", 1, 0)) %>%
  group_by(company_employee_total) %>%
  summarise(
    family_history_of_mental_illness_prop = round(sum(has_history / n()), digits = 3),
    previous_treatment_for_mental_illness_prop = round(sum(got_treatment) / n(), digits = 3),
    mental_health_benefits_provided_prop = round(sum(benefits / n()), digits = 3),
    comfortable_discussing_mental_health_with_coworkers_prop = round(sum(comfortable_coworkers / n()), digits = 3),
    comfortable_discussing_mental_health_with_supervisor_prop = round(sum(comfortable_supervisor / n()), digits = 3)
  ) %>%
  slice(match(order, company_employee_total))

summary_of_data <- table_of_data %>%
  filter(easy_to_take_leave != "Don't know") %>%
  filter(mental_health_benefits_provided != "Don't know") %>%
  drop_na(mental_illness_effects_work) %>%
  mutate(leave_provided = if_else(easy_to_take_leave == "Very easy" |
                                    easy_to_take_leave == "Somewhat easy", 1, 0)) %>%
  mutate(benefits_provided = if_else(mental_health_benefits_provided == "Yes", 1, 0)) %>%
  mutate(comfortable = if_else(comfortable_discussing_mental_health_with_coworkers == "Yes" |
                                 comfortable_discussing_mental_health_with_coworkers == "Some of them", 1, 0)) %>%
  mutate(effects_work = if_else(mental_illness_effects_work == "Often" |
                                  mental_illness_effects_work == "Sometimes", 1, 0)) %>%
  group_by(tech_company) %>%
  summarise(
    leave_provided_prop = round(sum(leave_provided / n()), digits = 3),
    benefits_provided_prop = round(sum(benefits_provided / n()), digits = 3),
    comfortable_prop = round(sum(comfortable / n()), digits = 3),
    effects_work_prop = round(sum(effects_work / n()), digits = 3))


library(changepoint)
library(bcp)

getdatafiles = function(datadirs, scanpattern) {
  # Search for data files to load
  #
  # Args:
  #   datadirs: vector of which
  #   scanpattern: e.g. *.csv
  #
  # Returns:
  #   data frame with datadir, fn (filename) columns
  files = adply(datadirs, 1, function(datadir) {
    data.frame(
      datadir = datadir,
      fn = list.files(path=datadir, recursive=TRUE, pattern=scanpattern),
      stringsAsFactors=FALSE
    )
  })
  #cut out cpu_report
  files = subset(files, !grepl("cpu_report", fn, fixed=TRUE))
  files
}

readsingle = function(loc) {
  # Read a single data file from location loc
  #
  # Args:
  #   loc: file location
  #
  # Returns:
  #   data frame with t (timestamp) and v (value) columns
  dat = read.csv(loc, col.names=c("t", "v"), sep=",")
  dat$t = strptime(dat$t, "%Y-%m-%dT%H:%M:%S+00:00")
  dat
}

readdata = function(datafiles) {
  # Read a set of datafiles, as produced, for e.g., by getdatafiles
  #
  # Args:
  #   datafiles: data frame of file locations with datadir, fn columns
  #
  # Returns:
  #   list of lists, each with info re: location and data (see readsingle)
  alply(datafiles, 1, function(r) {
    parts = strsplit(r$fn, "/")[[1]]
    list(
      datadir=r$datadir,
      fn=r$fn,
      node=parts[1],
      metric=parts[2],
      data=readsingle(paste(r$datadir, r$fn, sep="/"))
    )
  }, .progress="text")
}

findcps = function(series, method="SegNeigh") {
  # Find changepoints of a time series
  c = data.frame(t=c(), stat=c())
  tryCatch({
    if (method == "SegNeigh") {
      cps = cpt.mean(series$v, Q=10, method="SegNeigh", class=FALSE)
      pts = unique(cps$cps[(nrow(cps$cps)-cps$op.cpts + 1):nrow(cps$cps), 1])
      c = data.frame(
        t = series$t[pts],
        stat = rep(1, length(pts))
      )
    } else if (method == "BinSeg") {
      cps = binseg.mean.cusum(series$v, Q=10, pen=1)
      pts = cps$cps[1,1:cps$op.cpts]
      stats = cps$cps[2,1:cps$op.cpts]
      c = data.frame(
        t=series$t[pts], #time
        stat=stats #test statistic
      )
    }
  }, error=function(e) {
    #why can't we put c here?
  })
  c
}

test.maketseries = function() {
  vals = c(1,1,1,1,1,1,1,2,2,2,2,2,2,1,1,1,1,1,5,5,5,50,5,5,5)
  c = data.frame(
    t = seq(1, length(vals)),
    v = vals
  )
  c
}

test.findcps = function() {
  print(findcps(test.maketseries()))
}

#find probabilities of a changepoint at a given location
cpprobs = function(series, method="bcp") {
  if (method=="bcp") {
    #original
    #probs = bcp(series$v)$posterior.prob
    res = bcp(series$v, p0=1e-7, w0=1e-5)
    probs = res$posterior.prob

    probs[is.na(probs)] = 0
    data.frame(
      t = series$t,
      v = probs
    )
  }
}

test.cpprobs = function() {
  print(cpprobs(test.maketseries()))
}


#' Transfer cover object into average local cover of vegetated cells, q_11.
#'
#' @param rho
#'
#' @return
#' @export
#'
#' @examples
#'
#' rho <- ini_rho(0.5,0.45)
#' q_11(rho)

q_11 <- function(rho) {
  out <- rho[[2]]/rho[[1]]
  out[is.nan(out)] <- 0
  return(as.vector(out))
}

#q_11 <- function(rho_1, rho_11) {
#  out <- rho_11/rho_1
#  out[out < zlim[1] | is.na(out)] <- 0
#  out[out > zlim[2]] <-  zlim[2]
#  return(as.vector(out))
#
#}

#' Transfer cover object into average local cover of empty cells, q_01.
#'
#' @param rho
#'
#' @return
#' @export
#' @examples
#'
#' rho <- ini_rho(0.5,0.45)
#' q_01(rho)
#'

q_01 <-  function(rho) {
  out <- (rho[[1]]-rho[[2]])/(1-rho[[1]])
  out[is.nan(out)] <- 1
  return(as.vector(out))
}

#q_01 <-  function(rho_1, rho_11, zlim = c(0,1)) {
#  out <- (rho_1-rho_11)/(1-rho_1)
#  out[out < zlim[1] | is.na(out)] <- 0
#  out[out > zlim[2]] <-  zlim[2]
#  return(as.vector(out))
#
#}


#' Summarize CpG distributions
#'
#' Summarize CpG site quantiles (0, 10, 15, 50, 75, 90, 100), the
#' mean, and SD.
#'
#' @param methylation DNA methylation matrix, one row per CpG site,
#' one column per sample.
#' @param cpgs.are.rows logical argument to allow CpG sites to be in
#' columns instead of rows.
#' @param ... Arguments to \code{\link{glm}}.
#' @return matrix with columns of each requested summary statistics
#' and row for each CpG in \code{methylation}
#'
#' @export
ewaff.cpg.summary <- function(methylation, cpgs.are.rows=T){
    if (!cpgs.are.rows)
    	methylation <- t(methylation)

    t(apply(methylation, 1, function(object){
	    nas <- is.na(object)
	    object <- object[!nas]
	    qq <- quantile(object, c(0.00, 0.10, 0.25, 0.50, 0.75, 0.90, 1.00))
	    qq <- signif(c(qq[1L:3L], mean(object), qq[4L], sd(object), qq[5L:7L]),
	    			max(3, getOption("digits")-3))
	    names(qq)[c(1,4:6,9)] <- c("Min.", "Mean", "Median", "SD", "Max.")
		c(qq, `NA's` = sum(nas), `N` = length(object) - sum(nas) )
    }))
}

lambda <- function(p.values){
	qunif(median(p.values, na.rm=T), lower.tail = F)/
  		qunif(0.5, 1)
}

lambda.chi <- function(p.values){
	qchisq(median(p.values, na.rm=T), df = 1, lower.tail = F)/
 		qchisq(0.5, 1)
}