library(R2WinBUGS)
library(BRugs)
dat=read.csv("C3_Species.csv",header=T)
#dat2=read.csv('c3covariates.csv',header=T)

my.model  = function(){
  Jmax ~ dlnorm(4.7,2.7)             ## maximum electron transport rate prior
  alpha~dnorm(0.25,100)              ##quantum yield  (mol electrons/mole photon) prior
  vmax ~dlnorm(4.6,2.7)              ## maximum rubisco capacity prior
  r ~ dlnorm(0.75,1.56)              ## leaf respiration prior
  cp ~ dlnorm(1.9,2.7)               ## CO2 compensation point prior
  tau ~ dgamma(0.1,0.1)
#  tpu~ dlnorm(3,2.8)                 ##tpu

#  tau.Vleaf~dgamma(0.1,0.1)          ## add random leaf effects
#  tau.Aleaf~dgamma(0.1,0.1)
#  for(i in 1:nrep){
#   Vleaf[i]~dnorm(0,tau.Vleaf)
#   Aleaf[i]~dnorm(0,tau.Aleaf)
#  }
#  beta1 ~ dnorm(0,0.1)              ## chlorophyll effects
#  beta2 ~ dnorm(0,0.1)              ## SLA effects
#  beta5 ~ dnorm(0,0.1)              ## Vcmax effects

#  tau.Vmon~dgamma(0.01,0.01)        ## add month effects on Vcmax, fixed effects
#   Vmon[7]<-0                       ## reference month
#   Vmon[8]~ dnorm(0,tau.Vmon)
#   Vmon[5]~ dnorm(0,tau.Vmon)
#   Vmon[6]~ dnorm(0,tau.Vmon)
#   Vmon[9]~ dnorm(0,tau.Vmon)
#   Vmon[10]~ dnorm(0,tau.Vmon)
#  Kc<-46                          ## Michaelis constant CO2 (Pa)
#  Ko<-33000                       ## Michaelis constant O2  (Pa)
#  po<-21000                       ## partial pressure of O2  (Pa)
#  k <- 0.21                       ## Vo/Vc
  for(i in 1:n){
#     al[i]<-((alpha+beta1*(chl[rep[i]]-chlave)+beta2*(sla[rep[i]]-slaave)
#     +Aleaf[rep[i]])*q[i]/(sqrt(1+((alpha+Aleaf[rep[i]])*(alpha+
#     Aleaf[rep[i]])*q[i]*q[i])/(Jmax*Jmax))))*(pi[i]-cp)/(4*pi[i]+8*cp)                            ## electron transport limited with chlorophyll, SLA and random leaf effects turned on

     al[i]<-(alpha*q[i]/(sqrt(1+(alpha*alpha*q[i]*q[i])/(Jmax*Jmax))))*(pi[i]-cp)/(4*pi[i]+8*cp)    ## electron transport limited without covariates

#     ae[i]<-(vmax+Vmon[month[i]]+beta5*(leafn[rep[i]]-leafnave)
#     +Vleaf[rep[i]])*((pi[i]-cp)/(pi[i]+Kc*(1+po/Ko)))                                              ## maximum rubisco limited with leaf N, month and random leaf effects turned on

     ae[i]<- vmax*(pi[i]-cp)/(pi[i]+Kc*(1+po/Ko))                                                    ## maximum rubisco limited without covariates

#    ap[i]<-3*tpu                         ## phosphate limited

     prean[i]<-min(al[i], ae[i]) - r      ## predicted net photosynthesis
     an[i]~dnorm(prean[i],tau)            ## likelihood
     pA[i] ~ dnorm(prean[i],tau)          ## prediction
     }
}
 write.model(my.model,"c3model.txt")

init<-list()
 init[[1]]<-list(r=1.2, vmax=39,alpha=0.25, tau=10, cp=6, Jmax=80) ## tau.Vleaf=30,beta1=4, beta2=1,beta5=3,tau.Vmon=10,tpu=10,
 init[[2]]<-list(r=1, vmax=100, alpha=0.20, tau=20, cp=4, Jmax=150) ##tau.Vleaf=20,beta1=1,beta2=1,beta5=-1,tau.Vmon=20,tpu=13,
 init[[3]]<-list(r=2, vmax=60, alpha=0.28, tau=20, cp=5,Jmax=60)    ##tau.Vleaf=100,beta1=1,beta2=2,beta5=2,tau.Vmon=3,tpu=20,

 spp.list = unique(as.character(dat$id))

 c3mcmc <- list()

 for(s in spp.list){
  sel = which(dat$id == s)
  an=dat$Photo[sel]
  pi=dat$Ci_Pa[sel]
  q=dat$PARi[sel]
#  rep=dat$rep[sel]        ## turn on random leaf effects
#  reps = unique(rep)
#  rep = match(rep,reps)
#  nrep = length(reps)
#  month=dat$month[sel]    ## month information

## covariates data from dat2
#  sel2=which(dat2$id==s)
#  chl=dat2$chl[sel2]
#  leafn=dat2$leafn[sel2]
#  sla=dat2$sla[sel2]
#  rep2 = dat2$rep[sel2]
#  rep2 = match(rep2,reps)
#  rep3track[[s]]=rep2
#  chlave=mean(chl)
#  leafnave=mean(leafn)
#  slaave=mean(sla)

## temperature compoent   (Bernacchi et al. 2001,2002,2003)
#parameter=as.character(c("Vmax","Jmax","Kc","Ko","cp","Rd"))
#c=c(26.36,17.71,35.98,12.38,11.19,18.71)
#Ha=c(65.33,43.9,80.99,23.72,24.46,46.39)
#R=8.314
#value25=c(1,1,460,220,37,1)         ## when include temperature component, the unit of Kc (umol mol-1) Ko (mmol mol-1) and cp (umol mol-1) in this equation need to be converted into Pascals
#for(i in 1:6){
#y=value25[i]*exp(c[i]-(1000*Ha[i]/(R*(tleaf+273.15))))
#}

mydat<-list(an=an, pi=pi, q=q,n=length(an),Kc=46,Ko=22000,po=21000)
## rep=rep,nrep=nrep,chl=chl,leafn=leafn, sla=sla, chlave=chlave,leafnave=leafnave,slaave=slaave,month=month

 mc3 <- openbugs(mydat,
 init,
 model.file="c3model.txt",
 n.chains=3,
 n.iter=1000,
 n.burnin=500,
 n.thin =25,
 parameters.to.save=c("r","vmax","alpha","Jmax", "cp","tau", "prean", "pA")
##"beta1","beta2","beta5","Vmon","Vleaf","Aleaf","tau.Vmon","tau.Vleaf","tau.Aleaf",
 )
 c3mcmc[[s]]=mc3
}

## make trace and density plots
for(s in spp.list){
pdf(paste(s, " model trace.pdf",sep=""))
plot(as.mcmc.list(c3mcmc[[s]]))
dev.off()
}

## predictions vs measurements
sel1=which(dat$id==s)
an=dat$Photo[sel1]
plot(an,c3mcmc[[s]]$mean$prean, ylim=c(-5,40),xlim=c(-5,40), pch=19,
main="Predicted photosynthesis vs measured phtosynthesis", xlab="Measured An (umol m-2 s-1)",
ylab="Predicted An (umol m-2 s-1)",cex.main=1.6,cex.lab=1.4)
abline(0,1, col="dark green",lwd=3)


install.packages("ggplot2")
library("ggplot2")

data <- c(179718,41370,41914,44280)
labels <- c("Army","Navy","Air Force","Marine")
piePercentage <- round(100*data/sum(data), 1)
pie(data,labels = piePercentage,radius=0.99,main = "Traumatic Brain Injury 2000-2014(Q2)",col = c("Red","Blue","Green","Yellow"),clockwise = "True")
legend("left", c("Army","Navy","Air Force","Marine"), cex = 0.8,
       fill = c("Red","Blue","Green","Yellow"))

R Community/Create Charts in R-Assignment/pie chart.r


source('C:\\Program Files\\R\\R-3.3.1\\library\\Functions.R');

# Load RODBC package
library(RODBC)

dbhandle <- odbcDriverConnect('Driver={PI ODBC Driver};Server=MARC-WEB-SQL;Trusted Connection=Yes;Provider Type=PIOLEDBENT;Initial Catalog=NuGreen; Provider String={Data Source=MARC-PI2016; Integrated Security=SSPI};')
values <- sqlQuery(dbhandle, 'SELECT ea.Name As Name, Format(i.Time, \'MMM-dd-yyyy HH:mm:ss\'), i.Value
FROM [IntegratingPISystemAndR].[Asset].[ElementHierarchy] eh
INNER JOIN [IntegratingPISystemAndR].[Asset].[ElementAttribute] ea
ON ea.ElementID = eh.ElementID,
[IntegratingPISystemAndR].[Data].[ft_InterpolateRange] i
WHERE i.ElementAttributeID = ea.ID
AND i.StartTime = \'1-Oct-2012\'
AND i.EndTime = \'1-Nov-2012\'
AND i.TimeStep = \'1h\'
OPTION (FORCE ORDER, EMBED ERRORS)')

tag1name = 'FAC.OAK.Weather-Inside_Humidity-Val.PV';
tag2name = 'FAC.OAK.Weather-Inside_Temperature-Val.PV';
tag3name = 'FAC.OAK.Weather-Outside_Temperature-Val.PV';

n = (dim(values)[1])/3;
v1 = 1: n;
v2 = 1: n;
v3 = 1: n;

i=1;
j=1;
k=1;
m = 1;

while(m<3*n) {

	if (values[[1]][[m]]=="OutsideTemperature")
	{
		v3[i] = values[[3]][[m]]
		i=i+1
	}
	if (values[[1]][[m]]=="Inside Temperature")
	{
		v2[j] = values[[3]][[m]]
		j=j+1
	}
	if (values[[1]][[m]]=="Inside Humidity")
	{
		v1[k] = values[[3]][[m]]
		k=k+1
	}
	m <- m+1;
}

impact3<-data.frame(v1,v2,v3);
tn3<-c(tag1name,tag2name,tag3name);
PI_Multi_Correlation3(impact3,tn3);

Chapter10 - Retrieving PI Data into R/rODBC/piodbc_oledb.r


# setting
dir_name <- "submission_pre"
filenames <- list.files(file.path("..", "submission", dir_name))
print(filenames)

# check result
result <- data.frame(filenames)
result$train <- as.numeric(gsub("submission_[0-9]+_s[0-9]+_train(.+)_valid(.+).csv","\\1",filenames))
result$valid <- as.numeric(gsub("submission_[0-9]+_s[0-9]+_train(.+)_valid(.+).csv","\\2",filenames))

# sort
result <- result[order(result$valid),]
print(result)

# number of input
num_model <- 20

# averaging
for(i in 1:num_model){
	target_file <- as.character(result$filename[i])
	print(target_file)
	datai <- read.csv(file.path("..", "submission", dir_name, target_file))
	if(i==1){
		data <- datai
	}else{
		data[,-1] <- data[,-1] + datai[,-1]
	}
}
data[,-1] <- data[,-1] / num_model

# display scores
train_scores <- result$train[1:num_model]
valid_scores <- result$valid[1:num_model]
cat("train: ", sprintf("%.4f +- %.4f", mean(train_scores), sd(train_scores)), "\n")
cat("valid: ", sprintf("%.4f +- %.4f", mean(valid_scores), sd(valid_scores)), "\n")

# save output
meanvalid <- mean(valid_scores)
filename <- paste0("submission_nummodel", num_model, "_mvalid", sprintf("%.4f", meanvalid), ".csv")
write.table(data, file.path(".." , "submission", filename), row.names = FALSE, sep=",", quote = FALSE)


# -----------------------------------------------------------------------------
# PROJECT:
#    Evaluating the structure of the communities of the estuary
#    and gulf of St.Lawrence
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# STEP:
#   2. Tanimoto analysis for multiple parameter values
# -----------------------------------------------------------------------------

# Evaluating the effects of multiple parameters on the efficiency of the algorithm

# -----------------------------------------------------------------------------
# FILES:
#   RData <- file = "RData/Tanimoto_analysis.RData" XXX adjust name with type of analysis
#   Script  <- file = "Script/2-1-Tanomoto_analysis.r"
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# PARAMETERS:

# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# SCRIPT
# -----------------------------------------------------------------------------
similarity_cons_res <- tanimoto_analysis(min.tx = 45,
                                        K.values = 8,
                                        MW = 1,
                                        WT =  c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1),
                                        minimum_threshold = 0.3,
                                        filename = 'similarity_cons_res')

# Catalog vs predictions
load("./RData/interactions_source.RData")
accuracy  <- vector('list', 3)
names(accuracy) <- c('Catalog', 'Predict', 'Algorithm')
accuracy[[1]] <- tanimoto_accuracy(Tanimoto_analysis = similarity_cons_res, empirical.only = TRUE)
accuracy[[2]] <- tanimoto_accuracy(Tanimoto_analysis = similarity_cons_res, predict.only = TRUE)
accuracy[[3]] <- tanimoto_accuracy(Tanimoto_analysis = similarity_cons_res)

#Figure
filename = 'Similarity_cons_res'
pdf(paste('./Article/',filename,'.pdf',sep=''),width=7,height=7)

# Plots
par(mfrow=c(2,2))
# Graph
for(j in 9:12) {
        eplot(xmin = -0.09, xmax = 1.09)
        par(pch = 21,  xaxs = "i", yaxs = "i", family = "serif")
        foodwebs <- names(similarity_cons_res[[1]][[1]][[1]])
        names <- c('TSS','Score y', 'Score -y', 'Accuracy score')
        col <- c("#FF8822","#449955","#2288FF")
        # col <- c("#FF000088","#00FF0088","#0000FF88")
        # col <- gray.colors(11, start = 0, end = 0.8, gamma = 2.2, alpha = NULL) # grey scale ramp
        # col <- sample(colours(), length(foodwebs))

        # Axes
            # rect(0, 0, 1, 1, col = "#eeeeee", border = NA)
            axis(side = 1, at = seq(0, 1, by = 0.2), labels = seq(0, 1, by = 0.2), las = 1, pos = -0.02)
            axis(side = 2, at = seq(0, 1, by = 0.2), labels = seq(0, 1, by = 0.2), las = 1, pos = -0.02)
            axis(side = 3, at = seq(0, 1, by = 0.2), labels = seq(0, 1, by = 0.2), las = 1, pos = 1.02)
            axis(side = 4, at = seq(0, 1, by = 0.2), labels = seq(0, 1, by = 0.2), las = 1, pos = 1.02)
            # abline(v = seq(0,6,by = 2), col = "white", lty = 2)
            # abline(h = seq(1,2,by = 1), col = "white", lty = 2)

            mtext(text = names[j-8], side = 2, line = 2, at = 0.5, font = 2, cex = 1)
            mtext(text = "Similarity weight", side = 1, line = 2, at = 0.5, font = 2, cex = 1)

        for(i in 1:length(accuracy)) {
            accuracy_mean <- aggregate(as.numeric(accuracy[[i]][,j]) ~ as.numeric(accuracy[[i]][, 'wt']), data=accuracy[[i]], FUN=function(x) c(mean=mean(x), sd=sd(x)))
            # hack: we draw arrows but with very special "arrowheads" for error bars
            arrows(accuracy_mean[, 1], accuracy_mean[, 2][,1] - accuracy_mean[, 2][, 2], accuracy_mean[, 1], accuracy_mean[, 2][, 1] + accuracy_mean[, 2][, 2], length=0.05, angle=90, code=3, col = col[i])
            points(x = accuracy_mean[, 1], y = accuracy_mean[, 2][, 1], cex = 1.5, pch = 22, col = col[i])
        } #i

        ## Add legend
        if(j == 12) {
            legend(0.45, 0.3, lwd = 3, col = col, legend = names(accuracy), bty = 'n', y.intersp = 1)
        }
} #j
dev.off()


library(DBI)
library(odbc)
library(tidyverse)
library(ComplexHeatmap)
library(circlize)
library(RColorBrewer)

rm(list=ls())

#Load and prepare gene expression matrix
myinf1 <- "/projects/varnf/GLASS-III/GLASS-III/results/kallisto/kallisto/final/gene_tpm_matrix_all_samples.tsv"

genes <- read.delim(myinf1,row.names=1)
colnames(genes) <- gsub("\\.","-",colnames(genes))

gene_sums <- apply(genes,1,sum)
sub_genes <- genes[which(gene_sums>0),]
gene_var <- apply(sub_genes,1,var)
gene_var <- gene_var[order(gene_var,decreasing=TRUE)]

#Load clinical data
con <- DBI::dbConnect(odbc::odbc(), "GLASSv3")

q <- "SELECT al.aliquot_barcode, sa.sample_type, su.*, aliquot_batch
FROM biospecimen.aliquots al
LEFT JOIN clinical.surgeries su ON su.sample_barcode = al.sample_barcode
LEFT JOIN biospecimen.samples sa ON al.sample_barcode = sa.sample_barcode
WHERE aliquot_analyte_type = 'R'"

clin <- dbGetQuery(con,q)

#PCA plot
mypca <- prcomp(t(sub_genes),scale.=TRUE)
scores <- as.data.frame(mypca$x)
scores <- scores[clin[,1],]
scores[,"aliquot_batch"] <- as.factor(clin[,"aliquot_batch"])

pdf("/projects/varnf/GLASS-III/GLASS-III/figures/qc/pca_genes.pdf",width=7,height=7)
ggplot(data = scores, aes(x = PC1, y = PC2, colour=aliquot_batch)) +
  geom_point() +
  geom_hline(yintercept = 0, colour = "gray65") +
  geom_vline(xintercept = 0, colour = "gray65") +
  scale_colour_manual(values=brewer.pal(11,"Set3")) +
  ggtitle("PCA plot of GLASS RNAseq aliquots") +
  theme_classic()
dev.off()

myrk <- qn_genes <- matrix(0, nrow(genes), ncol(genes))
rownames(qn_genes) <- rownames(genes)
colnames(qn_genes) <- colnames(genes)
xx <- myrk
for(k in 1:ncol(genes))
{
	myrk[,k] <- rank(genes[,k])
	xx[,k] <- sort(genes[,k])
}
mymed = apply(xx, 1, median, na.rm=T)
for(k in 1:ncol(genes))
{
	qn_genes[,k] <- mymed[myrk[,k]]
}

qn_gene_sums <- apply(qn_genes,1,sum)
sub_qn_genes <- qn_genes[which(qn_gene_sums>0),]

mypca <- prcomp(t(sub_qn_genes),scale.=TRUE)
scores <- as.data.frame(mypca$x)
scores <- scores[clin[,1],]
scores[,"aliquot_batch"] <- as.factor(clin[,"aliquot_batch"])
scores[,"subtype"] <- as.factor(clin[,"idh_codel_subtype"])

pdf("/projects/varnf/GLASS-III/GLASS-III/figures/qc/pca_genes_qn.pdf",width=7,height=7)
ggplot(data = scores, aes(x = PC1, y = PC2, colour=aliquot_batch)) +
  geom_point() +
  geom_hline(yintercept = 0, colour = "gray65") +
  geom_vline(xintercept = 0, colour = "gray65") +
  scale_colour_manual(values=brewer.pal(11,"Set3")) +
  ggtitle("PCA plot of GLASS RNAseq aliquots") +
  theme_classic()
dev.off()

pdf("/projects/varnf/GLASS-III/GLASS-III/figures/qc/pca_genes_qn_with_subtype.pdf",width=7,height=7)
ggplot(data = scores, aes(x = PC1, y = PC2, colour=aliquot_batch, shape = subtype)) +
  geom_point() +
  geom_hline(yintercept = 0, colour = "gray65") +
  geom_vline(xintercept = 0, colour = "gray65") +
  scale_colour_manual(values=brewer.pal(11,"Set3")) +
  ggtitle("PCA plot of GLASS RNAseq aliquots") +
  theme_classic()
dev.off()


cat(1 - as.numeric(readLines(tail(commandArgs(), n=1))) %% 2, sep="\n")


library(ggplot2)
library(sitools)

data = read.csv('packet-lens-no-apple-tv-no-iphone-no-ipad.csv')
data$timestamp = as.POSIXct(data$timestamp, origin="1970-01-01", tz="GMT")

#ggplot(data, aes(timestamp, io)) +
#	labs(x = "Time", y = "Traffic (bytes)") +
#	geom_line() +
#	#scale_x_date(format = "%b-%Y")
#	theme_bw() +
#	#scale_fill_brewer(palette = 'Set2') +
#	scale_y_continuous(labels=f2si) +
#	theme(
#		#panel.grid.major = element_line(colour = "white"),
#		#panel.grid.minor = element_line(colour = "white"),
#		#axis.text = element_text(size = 18),
#		axis.text.x = element_text(angle=90,hjust=1,vjust=0.5),
#		#axis.title = element_text(size = 20, face="bold")
#	)
#ggsave('packet-lens.pdf', width=10, height=5)

data = aggregate(list(io = data$io), list(timestamp = cut(data$timestamp, "1 hour")), sum)
data$timestamp = as.POSIXct(data$timestamp, origin="1970-01-01", tz="GMT")

ggplot(data, aes(timestamp, io)) +
	labs(x = "Time", y = "Traffic (bytes)") +
	geom_line() +
	#scale_x_date(format = "%b-%Y")
	theme_bw() +
	#scale_fill_brewer(palette = 'Set2') +
	scale_y_continuous(labels=f2si) +
	theme(
		#panel.grid.major = element_line(colour = "white"),
		#panel.grid.minor = element_line(colour = "white"),
		#axis.text = element_text(size = 18),
		axis.text.x = element_text(angle=90,hjust=1,vjust=0.5),
		#axis.title = element_text(size = 20, face="bold")
	)
ggsave('packet-lens-hourly-no-apple-tv-no-iphone-no-ipad.pdf', width=10, height=5)


library(kableExtra)

save.table = function(dat.last.rate, label, caption, file.out, show.operation=TRUE, highlight.best=TRUE, longtable=FALSE) {

  latex.scientific = function (num) {
    exp = floor(log10(abs(num)))
    mech = sprintf("%.1f", num / (10^exp))
    return(paste0(mech, ' \\cdot 10^{', exp, '}'))
  }

  latex.digit = function (d) {
    return(sprintf("%.0f", as.numeric(d)))
  }

  latex.rate = function (d) {
    return(sprintf("%.0f\\%%", as.numeric(d) * 100))
  }

  latex.math.highlighter = function (content, highlight) {
    if (replace_na(highlight, FALSE) && highlight.best) {
      return(paste0('\\mathbf{', content, '}'))
    } else {
      return(content)
    }
  }

  latex.formater = function (vec, formater, min.best=T) {
    df.format = data.frame(
      is.best = vec == ifelse(min.best, min(vec, na.rm=T), max(vec, na.rm=T)),
      num = vec
    ) %>%
      rowwise() %>%
      mutate(
        formatted = ifelse(is.finite(num),
                           paste0('$', latex.math.highlighter(formater(num), is.best), '$'),
                           '---')
      )
    return(df.format$formatted)
  }

  latex.ci.formater = function (vec.mean, vec.lower, vec.upper, formater, min.best=T) {
    df.format = data.frame(
      is.best = vec.mean == ifelse(min.best, min(vec.mean, na.rm=T), max(vec.mean, na.rm=T)),
      mean = vec.mean,
      ci.defined = !is.na(vec.upper + vec.lower),
      ci.upper = vec.upper - vec.mean,
      ci.lower = vec.mean - vec.lower
    ) %>%
      rowwise() %>%
      mutate(
        formatted = ifelse(is.finite(mean),
                      ifelse(ci.defined,
                             paste0('$', latex.math.highlighter(formater(mean), is.best),' {~}^{+', formater(ci.upper), '}_{-', formater(ci.lower), '}$'),
                             paste0('$', latex.math.highlighter(formater(mean), is.best), '$')
                      ),
                      '---')
      )
    return(df.format$formatted)
  }

  align = c('c', 'r', 'l', 'l', 'l', 'l')
  header.1 = c("Op", "Model", "Success", "Solved at"=2, "Sparsity error")
  header.2 = c("", "", "Rate", "Median", "Mean", "Mean")

  if (!show.operation) {
    align = align[2:length(align)]
    header.1 = header.1[2:length(header.1)]
    header.2 = header.2[2:length(header.2)]
  }

  dat.table = dat.last.rate %>%
    group_by(operation) %>%
    mutate(
      success.rate = latex.ci.formater(success.rate.mean, success.rate.lower, success.rate.upper, latex.rate, min.best=F),
      converged.at.median = latex.formater(converged.at.median, latex.scientific),
      converged.at.mean = latex.ci.formater(converged.at.mean, converged.at.lower, converged.at.upper, latex.scientific),
      sparse.error = latex.ci.formater(sparse.error.mean, sparse.error.lower, sparse.error.upper, latex.scientific)
    ) %>%
    select(operation, model, success.rate, converged.at.median, converged.at.mean, sparse.error) %>%
    arrange(operation, model)

  no.pagebreak.rows =  which(head(dat.table$operation, -1) == tail(dat.table$operation, -1))

  if (!show.operation) {
    dat.table$operation = NULL
  }

  dat.table %>%
    kable(
      "latex", booktabs=T, align = align, escape=F, label=label,
      caption=caption,
      col.names = header.2,
      longtable=longtable
    ) %>%
    add_header_above(header.1) %>%
    kable_styling(latex_options=c('hold_position', 'repeat_header')) %>%
    row_spec(no.pagebreak.rows, extra_latex_after='\\nopagebreak') %>%
    collapse_rows(columns = ifelse(show.operation, c(1), c(1,2)), latex_hline = ifelse(show.operation, "major", "none")) %>%
    write(file.out)
}


#!/usr/bin/env Rscript

args = commandArgs(trailingOnly = TRUE)

if (length(args) != 1) {
    stop("Provide Motor Type (cim, 775) as Command Line Argument.")
}

if (args[1] == "cim") {
    rpm = 2670
} else if (args[1] == "775") {
    rpm = 9370
} else {
    rpm = 1
}

peakFile = paste(args[1], "-peak-power.csv", sep="")
stallFile = paste(args[1], "-stall-6v.csv", sep="")

peak <- read.csv(peakFile, header = TRUE)
stall <- read.csv(stallFile, header = TRUE)

x11()

peak$Torque = (9.5488 * peak$Power) / rpm

plot(peak$Time,
     peak$Torque,
     col="red",
     type="l",
     ylim=c(0, 1.3),
     xlim=c(0, 300),
     xlab="Time (s)",
     ylab="Torque (Nm)",
     main="Torque Output - Slipping vs Stalling")
points(stall$Time,
       stall$Torque,
       col="blue",
       type="l")
legend(x = "bottomright",
       legend = c("Slipping (Peak Power)", "Stalling (6 Volts)"),
       col = c("red", "blue"),
       lty = 1,
       bty = "n",
       cex = 0.8)

dev.print(png, "torque.png", width = 1000, height = 1000)

x11()

plot(peak$Time,
     peak$Current,
     col="red",
     type="l",
     ylim=c(0,70),
     xlim=c(0,300),
     ylab="Current (A)",
     xlab="Time(s)",
     main="Current Draw, Slipping vs Stalling")
points(stall$Time,
       stall$Amps,
       col="blue",
       type="l")

dev.print(png, "current.png", width = 1000, height = 1000)

x11()

peak$TorquePerAmp = 1000 * peak$Torque / peak$Current
stall$TorquePerAmp = 1000 * stall$Torque / stall$Amps

plot(peak$Time,
     peak$TorquePerAmp,
     col="red",
     type="l",
     ylim=c(0,30),
     ylab="Torque per Amp (mNm/A)",
     xlab="Time (s)",
     main="Torque per Amp, Slipping vs Stalling")
points(stall$Time,
       stall$TorquePerAmp,
       col="blue",
       type="l")

dev.print(png, "torque-per-amp.png", width = 1000, height = 1000)

Sys.sleep(1000)

# Do both draw the same current? We could plot this, or also Torque per Amp.


#' @inheritParams layer
#' @inheritParams geom_point
#' @section Computed variables:
#' \describe{
#'  \item{n}{number of observations at position}
#'  \item{prop}{percent of points in that panel at that position}
#' }
#' @export
#' @rdname geom_count
stat_sum <- function(mapping = NULL, data = NULL,
                     geom = "point", position = "identity",
                     ...,
                     na.rm = FALSE,
                     show.legend = NA,
                     inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatSum,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatSum <- ggproto("StatSum", Stat,
  default_aes = aes(size = after_stat(n), weight = 1),

  required_aes = c("x", "y"),

  compute_panel = function(data, scales) {
    if (is.null(data$weight)) data$weight <- 1

    group_by <- setdiff(intersect(names(data), ggplot_global$all_aesthetics), "weight")

    counts <- count(data, group_by, wt_var = "weight")
    counts <- rename(counts, c(freq = "n"))
    counts$prop <- stats::ave(counts$n, counts$group, FUN = prop.table)
    counts
  }
)


library(ggplot2)
library(geofacet)
library(broom)
library(maptools)
library(rgeos)
library(rgdal)
library(colorspace)
library(sf)
library(dplyr)
library(tidyr)
library(matrixStats)

source("usa/code/utils/read-data-usa.r")

plot_infectiousness_regions <- function(JOBID, StanModel, ext = ".pdf", last_date_data, individual = TRUE){
  data <- readRDS(paste0("usa/results/infectiousness_all_", JOBID, ".RDS"))
  data_set_raw <- do.call(rbind, data)

  df <- read_death_data("jhu")
  df <- select(df, code, region_census_sub_revised, date)

  data_set <- left_join(data_set_raw, df, by=c("state" = "code", "date")) %>%
    group_by(date, region_census_sub_revised) %>%
    summarise(infectioussness = sum(infectioussness),
              infectioussness_li = sum(infectioussness_li),
              infectioussness_ui = sum(infectioussness_ui),
              infectioussness_li2 = sum(infectioussness_li2),
              infectioussness_ui2 = sum(infectioussness_ui2))

  data_95 <- data.frame(data_set$date, data_set$region_census_sub_revised, data_set$infectioussness_li,
                        data_set$infectioussness_ui)
  names(data_95) <- c("date", "region", "i_min", "i_max")
  data_95$key <- rep("nintyfive", length(data_95$date))
  data_50 <- data.frame(data_set$date, data_set$region_census_sub_revised, data_set$infectioussness_li2,
                        data_set$infectioussness_ui2)
  names(data_50) <- c("date", "region", "i_min", "i_max")
  data_50$key <- rep("fifty", length(data_50$date))
  data <- rbind(data_95, data_50)
  #levels(data$key) <- c("ninetyfive", "fifty")

  load(paste0('usa/results/', StanModel, '-', JOBID, '-stanfit.Rdata'))
  out <- rstan::extract(fit)
  infections <- out$prediction

  inf_data <- NULL
  for (i in 1:length(states)){
    N <- length(dates[[i]])

    inf_states <- infections[,,i]
    means <- colMeans(inf_states[,1:N])
    li <- colQuantiles(inf_states[,1:N], probs = 0.025)
    ui <- colQuantiles(inf_states[,1:N], probs = 0.975)
    li2 <- colQuantiles(inf_states[,1:N], probs = 0.25)
    ui2 <- colQuantiles(inf_states[,1:N], probs = 0.75)

    inf_data_tmp <- data.frame("state" = rep(states[i], length(dates[[i]])),
                           "date" = dates[[i]],
                           "means" = means,
                           "li" = li,
                           "ui" = ui,
                           "li2" = li2,
                           "ui2" = ui2)
    inf_data <- rbind(inf_data, inf_data_tmp)
  }

  data_set_inf <- left_join(inf_data, df, by=c("state" = "code", "date")) %>%
    group_by(date, region_census_sub_revised) %>%
    summarise(infections = sum(means),
              infections_li = sum(li),
              infections_ui = sum(ui),
              infections_li2 = sum(li2),
              infections_ui2 = sum(ui2))

  data_95_inf <- data.frame(data_set_inf$date, data_set_inf$region_census_sub_revised, data_set_inf$infections_li,
                            data_set_inf$infections_ui)
  names(data_95_inf) <- c("date", "region", "i_min", "i_max")
  data_95_inf$key <- rep("nintyfive_inf", length(data_95_inf$date))
  data_50_inf <- data.frame(data_set_inf$date, data_set_inf$region_census_sub_revised, data_set_inf$infections_li2,
                            data_set_inf$infections_ui2)
  names(data_50_inf) <- c("date", "region", "i_min", "i_max")
  data_50_inf$key <- rep("fifty_inf", length(data_50_inf$date))
  data_inf <- rbind(data_95_inf, data_50_inf)
  #levels(data_inf$key) <- c("ninetyfive_inf", "fifty_inf")

  data_all <- rbind(data, data_inf)
  data_all$key <- factor(data_all$key, levels = c("nintyfive_inf",  "fifty_inf", "nintyfive", "fifty"))

  data_all$region_fac = factor(data_all$region, levels = c('Pacific', 'Great Plains', 'Northeast Corridor', 'Mountain','Great Lakes','Southern Appalachia', ' ', 'TOLA','South Atlantic'), ordered = T)

  p <- ggplot(data_all) +
    #geom_line(aes(x = date, y = infectioussness, group = state)) +
    geom_ribbon(aes(x = date, ymin = i_min, ymax = i_max, group = key, fill = key)) +
    ylab("\nNumber of people") + xlab("") +
    facet_wrap(~region_fac,  scales = "free", drop = F) +
    scale_x_date(date_breaks = "2 weeks", labels = date_format("%e %b"),
                 limits = c(as.Date("2020-02-5"), last_date_data)) +
    scale_y_continuous(labels = comma, expand=expansion(mult=c(0,0.1))) +
    scale_fill_manual(name = "", labels = c("# new infections [95% CI]", "# new infections [50% CI]", "# current infections [95% CI]",
                                            "# current infections [50% CI]"),
                      values = c(alpha("deepskyblue4", 0.45),
                                 alpha("deepskyblue4", 0.55),
                                 alpha("darkorchid", 0.45),
                                 alpha("darkorchid", 0.55))) +

    theme_bw() +
    theme(axis.text.x = element_text(angle = 45, hjust = 1),
          legend.position = "bottom",
          axis.text = element_text(size = 12),
          axis.title = element_text(size = 12),
          strip.background = element_rect(colour="black", fill="white"))

  g = ggplotGrob(p)
  empty = (g$layout$name %in% c("panel-3-1", "strip-t-1-3", 'axis-t-1-3', 'axis-b-1-3'))

  ## remove empty panels
  g$grobs[which(empty)] = NULL
  ## remove them from the layout
  g$layout = g$layout[!empty,]

  g = arrangeGrob(g)

  ggsave(paste0("usa/figures/", JOBID, "_infectiousness_regions", ext), g, width = 10, height = 10)
  print(paste0("saving usa/figures/", JOBID, "_infectiousness_regions", ext))

  regions <- read.csv("usa/data/usa-regions.csv", stringsAsFactors = FALSE)

  data_usa <- data_set %>%
    group_by(date) %>%
    summarise("total_infected_p" = sum(infectioussness)/sum(regions$pop_count)*100,
              "li_p" = sum(infectioussness_li)/sum(regions$pop_count)*100,
              "ui_p" = sum(infectioussness_ui)/sum(regions$pop_count)*100,
              "total_infected" = sum(infectioussness),
              "li" = sum(infectioussness_li),
              "ui" = sum(infectioussness_ui))

  # format(round(data_today$infectioussness, digits = -3), big.mark=",", trim=TRUE)

  if (individual == TRUE){
    data_set_states <- inf_data
    data_95 <- data.frame(data_set_states$date, data_set_states$state,
                          data_set_states$li, data_set_states$ui)
    names(data_95) <- c("date", "state", "i_min", "i_max")
    data_95$key <- rep("nintyfive_inf", length(data_95$date))
    data_50 <- data.frame(data_set_states$date, data_set_states$state,
                          data_set_states$li2, data_set_states$ui2)
    names(data_50) <- c("date", "state", "i_min", "i_max")
    data_50$key <- rep("fifty_inf", length(data_50$date))
    data <- rbind(data_95, data_50)

    data_95_inf <- data.frame(data_set_raw$date, data_set_raw$state, data_set_raw$infectioussness_li,
                          data_set_raw$infectioussness_ui)
    names(data_95_inf) <- c("date", "state", "i_min", "i_max")
    data_95_inf$key <- rep("nintyfive", length(data_95_inf$date))
    data_50_inf <- data.frame(data_set_raw$date, data_set_raw$state, data_set_raw$infectioussness_li2,
                          data_set_raw$infectioussness_ui2)
    names(data_50_inf) <- c("date", "state", "i_min", "i_max")
    data_50_inf$key <- rep("fifty", length(data_50_inf$date))
    data_inf <- rbind(data_95_inf, data_50_inf)

    data_all <- rbind(data, data_inf)
    data_all$key <- factor(data_all$key, levels = c("nintyfive_inf",  "fifty_inf", "nintyfive", "fifty"))

    for (i in 1:length(states)){
      data_subset = data_all[which(data_all$state == states[i]),]
      p <- ggplot(data_subset) +
        #geom_line(aes(x = date, y = infectioussness, group = state)) +
        geom_ribbon(aes(x = date, ymin = i_min, ymax = i_max, group = key, fill = key)) +
        ylab("\nNumber of people") + xlab("") +
        scale_x_date(date_breaks = "2 weeks", labels = date_format("%e %b"),
                     limits = c(as.Date("2020-02-5"), last_date_data)) +
        scale_y_continuous(labels = comma, expand=expansion(mult=c(0,0.1))) +
        scale_fill_manual(name = "", labels = c("# new infections [95% CI]", "# new infections [50% CI]", "# current infections [95% CI]",
                                                "# current infections [50% CI]"),
                          values = c(alpha("deepskyblue4", 0.45),
                                     alpha("deepskyblue4", 0.55),
                                     alpha("darkorchid", 0.45),
                                     alpha("darkorchid", 0.55))) +

        theme_bw() +
        theme(axis.text.x = element_text(angle = 45, hjust = 1),
              #legend.position = "None",
              axis.text = element_text(size = 12),
              axis.title = element_text(size = 12),
              strip.background = element_rect(colour="black", fill="white"))
      ggsave(paste0("usa/figures/",states[[i]], "_", JOBID, "_infectiousness", ext), p, height = 10, width = 14)

    }
  }
}


#' Convenient Computation of Powers
#'
#' Are you tired of using the power operator, \code{^} or \code{**} in R?
#' Use this package to call functions that apply common powers
#' to your vectors.
#'
#' @name powers
#' @author Vincenzo Coia
#' @note This package isn't actually meant to be serious. It's just for
#' teaching purposes.
#' @docType package
NULL


context("Trans - numeric")

test_that("Pseudo-log is invertible", {
  trans <- pseudo_log_trans()
  expect_equal(
    trans$inverse(trans$transform(-10:10)),
    -10:10
  )
})

test_that("Modulus is invertible for negative and positive numbers", {
  trans <- modulus_trans(p = .1)
  expect_equal(trans$inv(trans$trans(-10:10)), -10:10)
  trans <- modulus_trans(p = -2)
  expect_equal(trans$inv(trans$trans(-10:10)), -10:10)
  trans <- modulus_trans(p = 1)
  expect_equal(trans$inv(trans$trans(-10:10)), -10:10)
})

test_that("Boxcox gives error for negative values", {
  trans <- boxcox_trans(p = .1)
  expect_error(trans$trans(-10:10))
  trans <- boxcox_trans(p = -2)
  expect_error(trans$trans(-10:10))
})

test_that("Boxcox can handle NA values", {
  trans <- boxcox_trans(p = 0)
  expect_equal(trans$trans(c(1, NA_real_)), c(0, NA_real_))
})

test_that("Boxcox is invertible", {
  trans <- boxcox_trans(p = .1)
  expect_equal(trans$inv(trans$trans(0:10)), 0:10)
  trans <- boxcox_trans(p = -2)
  expect_equal(trans$inv(trans$trans(0:10)), 0:10)
  trans <- boxcox_trans(p = 1)
  expect_equal(trans$inv(trans$trans(0:10)), 0:10)
})

test_that("Yeo-Johnson is invertible", {
  x <- c(-12345, 12345, -0.12345, 0.12345, -10:10)

  trans <- yj_trans(p = -1.5)
  expect_equal(trans$inverse(trans$transform(x)), x)

  trans <- yj_trans(p = 0)
  expect_equal(trans$inverse(trans$transform(x)), x)

  trans <- yj_trans(p = 0.7)
  expect_equal(trans$inverse(trans$transform(x)), x)

  trans <- yj_trans(p = 1.5)
  expect_equal(trans$inverse(trans$transform(x)), x)

  trans <- yj_trans(p = 2)
  expect_equal(trans$inverse(trans$transform(x)), x)
})

test_that("Yeo-Johnson is identity function for p = 1", {
  x <- c(-12345, 12345, -0.12345, 0.12345, -10:10)
  trans <- yj_trans(p = 1)
  expect_equal(trans$transform(x), x)
})

test_that("Yeo-Johnson transforms NAs to NAs without error", {
  x <- c(1, 2, NA, 4)
  trans <- yj_trans(p = 1)
  expect_equal(trans$transform(x), x)
})

test_that("Yeo-Johnson transform works", {
  # example data adpated from recipes package
  # https://github.com/tidymodels/recipes/blob/master/tests/testthat/test_YeoJohnson.R
  n <- 20
  set.seed(1)
  x <- data.frame(
    x1 = exp(rnorm(n, mean = .1)),
    x2 = 1/rnorm(n),
    x3 = rexp(n)
  )

  lambdas <- c(
    x1 = -0.2727204451,
    x2 =  1.139292543,
    x3 = -1.012702061)

  expected_data <- data.frame(
    x1 = c(0.435993557749438, 0.754696454247318, 0.371327932207827,
           1.46113017436327, 0.82204097731098, 0.375761562702297, 0.89751975937422,
           1.02175936118846, 0.940739811377902, 0.54984302797741, 1.41856737837093,
           0.850587387615876, 0.437701618670981, 0.112174615510591, 1.21942112715274,
           0.654589551748501, 0.666780580127795, 1.12625135443351, 1.0636850911955,
           0.949680956411546),
    x2 = c(1.15307873387121, 1.36532999080347,
           17.4648439780388, -0.487746797875704, 1.74452440065935, -13.3640721541574,
           -5.35805967319061, -0.653901985285932, -1.90735599477338, 2.65253432454371,
           0.76771137336975, -7.79484535687973, 2.87484976680907, -13.8738947581599,
           -0.696856395842167, -2.17745353101028, -2.28384276604207, -12.7261652971783,
           0.95585544349634, 1.40099012093008),
    x3 = c(0.49061104973894, 0.49670370366879, 0.338742419511653,
           0.663722100577351, 0.296260662322359, 0.681346128666408,
           0.757581280603711, 0.357148961119583, 0.371872889850153,
           0.49239057672598, 0.173259524331095, 0.235933290139909, 0.52297977893566,
           0.434927187456966, 0.0822501770191215, 0.523479652016858,
           0.197977570919824, 0.608108816144845, 0.821913792446345,
           0.300608495427594))

  expect_equal(yj_trans(lambdas[1])$transform(x[[1]]), expected_data[[1]])
  expect_equal(yj_trans(lambdas[2])$transform(x[[2]]), expected_data[[2]])
  expect_equal(yj_trans(lambdas[3])$transform(x[[3]]), expected_data[[3]])
})


# A list is basically a vector in which all the elements can br of a different type

# Creating list
# Lists can be created using the list() function
# It works similar to the c() function we saw in the previous lesson.

myList <- list(1, 1+1i, 'a', TRUE)
print(myList)
is.recursive(myList)

# Inserting elements in a List
myList <- c('s', myList)
cat("Appending 's' at the start of thr vector: \n")
print(myList)

# Accesing and modifying lists
print(myList[4])
print(myList[[4]])

myList[[4]] = "vaca"

# Named entries in list
myList <- list(
            integerVar = 1:3,
            numericVar = 0.4,
            characterVar = c('a', 'b')
            )

print(myList['integerVar']) # prints the name as well as the value

print(myList[['integerVar']]) # prints only the value


x <- paste(rep("", 100), c("", "", "Fizz"), c("", "", "", "", "Buzz"), sep="")
cat(ifelse(x == "", 1:100, x), "\n")


library(shiny)

ui <- pageWithSidebar(
  headerPanel('Iris k-means clustering'),
  sidebarPanel(
    selectInput('xcol', 'X Variable', names(iris)),
    selectInput('ycol', 'Y Variable', names(iris),
                selected=names(iris)[[2]]),
    numericInput('clusters', 'Cluster count', 3,
                 min = 1, max = 9)
  ),
  mainPanel(
    plotOutput('plot1')
  )
)


# Exercise 7: Husky Football 2015 Season
# Read in the Husky Football 2015 game data into a variable called `husky.games.2015`
husky.games.2015 <- read.csv('data/huskies_2015.csv')

# Create a vector of the teams that the Huskies played against during that season
# Call this vector `not.huskies`. You'll need to convert this column to a vector
not.huskies <- husky.games.2015$opponent

# Create a vector of the their final scores for the games
# Call this variable `husky.scores`
husky.scores <- husky.games.2015$uw_score

# Create 2 variables called `rushing.yards` and `passing.yards` to represent the yards the Huskies rushed and passed
rushing.yards <- husky.games.2015$rushing_yards
passing.yards <- husky.games.2015$passing_yards

# Create a variabled called `combined.yards` that is the total yardage of the Huskies for each game
combined.yards <- rushing.yards + passing.yards

# What is the score of the game where the Huskies had the most combined yards?
max(combined.yards,na.rm = FALSE)

# Write a function `MostYardsScore` that takes in a dataframe parameter `games` and returns a descriptive sentence
# about the game that was played that had the most yards scored in it.
# Take note of the steps from above including the opposing team, score, and date the game was played
MostYardsScore <- function(games) {

  dates <- as.vector(games$date)
  scores <- games$uw.score
  opponents <- as.vector(games$opponent)

  rushing.yards <- games$rushing.yards
  passing.yards <- games$passing.yards
  combined.yards <- passing.yards + rushing.yards

  most.yards <- max(combined.yards,na.rm = FALSE)
  opponent <- opponents[combined.yards == most.yards]
  date <- dates[combined.yards == most.yards]
  highest.score <- scores[combined.yards == most.yards]

  return(paste("The game that the Huskies had the most yards was against", opponent, "on", date, "where they scored", highest.score, "points!"))
}

# What was the highest yardage game so far this season?
# Hint: Read in the dataset titled `huskies_2016.csv` and save it as a variable
husky.games.2016 <- read.csv('data/huskies_2016.csv')
most.yards.2016 <- MostYardsScore(husky.games.2016)


\name{hc_segmented_points-HilbertCurve-method}
\alias{hc_segmented_points,HilbertCurve-method}
\alias{hc_segmented_points}
\title{
Add points to the Hilbert curve
}
\description{
Add points to the Hilbert curve
}
\usage{
\S4method{hc_segmented_points}{HilbertCurve}(object, ir = NULL, x1 = NULL, x2 = NULL, gp = gpar(),
    np = max(c(2, 10 - hc_level(object))),
    mean_mode = c("w0", "absolute", "weighted", "max_freq"),
    shape = "circle")
}
\arguments{

  \item{object}{A \code{\link{HilbertCurve-class}} object.}
  \item{ir}{an \code{\link[IRanges:IRanges-constructor]{IRanges}} object which specifies the input intervals.}
  \item{x1}{if start positions are not integers, they can be set by \code{x1}.}
  \item{x2}{if end positions are not integers, they can be set by \code{x2}.}
  \item{np}{number of points (a circle or a square, ...) that are put in a segment.}
  \item{gp}{graphic parameters for points. It should be specified by \code{\link[grid]{gpar}}. The size of the points can be set here because the size of points are determined by \code{np} argument.}
  \item{mean_mode}{when a segment in the curve overlaps with intervals in \code{ir}, how to calculate  the mean values for this segment. See explanation in \code{\link{hc_points}}.}
  \item{shape}{shape of points. Possible values are "circle", "square", "triangle", "hexagon", "star".}

}
\details{
Every segment on the curve is split by \code{np} points.

This function is used internally, please use \code{\link{hc_points,HilbertCurve-method}} directly.
}
\value{
A data frame which contains coordinates (in the 2D space) of points.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
# see documentation of hc_points
NULL
}


#!/usr/bin/env Rscript
#
# Use a weighted linear regression to test for differences in read depth
# among treatments. The weights come from the total number of aligned
# reads.
#
#   read_depth_test.r <file with group 1 input files>
#       <file with group 2 input files>
#
#==============================================================================#

cargs = commandArgs(trailingOnly=TRUE)
group_1 = scan(cargs[1], what='character')
group_2 = scan(cargs[2], what='character')

trtmnt = c(rep('a', length(group_1)),
           rep('b', length(group_2)))

data_sets = lapply(c(group_1, group_2),
                   function(x) read.csv(x, sep='\t',
                                        stringsAsFactors=FALSE,
                                        check.names=FALSE,
                                        comment.char='#',
                                        header=TRUE))
n_genes = nrow(data_sets[[1]])

same_gene = sapply(1:n_genes,
                   function(i) {
                       genes = sapply(data_sets,
                                       function(x) x[i, 'name'])
                       all(genes == genes[1])
                    })
if(!all(same_gene))
    stop('Gene names do not match')

cat('contig\tstart\tend\tgene\tp\teffect\trpkm1\trpkm2\n', file=stdout())
for(i in 1:n_genes) {
    contig = data_sets[[1]][i, 'chrom']
    start_pos = data_sets[[1]][i, 'start']
    end_pos = data_sets[[1]][i, 'end']
    gene = data_sets[[1]][i, 'name']

    raw_counts = sapply(data_sets, function(x) x[i, 'count'])
    cpm = sapply(data_sets, function(x) x[i, 'count (CPM)'])
    rpkm = sapply(data_sets, function(x) x[i, 'RPKM'])

    if(sum(raw_counts[trtmnt == 'a'] != 0) > 0 &&
       sum(raw_counts[trtmnt == 'b'] != 0) > 0) {
        trts = trtmnt[raw_counts > 0]
        cpm = cpm[raw_counts > 0]
        rpkm = rpkm[raw_counts > 0]
        raw_counts = raw_counts[raw_counts > 0]
        wts = raw_counts / cpm

        test_results = lm(rpkm ~ trts, weights=wts)
        effect = coefficients(test_results)['trtsb']
        p = coefficients(summary(test_results))['trtsb', 'Pr(>|t|)']
    } else {
        p = NaN
        effect = NaN
    }
    cat(paste(contig, start_pos, end_pos, gene, p, effect, sep='\t'),
        '\t', paste(round(rpkm[trts == 'a'], 3), collapse=','),
        '\t', paste(round(rpkm[trts == 'b'], 3), collapse=','),
        '\n', sep='', file=stdout())
}


function (x, y, n = 10, k = 3, a = 1, spl = c(1:30))
{
    o <- matrix(0, n, 2)
    for (i in c(1:n)) {
        s <- c(spl[order(runif(length(spl)))], spl[order(runif(length(spl)))])
        xtrn <- x[s > k, ]
        ytrn <- y[s > k]
        xtst <- x[s <= k, ]
        ytst <- y[s <= k]
        m <- cv.glmnet(x = xtrn, y = ytrn, family = "binomial",
            alpha = a)
        p <- predict(m, xtst)
        o[i, 1] <- mean((p > 0) == ytst)
        o[i, 2] <- m$nzero[m$lambda == m$lambda.min]
        print(paste("Round", round(i, 2), "CVAcc:", o[i, 1],
            "Nonzero:", o[i, 2]))
        flush.console()
    }
    o
}


# -----------------------------------------------------------------------------
# logs
# -----------------------------------------------------------------------------

#' Logarithms and Exponentials
#'
#' exp/log functions.
#'
#' @param x
#' A float vector/matrix.
#' @param base
#' The logarithm base.
#'
#' @return
#' A float vector/matrix of the same dimensions as the input.
#'
#' @examples
#' \dontrun{
#' library(float)
#'
#' x = flrunif(10)
#' log(x)
#' }
#'
#' @useDynLib float R_exp_spm R_expm1_spm R_log_spm R_log10_spm R_log2_spm
#' @name log
#' @rdname log
NULL

exp_float32 = function(x)
{
  ret = .Call(R_exp_spm, DATA(x))
  float32(ret)
}

expm1_float32 = function(x)
{
  ret = .Call(R_expm1_spm, DATA(x))
  float32(ret)
}

log_float32 = function(x, base=exp(1))
{
  if (is.float(base))
    base = dbl(base[1])

  ret = .Call(R_log_spm, DATA(x), as.double(base))
  float32(ret)
}

log10_float32 = function(x)
{
  ret = .Call(R_log10_spm, DATA(x))
  float32(ret)
}

log2_float32 = function(x)
{
  ret = .Call(R_log2_spm, DATA(x))
  float32(ret)
}

#' @rdname log
#' @export
setMethod("exp", signature(x="float32"), exp_float32)

#' @rdname log
#' @export
setMethod("expm1", signature(x="float32"), expm1_float32)

#' @rdname log
#' @export
setMethod("log", signature(x="float32"), log_float32)

#' @rdname log
#' @export
setMethod("log10", signature(x="float32"), log10_float32)

#' @rdname log
#' @export
setMethod("log2", signature(x="float32"), log2_float32)

# -----------------------------------------------------------------------------
# trig
# -----------------------------------------------------------------------------

#' Trigonometric functions
#'
#' Basic trig functions.
#'
#' @param x
#' A float vector/matrix.
#'
#' @return
#' A float vector/matrix of the same dimensions as the input.
#'
#' @examples
#' \dontrun{
#' library(float)
#'
#' x = flrunif(10)
#' sin(x)
#' }
#'
#' @useDynLib float R_sin_spm R_cos_spm R_tan_spm R_asin_spm R_acos_spm R_atan_spm
#' @name trig
#' @rdname trig
NULL

sin_float32 = function(x)
{
  ret = .Call(R_sin_spm, DATA(x))
  float32(ret)
}

cos_float32 = function(x)
{
  ret = .Call(R_cos_spm, DATA(x))
  float32(ret)
}

tan_float32 = function(x)
{
  ret = .Call(R_tan_spm, DATA(x))
  float32(ret)
}

asin_float32 = function(x)
{
  ret = .Call(R_asin_spm, DATA(x))
  float32(ret)
}

acos_float32 = function(x)
{
  ret = .Call(R_acos_spm, DATA(x))
  float32(ret)
}

atan_float32 = function(x)
{
  ret = .Call(R_atan_spm, DATA(x))
  float32(ret)
}

#' @rdname trig
#' @export
setMethod("sin", signature(x="float32"), sin_float32)

#' @rdname trig
#' @export
setMethod("cos", signature(x="float32"), cos_float32)

#' @rdname trig
#' @export
setMethod("tan", signature(x="float32"), tan_float32)

#' @rdname trig
#' @export
setMethod("asin", signature(x="float32"), asin_float32)

#' @rdname trig
#' @export
setMethod("acos", signature(x="float32"), acos_float32)

#' @rdname trig
#' @export
setMethod("atan", signature(x="float32"), atan_float32)

# -----------------------------------------------------------------------------
# hyperbolic
# -----------------------------------------------------------------------------

#' Hyperbolic functions
#'
#' Hyperbolic functions.
#'
#' @param x
#' A float vector/matrix.
#'
#' @return
#' A float vector/matrix of the same dimensions as the input.
#'
#' @examples
#' \dontrun{
#' library(float)
#'
#' x = flrunif(10)
#' sinh(x)
#' }
#'
#' @useDynLib float R_sinh_spm R_cosh_spm R_tanh_spm R_asinh_spm R_acosh_spm R_atanh_spm
#' @name hyperbolic
#' @rdname hyperbolic
NULL

sinh_float32 = function(x)
{
  ret = .Call(R_sinh_spm, DATA(x))
  float32(ret)
}

cosh_float32 = function(x)
{
  ret = .Call(R_cosh_spm, DATA(x))
  float32(ret)
}

tanh_float32 = function(x)
{
  ret = .Call(R_tanh_spm, DATA(x))
  float32(ret)
}

asinh_float32 = function(x)
{
  ret = .Call(R_asinh_spm, DATA(x))
  float32(ret)
}

acosh_float32 = function(x)
{
  ret = .Call(R_acosh_spm, DATA(x))
  float32(ret)
}

atanh_float32 = function(x)
{
  ret = .Call(R_atanh_spm, DATA(x))
  float32(ret)
}

#' @rdname hyperbolic
#' @export
setMethod("sinh", signature(x="float32"), sinh_float32)

#' @rdname hyperbolic
#' @export
setMethod("cosh", signature(x="float32"), cosh_float32)

#' @rdname hyperbolic
#' @export
setMethod("tanh", signature(x="float32"), tanh_float32)

#' @rdname hyperbolic
#' @export
setMethod("asinh", signature(x="float32"), asinh_float32)

#' @rdname hyperbolic
#' @export
setMethod("acosh", signature(x="float32"), acosh_float32)

#' @rdname hyperbolic
#' @export
setMethod("atanh", signature(x="float32"), atanh_float32)

# -----------------------------------------------------------------------------
# misc
# -----------------------------------------------------------------------------

#' Miscellaneous mathematical functions
#'
#' Miscellaneous mathematical functions.
#'
#' @param x
#' A float vector/matrix.
#'
#' @return
#' A float vector/matrix of the same dimensions as the input.
#'
#' @examples
#' \dontrun{
#' library(float)
#'
#' x = flrunif(10)
#' sqrt(x)
#' }
#'
#' @useDynLib float R_abs_spm R_sqrt_spm
#' @name miscmath
#' @rdname miscmath
NULL

abs_float32 = function(x)
{
  ret = .Call(R_abs_spm, DATA(x))
  float32(ret)
}

sqrt_float32 = function(x)
{
  ret = .Call(R_sqrt_spm, DATA(x))
  float32(ret)
}

#' @rdname miscmath
#' @export
setMethod("abs", signature(x="float32"), abs_float32)

#' @rdname miscmath
#' @export
setMethod("sqrt", signature(x="float32"), sqrt_float32)

# -----------------------------------------------------------------------------
# special
# -----------------------------------------------------------------------------

#' Special mathematical functions
#'
#' Special mathematical functions.
#'
#' @param x
#' A float vector/matrix.
#'
#' @return
#' A float vector/matrix of the same dimensions as the input.
#'
#' @examples
#' \dontrun{
#' library(float)
#'
#' x = flrunif(10)
#' lgamma(x)
#' }
#'
#' @useDynLib float R_gamma_spm R_lgamma_spm
#' @name specialmath
#' @rdname specialmath
NULL

gamma_float32 = function(x)
{
  ret = .Call(R_gamma_spm, DATA(x))
  float32(ret)
}

lgamma_float32 = function(x)
{
  ret = .Call(R_lgamma_spm, DATA(x))
  float32(ret)
}

#' @rdname specialmath
#' @export
setMethod("gamma", signature(x="float32"), gamma_float32)

#' @rdname specialmath
#' @export
setMethod("lgamma", signature(x="float32"), lgamma_float32)

# -----------------------------------------------------------------------------
# mathis
# -----------------------------------------------------------------------------

#' Finite, infinite, and NaNs
#'
#' Finite, infinite, and NaNs.
#'
#' @param x
#' A float vector/matrix.
#'
#' @return
#' An integer vector/matrix of the same dimensions as the input.
#'
#' @examples
#' \dontrun{
#' library(float)
#'
#' x = flrnorm(10)
#' is.nan(sqrt(x))
#' }
#'
#' @useDynLib float R_isfinite_spm R_isinfinite_spm R_isnan_spm
#' @name mathis
#' @rdname mathis
NULL

is.finite_float32 = function(x)
{
  .Call(R_isfinite_spm, DATA(x))
}

is.infinite_float32 = function(x)
{
  .Call(R_isinfinite_spm, DATA(x))
}

is.nan_float32 = function(x)
{
  .Call(R_isnan_spm, DATA(x))
}

#' @rdname mathis
#' @export
setMethod("is.finite", signature(x="float32"), is.finite_float32)

#' @rdname mathis
#' @export
setMethod("is.infinite", signature(x="float32"), is.infinite_float32)

#' @rdname mathis
#' @export
setMethod("is.nan", signature(x="float32"), is.nan_float32)

# -----------------------------------------------------------------------------
# rounding
# -----------------------------------------------------------------------------

#' Round
#'
#' Rounding functions.
#'
#' @param x
#' A float vector/matrix.
#' @param digits
#' The number of digits to use in rounding.
#' @param ...
#' ignored
#'
#' @return
#' A float vector/matrix of the same dimensions as the input.
#'
#' @examples
#' library(float)
#'
#' x = flrnorm(10)
#' floor(x)
#'
#' @useDynLib float R_ceiling_spm R_floor_spm R_trunc_spm R_round_spm
#' @name round
#' @rdname round
NULL

ceiling_float32 = function(x)
{
  ret = .Call(R_ceiling_spm, DATA(x))
  float32(ret)
}

floor_float32 = function(x)
{
  ret = .Call(R_floor_spm, DATA(x))
  float32(ret)
}

trunc_float32 = function(x, ...)
{
  ret = .Call(R_trunc_spm, DATA(x))
  float32(ret)
}

round_float32 = function(x, digits=0)
{
  ret = .Call(R_round_spm, DATA(x), as.double(digits))
  float32(ret)
}

#' @rdname round
#' @export
setMethod("ceiling", signature(x="float32"), ceiling_float32)

#' @rdname round
#' @export
setMethod("floor", signature(x="float32"), floor_float32)

#' @rdname round
#' @export
setMethod("trunc", signature(x="float32"), trunc_float32)

#' @rdname round
#' @export
setMethod("round", signature(x="float32"), round_float32)


# Review code, this should help reviewers to validate the code, note that tests were also added in the Rcode/tests folder.
# We first run the code for the Ro_testdata_mbr project, and then come back step by step.
# in the second part, we use the dataset created to test that the SVM analysis runs.

## input variables, similar as in master_noshiny.r

setwd("analysis")
library (randomForest)
library (ica)
library (e1071) #svm
require(Hmisc)   #binomial confidence
require (plotly)
library (rstatix) #effect size calculation
library (coin) #effect size calculation
library(osfr) ##access to osf
library (tidyverse)
library (stringr)
library(gridExtra)
library(RGraphics)
source ("Rcode/functions.r")

version = "noused"
PMeta ="../data/Projects_metadata.csv"

RECREATEMINFILE= T # set to true if you want to recreate an existing min file, otherwise the code will create one only if it cannot find an exisiting one.
NO_svm = TRUE

# variable grouping, only working with HCS data at the moment.
groupingby =  "Berlin" #"Jhuang" # other possibilities:"Berlin" #
# choosing time windows for the analysis
selct_TW = c(8:9)

Npermutation = 1 # number of permutation to perform. set to 1 if testing (42 s per run with AOCF designation,30s with MIT)

Name_project ="Ro_testdata_mbr"

## run code
source ("master_shiny.r")

#################---------------------#################
#################---------------------#################
#################---------------------#################

## review process point by point

## experiment metadata: (read in input.r file, saved with the data in Min_Ro_testdata_mbr.csv)
## ----------------------------------------------

metadata # information about animals and lab (light on and light off time) as entered in the metadata files,
#### depending of the type of input data used (minute summary, mbr files), links to data files are either here
metadata$Onemin_summary
#### or here
metadata$primary_behav_sequence

#### grouping variable (created in animal_groups.r from master metadata file entry)
metadata$groupingvar
metadata$confoundvar # confounding variables not interesting to test, but grouping may help statistics

## The data (MIN_data, written to  Min_Ro_testdata_mbr.csv)
## ----------------------------------------------

# create_minfile.r code read, and pull together the data, its output is saved in the Min_Ro_testdata_mbr file, available in the data folder.
# Unless the input is hourly summary, it is a minute summary file, giving the amount of time doing each behavior for each minute of experiment.
# metadata and relation to light on/off time is added to the data.
MIN_data

# The file created by R from the raw behavior sequence should be very similar to identical to the excel file information created with the home cage scan software.
#compare for instance:
View(MIN_data %>% filter (ID =="100"))
# with 150609_Testdata_HCS_groupB/150609_Testdata_HCS_min_2.xlsx

## the time-windowed summary data (Multi_datainput, written to timedwindowed_Ro_testdata_mbr.csv)
## this will become the input for the analysis (PCR, random forest, svm)
## ----------------------------------------------

## timewindows are created, only non-empty ones are displayed (depends on the length of the experiment)
Timewindows

## for each selected time window
selct_TW
## the code takes minutes summary for each meta-behavior (2 grouping choice possible at the moment berlin, jhuang),
names(behav_gp)
## and calculates the percentage of time spent doing each one, in each time window, based on the function get_windowsummary()
## its output is Multi_datainput, (metadata is not included, only animal ID is present)
unique(Multi_datainput$ID)

# one number (representing the time window) is added to each metabehavior name in the header
names(Multi_datainput)

## Analysis
## ID is replaced by groupingvar (and confoundvar if exists) in Multi_datainput_m (or Multi_datainput_m2)
Multi_datainput_m$groupingvar

## random forest + ICA: RF_selection_2rounds.r, ICA.r

RF_selec # selection of Multi_datainput_m, with a minimum of 8 variables
# all variables having a MeanDecreaseGini > 0.95,
# theoretical maximum of variables is 20, because 20 are chosen after a first random forest.

pls2 # 3d plot of the results of the ICA done over RF_select, groups as color

## PCA analysis
# done over Multi_datainput_m,

Moddata #output with each principal components
Moddata$PC1 # first principal components where statistics is done

###------------------#####
###------------------#####
###------------------#####

###  SVM tests
## Multi_datainput_m is the only input of the svm analysis

Npermutation = 1 # make sure only one permutation is done.

## data input:
#source ("analysis/reviews_and_tests.r") # set working directory to project first.

#seed was set to 74 in master_shiny.r

# prepare extra data to test multiple groups groups:
Multi_datainput_moriginal = Multi_datainput_m

Multi_datainput_mplus = Multi_datainput_moriginal
Multi_datainput_mplus$groupingvar = "third"

# test 1: do not run if groups are not equal

Multi_datainput_m= rbind(Multi_datainput_moriginal, Multi_datainput_mplus
)

source ("Rcode/svmtest.r")
if (!NO_svm){ source ("Rcode/svmperf.r") } # will not run

# put same number of data per group
Multi_datainput_m = Multi_datainput_m [1:30,]

# test 2: run with 3 groups of 10
NO_svm = FALSE
source ("Rcode/svmtest.r")
if (!NO_svm){ source ("Rcode/svmperf.r") } # not run
# run the code for 3 groups, get 3 text outputs (takes time, as 3x one permutation is done)
p1
p2
p3

# test 3: with more than 15 animals per group: run testset and trainset (2 groups)

Multi_datainput_mplus = Multi_datainput_moriginal
Multi_datainput_m= rbind(Multi_datainput_moriginal, Multi_datainput_mplus
)

NO_svm = FALSE
source ("Rcode/svmtest.r")
if (!NO_svm){ source ("Rcode/svmperf.r") }

trainset$groupingvar
testset$groupingvar
Accuracy

# Accuracy very good:
# trying more permutation to see whether there is a chance problem:

Npermutation = 30
if (!NO_svm){ source ("Rcode/svmperf.r") }
hist(Acc_sampled, breaks=c(0:15)/15*2-1)
abline(v = Accuracyreal, col="Red")
beepr::beep()
Npermutation = 10
Acc_sampled = c()

# High Accuracyreal indeed due to chance, of course when test data are part of train data, it does not work !

# test 4: 2-out validation with 2 groups, with original data
Multi_datainput_m = Multi_datainput_moriginal

NO_svm = FALSE
source ("Rcode/svmtest.r")
if (!NO_svm){ source ("Rcode/svmperf.r") }
Accuracyreal

# Accuracyreal is very low, but it does not seem to be a bug:
# if we change data to make difference between groups bigger, and run it again:
Multi_datainput_m = Multi_datainput_moriginal
Multi_datainput_m [11:20, 3] = 3*Multi_datainput_m [11:20, 3]
Multi_datainput_m [11:20, 4] = Multi_datainput_m [11:20, 4]- 2*Multi_datainput_m [11:20, 3] # total will still 1

Multi_datainput_m [1:20, 3]
Multi_datainput_m [1:20, 4]

# PCA strategy leads to huge difference:
source ("Rcode/PCA_strategy.r")
boxplotPCA1

# run svm
NO_svm = FALSE
source ("Rcode/svmtest.r")
if (!NO_svm){ source ("Rcode/svmperf.r") }

Accuracyreal

# Accuracyreal is still very low, probably a issue with svm not being good in 2-out validation, or a specific issue with this kind of data ?
# indeed, when looking into it, the svm tuning does not find any good parameter for the svm even for the training data, so no  surprise it can not predict the test data.
objR$best.performance # the lower this score, the better the performance.

# get original dataset for further use:

Multi_datainput_moriginal -> Multi_datainput_m


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))

# Set themes
file_extensions <- c(".png", ".pdf")

plot_theme <- theme(
    title = element_text(size = 9),
    axis.title = element_text(size = 9),
    legend.text = element_text(size = 7),
    legend.title = element_text(size = 9),
    legend.key.size = unit(0.5, "cm"),
    strip.text = element_text(size = 10),
    strip.background = element_rect(colour="black", fill="#fdfff4")
)

# Load L2 distances per MOA
cp_file <- file.path("data", "MOA_LSA_metrics.tsv")
cp_df <- readr::read_tsv(cp_file)

cp_df$model <- factor(
    cp_df$model,
    levels = c("Vanilla", "Beta", "MMD", "PCA", "Complete")
)

head(cp_df)

# Compare performance means across architectures
cp_mean_df <- cp_df %>%
    dplyr::group_by(model, metric) %>%
    dplyr::mutate(
        model_mean = round(mean(zscore), 2)
    ) %>%
    dplyr::select(model, metric, model_mean) %>%
    dplyr::distinct()

cp_mean_df

plot_gg <- (
    ggplot(cp_df, aes(x=zscore))
    + geom_histogram(aes(y = ..density..), bins = 30)
    + geom_density()
    + geom_text(
        data=cp_mean_df,
        aes(x = -3, y = 0.5, label = paste0("Mean: ", model_mean))
    )
    + geom_vline(
        data=cp_mean_df,
        aes(xintercept = model_mean),
        color = "red",
        linetype="dashed"
    )
    + geom_vline(
        xintercept = 0,
        linetype = "dashed",
        color = "blue"
    )
    + facet_grid("model~metric")
    + theme_bw()
    + xlim(c(-5, 5))
    + plot_theme
    + geom_rect(
        data = cp_df %>%
            dplyr::filter(model == "MMD"),
        fill = NA,
        alpha = 1,
        color = "red",
        linetype = "solid",
        size = 2,
        xmin = -Inf,
        xmax = Inf,
        ymin = -Inf,
        ymax = Inf
    )
    + ylab("Density")
    + xlab("Z-score of metrics (L2 distance or Pearson correlation) for LSA predictions of\nground truth (per polypharmacology state) compared to 10 randomly shuffled LSA permutations")

)
plot_gg

# Save figure
output_file_base <- file.path("output", "sup_fig_lsa_metrics")
for (file_extension in file_extensions) {
    output_file <- paste0(output_file_base, file_extension)
    ggplot2::ggsave(output_file, plot_gg, dpi = 500, width = 8, height = 8)
}


#' Longest Common Substring
#'
#' it takes two strings
#' @param aString and bString are two strings
#' @return the Longest Common SubString.
#' @import stringr
#' @export
#'

library(stringr)

LCStr <- function(aString, bString, minLen){

  LCS = matrix(data = 0,nrow = nchar(aString)+1, ncol = nchar(bString)+1)
  lengthOfSubstring = -1
  finalIndex = -1

  for(i in 1:nchar(aString)+1){
    a<-str_sub(aString, i-1, i-1)
    for (j in 1:nchar(bString)+1){
      b<-str_sub(bString, j-1, j-1)
      if(a==b){
        LCS[i,j] = LCS[i-1,j-1]+1
        if (lengthOfSubstring < LCS[i,j]){
          lengthOfSubstring = LCS[i,j]
          finalIndex = i
        }
      }
      else{
        LCS[i,j] = 0
      }
    }
  }

  if (lengthOfSubstring > minLen){
    return (str_sub(aString, finalIndex-lengthOfSubstring, finalIndex-1))
  }
  else{
    return('no result')
  }
}


# ------------------------------------------------------------------------------
# Description:  Script to process fine-scale soils, cover, and rainfall
#               simulation data from Grassland Connectivity study in Walnut
#               Gulch Experimental Watershed (2018).
# Date:         1/6/21
# Author:       Justin Johnson
# ------------------------------------------------------------------------------
# Install and load packages
pkgs <- c('tidyverse','car', 'MASS')

check <- sapply(pkgs,require,warn.conflicts = TRUE,character.only = TRUE)
if(any(!check)){
  pkgs.missing <- pkgs[!check]
  install.packages(pkgs.missing)
  check <- sapply(pkgs.missing,require,warn.conflicts = TRUE,character.only = TRUE)
}

# ------------------------------------------------------------------------------
# Inputs
filename <- "Data/rg47_finescale_main.csv"

timefilename <- "Data/rg47_finescale_rainfall_time_series.csv"

# ------------------------------------------------------------------------------
# Set col_types for read_csv
col_typesa <- "fcnfffc"
col_typesb <- paste(rep("n", 82), collapse = "")
col_types <- paste(col_typesa, col_typesb, sep = "")

# Read in fine-scale data
fine <- read_csv(filename, col_type = col_types)

# Add a column for all four combinations of microsites and treatments
fine <- fine %>%
  unite(micro, treatment, microsite, remove = FALSE) %>%
  mutate(micro = factor(micro))

# ------------------------------------------------------------------------------
# Create functions to check assumptions, run ANOVA, and Kruskal-Wallis

# Check for normality and heteroscedasticity
diagnose <- function(response) {
  model <- lm(as.formula(paste(response, "~ micro")), data = fine)
  residuals <- residuals(object = model)
  shapiro <- shapiro.test(residuals)
  levene <- leveneTest(model)
  plots <- plot(model)
  return_list <- list(shapiro = shapiro, levene = levene, plots = plots)
  return(return_list)
}

# Run ANOVA
anovate <- function(response) {
  anova <- Anova(aov(lm(as.formula(paste(response, "~ micro")), data = fine)), type = "III")
  means <- fine %>%
    group_by(micro) %>%
    summarize(mean = mean(!!as.name(response), na.rm = TRUE),
              se = sd(!!as.name(response), na.rm = TRUE)/sqrt(n()))
  return_list <- list(means = means, anova = anova)
  return(return_list)
}

# Run Tukey's HSD
tukey <- function(response) {
  result <- TukeyHSD(aov(lm(as.formula(paste(response, "~ micro")), data = fine)))
  means <- fine %>%
    group_by(micro) %>%
    summarize(mean = mean(!!as.name(response), na.rm = TRUE),
              se = sd(!!as.name(response), na.rm = TRUE)/sqrt(n()))
  return_list <- list(means = means, result = result)
  return(return_list)
}

# Run Kruskal-Wallis Rank Sum Test
kruskalize <- function(response) {
  kruskal <- kruskal.test(as.formula(paste(response, "~ micro")), data = fine)
  means <- fine %>%
    group_by(micro) %>%
    summarize(mean = mean(!!as.name(response), na.rm = TRUE),
              se = sd(!!as.name(response), na.rm = TRUE)/sqrt(n()))
  return_list <- list(means = means, kruskal = kruskal)
  return(return_list)
}

# Run Mann-Whitney U test
wilcoxidize <- function(response) {
  wilcox <- pairwise.wilcox.test(fine[[response]], fine$micro, p.adjust.method = "holm")
  means <- fine %>%
    group_by(micro) %>%
    summarize(mean = mean(!!as.name(response), na.rm = TRUE),
              se = sd(!!as.name(response), na.rm = TRUE)/sqrt(n()))
  return_list <- list(means = means, wilcox = wilcox)
  return(return_list)
}

# Summary stats for table
mean_se <- function(response) {
  fine %>%
    group_by(micro) %>%
    summarize(mean = mean(!!as.name(response), na.rm = TRUE),
              se = sd(!!as.name(response), na.rm = TRUE)/sqrt(n()))
}

# ------------------------------------------------------------------------------
# Table 1 ----------------------------------------------------------------------
# ------------------------------------------------------------------------------
# Total canopy cover
diagnose("can_total.pct") # Heterogeneous variance
boxcox(lm(can_total.pct ~ micro, data = fine), lambda=seq(-3,3)) # ^2 transformation
diagnose("can_total.pct^2") # Assumptions satisfied
model <- aov(lm(can_total.pct^2 ~ micro, data = fine))
summary(model) # ANOVA significant
TukeyHSD(model) # Pairwise comparisons
mean_se("can_total.pct")

# Shrub canopy cover
diagnose("can_shrub.pct") # Non-normal, heterogeneous variance
boxcox(lm(can_shrub.pct+0.0001 ~ micro, data = fine), lambda=seq(-3,3)) # log transformation
diagnose("log(can_shrub.pct+0.0001)") # Transformation ineffective
kruskalize("can_shrub.pct") # Significant
wilcoxidize("can_shrub.pct") # Pairwise comparisons

# Grass canopy cover
diagnose("can_grass.pct") # Heterogeneous variance
boxcox(lm(can_grass.pct+0.0001 ~ micro, data = fine), lambda=seq(-3,3)) # log transformation
diagnose("log(can_grass.pct+0.0001)") # Transformation ineffective
kruskalize("can_grass.pct") # Significant
wilcoxidize("can_grass.pct") # Pairwise comparisons

# ERLE canopy cover
diagnose("can_ERLE.pct") # Non-normal, heterogeneous variance
boxcox(lm(can_ERLE.pct+0.0001 ~ micro, data = fine), lambda=seq(-3,3)) # log transformation
diagnose("log(can_ERLE.pct+0.0001)") # Transformation ineffective
kruskalize("can_ERLE.pct") # Significant
wilcoxidize("can_ERLE.pct") # Pairwise comparisons

# MUPO2 canopy cover
diagnose("can_MUPO2.pct") # Non-normal, heterogeneous variance
boxcox(lm(can_MUPO2.pct+0.0001 ~ micro, data = fine), lambda=seq(-3,3)) # log transformation
diagnose("log(can_MUPO2.pct+0.0001)") # Transformation ineffective
kruskalize("can_MUPO2.pct") # Significant
wilcoxidize("can_MUPO2.pct") # Pairwise comparisons

# Basal cover
diagnose("grd_basal.pct") # Non-normal, heterogeneous variance
boxcox(lm(grd_basal.pct+0.0001 ~ micro, data = fine), lambda=seq(-3,3)) # log transformation
diagnose("log(grd_basal.pct+0.0001)") # Transformation ineffective
kruskalize("grd_basal.pct") # Significant
wilcoxidize("grd_basal.pct") # Pairwise comparisons

# Ground litter cover
diagnose("grd_litter.pct") # Non-normal
boxcox(lm(grd_litter.pct+0.0001 ~ micro, data = fine), lambda=seq(-3,3)) # log transformation
diagnose("log(grd_litter.pct+0.0001)") # Transformation effective
model <- aov(lm(log(grd_litter.pct + 0.0001) ~ micro, data = fine))
summary(model) # ANOVA significant
##################     TukeyHSD(model) # Pairwise comparisons
mean_se("grd_litter.pct")

# Bare soil
diagnose("grd_bare_soil.pct") # Assumptions met
anovate("grd_bare_soil.pct") # Not significant

# Bare ground
diagnose("grd_bare_ground.pct") # Non-normal, heterogeneous variance
boxcox(lm(grd_bare_ground.pct+0.0001 ~ micro, data = fine), lambda=seq(-3,3)) # ^0.5 transformation
diagnose("(grd_bare_ground.pct+0.0001)^0.5") # Transformation effective
model <- aov(lm((grd_bare_ground.pct + 0.0001)^0.5 ~ micro, data = fine))
summary(model) # ANOVA significant
TukeyHSD(model) # Pairwise comparisons
mean_se("grd_bare_ground.pct")

# Cryptogram cover was not observed within any of the microsites.

# Litter depth
diagnose("litter_depth.cm") # Non-normal, heterogeneous variance
boxcox(lm(litter_depth.cm+0.0001 ~ micro, data = fine), lambda=seq(-3,3))# ^0.5 transformation
diagnose("(litter_depth.cm+0.0001)^0.5") # Transformation effective
model <- aov(lm((litter_depth.cm + 0.0001)^0.5 ~ micro, data = fine))
summary(model) # ANOVA significant
TukeyHSD(model) # Pairwise comparisons
mean_se("litter_depth.cm")

# Aggregate stability
diagnose("aggregate_stability") # heterogeneous variance
boxcox(lm(aggregate_stability ~ micro, data = fine), lambda=seq(-3,6))# ^3 transformation
diagnose("aggregate_stability^3") # Transformation effective
model <- aov(lm(aggregate_stability^3 ~ micro, data = fine))
summary(model) # ANOVA significant
TukeyHSD(model) # Pairwise comparisons
mean_se("aggregate_stability")

# Surface roughness
diagnose("surface_roughness.cm") # Assumptions met
anovate("surface_roughness.cm") # Not significant

# Slope
diagnose("slope.pct") # Heterogeneous variance
boxcox(lm(slope.pct ~ micro, data = fine), lambda=seq(-3,3))# log transformation
diagnose("log(slope.pct)") # Transformation ineffective
kruskalize("slope.pct") # Significant
wilcoxidize("slope.pct") # Pairwise comparisons

# ------------------------------------------------------------------------------
# Table 3 ----------------------------------------------------------------------
# ------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# 64 mm/hr rainfall simulations had limited hydrologic response, so only
# selected variables are tested.

# Time to runoff
kruskalize("runoff_start_64mmhr.min") # Not significant

# Mean sediment concentration
kruskalize("Sed_mean_64mmhr.gL") # Not significant

#-------------------------------------------------------------------------------
# 100 mm/hr rainfall simulations
# Remove

fine$Sed_cum_100mmhr.g
# Cumulative runoff
diagnose("Runoff_cum_100mmhr.mm") # Non-normal
boxcox(lm(Runoff_cum_100mmhr.mm+0.0001 ~ micro, data = fine), lambda=seq(-3,3))# ^0.5 transformation
diagnose("(Runoff_cum_100mmhr.mm+0.0001)^0.5") # Transformation ineffective
kruskalize("Runoff_cum_100mmhr.mm") # Significant
wilcoxidize("Runoff_cum_100mmhr.mm")

# Runoff to rainfall ratio
diagnose("Runoff_cum_100mmhr.mm/(rainfall_intensity_100mmhr.mmhr*0.75)")
boxcox(lm(Runoff_cum_100mmhr.mm/(rainfall_intensity_100mmhr.mmhr*0.75)+0.0001 ~ micro, data = fine), lambda=seq(-3,3)) # ^0.5 transformation
diagnose("(Runoff_cum_100mmhr.mm/(rainfall_intensity_100mmhr.mmhr*0.75))^0.5") # Transformation ineffective
kruskalize("Runoff_cum_100mmhr.mm/(rainfall_intensity_100mmhr.mmhr*0.75)")
kruskal.test(Runoff_cum_100mmhr.mm/(rainfall_intensity_100mmhr.mmhr*0.75) ~ micro, data = fine) # Significant
pairwise.wilcox.test(fine$Runoff_cum_100mmhr.mm/(fine$rainfall_intensity_100mmhr.mmhr*0.75), fine$micro, p.adjust.method = "holm")
fine %>%
  mutate(runoff_ratio = Runoff_cum_100mmhr.mm/(rainfall_intensity_100mmhr.mmhr*0.75)) %>%
  group_by(micro) %>%
  summarize(mean = mean(runoff_ratio, na.rm = TRUE),
            se = sd(runoff_ratio, na.rm = TRUE)/sqrt(n()))

# Time to runoff
diagnose("runoff_start_100mmhr.min") # Assumptions met
anovate("runoff_start_100mmhr.min") # Significant
tukey("runoff_start_100mmhr.min")

# Cumulative sediment
diagnose("Sed_cum_100mmhr.g") # Assumptions met
anovate("Sed_cum_100mmhr.g") # Significant
tukey("Sed_cum_100mmhr.g")

# Sediment concentration
diagnose("Sed_mean_100mmhr.gL") # Assumptions met
anovate("Sed_mean_100mmhr.gL") # Not significant - possible outlier
kruskalize("Sed_mean_100mmhr.gL") # Non-parametric to see if different from ANOVA

#-------------------------------------------------------------------------------
# 120 mm/hr rainfall simulations

# Cumulative runoff
diagnose("Runoff_cum_120mmhr.mm") # Assumptions met
anovate("Runoff_cum_120mmhr.mm") # Significant
tukey("Runoff_cum_120mmhr.mm")

# Runoff to rainfall ratio
diagnose("Runoff_cum_120mmhr.mm/(rainfall_intensity_120mmhr.mmhr*0.75)") # Assumptions met
model <- aov(lm(Runoff_cum_120mmhr.mm/(rainfall_intensity_120mmhr.mmhr*0.75) ~ micro, fine))
summary(model) # Significant
TukeyHSD(aov(lm(Runoff_cum_120mmhr.mm/(rainfall_intensity_120mmhr.mmhr*0.75) ~ micro, data = fine)))
fine %>%
  mutate(runoff_ratio = Runoff_cum_120mmhr.mm/(rainfall_intensity_120mmhr.mmhr*0.75)) %>%
  group_by(micro) %>%
  summarize(mean = mean(runoff_ratio, na.rm = TRUE),
            se = sd(runoff_ratio, na.rm = TRUE)/sqrt(n()))

# Time to runoff
diagnose("runoff_start_120mmhr.min") # Assumptions met
boxcox(lm(runoff_start_120mmhr.min ~ micro, data = fine), lambda=seq(-3,3)) # ^0.5 transformation
diagnose("runoff_start_120mmhr.min^0.5") # Transformation effective
model <- aov(lm(runoff_start_120mmhr.min^0.5 ~ micro, fine))
summary(model) # Significant
TukeyHSD(model)
mean_se("runoff_start_120mmhr.min")

# Cumulative sediment
diagnose("Sed_cum_120mmhr.g") # Assumptions met
boxcox(lm(Sed_cum_120mmhr.g+0.0001 ~ micro, data = fine), lambda=seq(-3,3)) # ^0.5 transformation
diagnose("Sed_cum_120mmhr.g+0.0001^0.5") # Transformation ineffective
kruskalize("Sed_cum_120mmhr.g") # Significant
wilcoxidize("Sed_cum_120mmhr.g")

# Sediment concentration
diagnose("Sed_mean_120mmhr.gL") # Non-normal
boxcox(lm(Sed_mean_120mmhr.gL ~ micro, data = fine), lambda=seq(-3,3)) # Log transformation
diagnose("log(Sed_mean_120mmhr.gL)") # Assumptions met
model <- aov(lm(log(Sed_mean_120mmhr.gL) ~ micro, fine)) # Significant
summary(model) # Significant
TukeyHSD(model)
mean_se("Sed_mean_120mmhr.gL")

#-------------------------------------------------------------------------------
# Cumulative rainfall simulations

fine_sum <- fine %>%
  rowwise() %>%
  mutate(Runoff_cum.mm = sum(Runoff_cum_64mmhr.mm,
                             Runoff_cum_100mmhr.mm,
                             Runoff_cum_120mmhr.mm),
         Sed_cum.g = sum(Sed_cum_64mmhr.g,
                         Sed_cum_100mmhr.g,
                         Sed_cum_120mmhr.g))

# Cumulative runoff
model <- aov(lm(Runoff_cum.mm ~ micro, data = fine_sum))
plot(model) # Assumuptions met
summary(model) # Significant
TukeyHSD(model)
fine_sum %>%
  group_by(micro) %>%
  summarize(mean = mean(Runoff_cum.mm, na.rm = TRUE),
            se = sd(Runoff_cum.mm, na.rm = TRUE)/sqrt(n()))

# Cumulative sediment
model <- aov(lm(Sed_cum.g ~ micro, data = fine_sum))
plot(model)
residuals <- residuals(object = model)
shapiro.test(residuals)
leveneTest(model) # Assumptions met
summary(model) # Significant
TukeyHSD(model)
fine_sum %>%
  group_by(micro) %>%
  summarize(mean = mean(Sed_cum.g, na.rm = TRUE),
            se = sd(Sed_cum.g, na.rm = TRUE)/sqrt(n()))

#-------------------------------------------------------------------------------
# Terminal infiltration rates

# Read in rainfall simulation time series
fine_time <- read_csv(timefilename, col_types = "fffffnfnnnnn")

# Determine terminal infiltration rate
terminal_infiltration <-  fine_time %>%
  group_by(plot_ID, target_rainfall_intensity.mmhr) %>%
  summarize(terminal_infiltration_mmhr = last(Inf.mmhr)) %>%
  spread(target_rainfall_intensity.mmhr, terminal_infiltration_mmhr) %>%
  rename(`Inf_terminal_64mmhr.mmhr`="64",
         `Inf_terminal_100mmhr.mmhr`="100",
         `Inf_terminal_120mmhr.mmhr`="120")

# Join data sets
fine_full <- full_join(fine, terminal_infiltration, by = "plot_ID")

# 64 mm/hr terminal infiltration rate
model <- aov(lm(Inf_terminal_64mmhr.mmhr ~ micro, data = fine_full))
plot(model)
residuals <- residuals(object = model)
shapiro.test(residuals) # Non-normal
leveneTest(model) # Homogeneous variance
boxcox(model, lambda=seq(-3,10)) # ^9 transformation
model <- aov(lm(Inf_terminal_64mmhr.mmhr^9 ~ micro, data = fine_full))
plot(model)
residuals <- residuals(object = model)
shapiro.test(residuals)
leveneTest(model) # Assumptions met
summary(model) # Not significant
fine_full %>%
  group_by(micro) %>%
  summarize(mean = mean(Inf_terminal_64mmhr.mmhr, na.rm = TRUE),
            se = sd(Inf_terminal_64mmhr.mmhr, na.rm = TRUE)/sqrt(n()))

# 100 mm/hr terminal infiltration rate
model <- aov(lm(Inf_terminal_100mmhr.mmhr ~ micro, data = fine_full))
plot(model)
residuals <- residuals(object = model)
shapiro.test(residuals)
leveneTest(model) # Assumptions met
summary(model) # Significant
TukeyHSD(model)

# 120 mm/hr terminal infiltration rate
model <- aov(lm(Inf_terminal_120mmhr.mmhr ~ micro, data = fine_full))
plot(model)
residuals <- residuals(object = model)
shapiro.test(residuals)
leveneTest(model) # Assumptions met
summary(model) # Significant
TukeyHSD(model)

# ------------------------------------------------------------------------------
# Figure 5 ---------------------------------------------------------------------
# ------------------------------------------------------------------------------
# Panel a
fine_canopy <- fine %>%
  filter(microsite == "Canopy")

model <- lm(Runoff_cum_120mmhr.mm ~ can_grass.pct, data = fine_canopy)
summary(model)

fine_interspace <- fine %>%
  filter(microsite == "Interspace")

model <- lm(Runoff_cum_120mmhr.mm ~ can_grass.pct, data = fine_interspace)
summary(model)

# Panel b
#Gather all intensities for cumulative runoff
fine_runoff <- gather(fine, key="rainfall_intensity.mmhr", value="Runoff_cum.mm",
                     Runoff_cum_64mmhr.mm,
                     Runoff_cum_100mmhr.mm,
                     Runoff_cum_120mmhr.mm) %>%
  dplyr::select(plot_ID, rainfall_intensity.mmhr, Runoff_cum.mm) %>%
  mutate(rainfall_intensity.mmhr=recode_factor(rainfall_intensity.mmhr,
                                 Runoff_cum_64mmhr.mm ="64",
                                 Runoff_cum_100mmhr.mm ="100",
                                 Runoff_cum_120mmhr.mm ="120"))

#Gather all intensities for cumulative sediment
fine_sed <- gather(fine, key="rainfall_intensity.mmhr", value="Sed_cum.g",
                   Sed_cum_64mmhr.g,
                   Sed_cum_100mmhr.g,
                   Sed_cum_120mmhr.g) %>%
  dplyr::select(plot_ID, rainfall_intensity.mmhr, Sed_cum.g) %>%
  mutate(rainfall_intensity.mmhr=recode_factor(rainfall_intensity.mmhr,
                                               Sed_cum_64mmhr.g ="64",
                                               Sed_cum_100mmhr.g ="100",
                                               Sed_cum_120mmhr.g ="120"))

#Join combined datasets
fine_all <- full_join(fine_runoff, fine_sed, by=c("plot_ID", "rainfall_intensity.mmhr"))

model <- lm(Sed_cum.g ~ Runoff_cum.mm, data = fine_all)
summary(model)

# ------------------------------------------------------------------------------
# Supplemental Figure 1 --------------------------------------------------------
# ------------------------------------------------------------------------------

# Gather wetted areas.
wet <- fine %>%
  gather(key="depth.cm", value="wetted.pct", wet_2cm.pct:wet_20cm.pct) %>%
  mutate(depth.cm=recode_factor(depth.cm, wet_2cm.pct="2",
                                wet_4cm.pct="4",
                                wet_6cm.pct="6",
                                wet_8cm.pct="8",
                                wet_10cm.pct="10",
                                wet_12cm.pct="12",
                                wet_14cm.pct="14",
                                wet_16cm.pct="16",
                                wet_18cm.pct="18",
                                wet_20cm.pct="20"))%>%
  dplyr::select(plot_ID, micro, depth.cm, wetted.pct)

#Gather rock distribution.
rock <- fine %>%
  gather(key="depth.cm", value="rock.pct", rock_2cm.pct:rock_20cm.pct)%>%
  mutate(depth.cm=recode_factor(depth.cm, rock_2cm.pct="2",
                                rock_4cm.pct="4",
                                rock_6cm.pct="6",
                                rock_8cm.pct="8",
                                rock_10cm.pct="10",
                                rock_12cm.pct="12",
                                rock_14cm.pct="14",
                                rock_16cm.pct="16",
                                rock_18cm.pct="18",
                                rock_20cm.pct="20"))%>%
  dplyr::select(plot_ID, depth.cm, rock.pct)

#Calculate the percent of soil that was available to be wetted (deal with rocks).
soil_map <- full_join(wet,rock, by=c("plot_ID", "depth.cm"))%>%
  mutate(wet.pct=wetted.pct/(100-rock.pct))

# 2 cm
kruskal.test(wet.pct ~ micro, data = soil_map[which(soil_map$depth.cm == "2"),]) # All 100%

# 4 cm
kruskal.test(wet.pct ~ micro, data = soil_map[which(soil_map$depth.cm == "4"),]) # All 100%

# 6 cm
kruskal.test(wet.pct ~ micro, data = soil_map[which(soil_map$depth.cm == "6"),]) # All 100%

# 8 cm
kruskal.test(wet.pct ~ micro, data = soil_map[which(soil_map$depth.cm == "8"),]) # All 100%

# 10 cm
kruskal.test(wet.pct ~ micro, data = soil_map[which(soil_map$depth.cm == "10"),]) # Not significant

# 12 cm
kruskal.test(wet.pct ~ micro, data = soil_map[which(soil_map$depth.cm == "12"),]) # Not significant

# 14 cm
kruskal.test(wet.pct ~ micro, data = soil_map[which(soil_map$depth.cm == "14"),]) # Not significant

# 16 cm
kruskal.test(wet.pct ~ micro, data = soil_map[which(soil_map$depth.cm == "16"),]) # Not significant

# 18 cm
kruskal.test(wet.pct ~ micro, data = soil_map[which(soil_map$depth.cm == "18"),]) # Not significant

# 20 cm
kruskal.test(wet.pct ~ micro, data = soil_map[which(soil_map$depth.cm == "20"),]) # Not significant


# print_correlation generic function ----
print_correlation <- function(data, ...) UseMethod("print_correlation", data)

# print_correlation data.frame method ----
print_correlation.data.frame <- function(data, show = TRUE, html = FALSE, ...) {

  # run correlation ----
  cor <- correlation::correlation(data)

  # do summary ----
  if (show | html) {
    out <- .hlpr_summary_cor(object = cor)
  }

  # return output ----
  if(html) {
    if (requireNamespace("stargazer", quietly = TRUE)) {
      if (!show) warning("html == TRUE overrules show == FALSE!")
      out <- .hlpr_print_cor(object = out, html = TRUE)
      return(out)
    } else {
      warning("html == TRUE requires 'stargazer' package!")
    }
  } else if (show) {
    .hlpr_print_cor(object = out)
  } else {
    return(cor)
  }
}


library(digest)

input <- "Rosetta Code"
cat(digest(input, algo = "sha1", serialize = FALSE), "\n")


# library import
library(GenSA)

# data loading
setwd('/')
miscolc <- read.csv(file = 'miscolc.csv')

#assembly size
N <- 50

#gender, age, education and area sizes declaration
N_WOMAN <- 27
N_MAN <- 23

N_18 <- 6
N_30 <- 18
N_50 <- 12
N_65 <- 14

N_PRIMARY <- 16
N_MEDIUM <- 21
N_HIGHER <- 13

N_A_1 <- 1
N_A_2 <- 2
N_A_3 <- 1
N_A_4 <- 1
N_A_5 <- 1
N_A_6 <- 1
N_A_7 <- 3
N_A_8 <- 4
N_A_9 <- 3
N_A_10 <- 1
N_A_11 <- 2
N_A_12 <- 7
N_A_13 <- 4
N_A_14 <- 3
N_A_15 <- 4
N_A_16 <- 3
N_A_17 <- 5
N_A_18 <- 4

#current iteration checking parameter
check_par <- 0

# input entries size
INPUT_SIZE <- nrow(miscolc)

#evaluation function declaration
#v - vectors
#b - is that out of genSA call?
evaluation_function <- function(v,b) {

  ret <- 0
  if(any(duplicated(miscolc$ID[v]))){
    ret <- 99999999
  }else{

    #variables declarations
    man <- 0
    woman <- 0

    age18 <- 0
    age30 <- 0
    age50 <- 0
    age65 <- 0

    primary <- 0
    medium <- 0
    higher <- 0

    a1 <- 0
    a2 <- 0
    a3 <- 0
    a4 <- 0
    a5 <- 0
    a6 <- 0
    a7 <- 0
    a8 <- 0
    a9 <- 0
    a10 <- 0
    a11 <- 0
    a12 <- 0
    a13 <- 0
    a14 <- 0
    a15 <- 0
    a16 <- 0
    a17 <- 0
    a18 <- 0

    #counters
    for (i in 1:length(v)) {

      if (miscolc$Gender[v[i]] == "M") {
        man <- man+1
      } else if (miscolc$Gender[v[i]] == "F") {
        woman <- woman+1
      }

      if (miscolc$Age[v[i]] == "18-29") {
        age18 <- age18+1
      } else if (miscolc$Age[v[i]] == "30-49") {
        age30 <- age30+1
      } else if (miscolc$Age[v[i]] == "50-64") {
        age50 <- age50+1
      } else if (miscolc$Age[v[i]] == "65+") {
        age65 <- age65+1
      }

      if (miscolc$Education[v[i]] == "elementary school") {
        primary <- primary+1
      } else if (miscolc$Education[v[i]] == "high school") {
        medium <- medium+1
      } else if (miscolc$Education[v[i]] == "university") {
        higher <- higher+1
      }

      if (miscolc$area[v[i]] == "area_1") {
        a1 <- a1+1
      }else if(miscolc$area[v[i]] == "area_2") {
        a2 <- a2+1
      }else if(miscolc$area[v[i]] == "area_3") {
        a3 <- a3+1
      }else if(miscolc$area[v[i]] == "area_4") {
        a4 <- a4+1
      }else if(miscolc$area[v[i]] == "area_5") {
        a5 <- a5+1
      }else if(miscolc$area[v[i]] == "area_6") {
        a6 <- a6+1
      }else if(miscolc$area[v[i]] == "area_7") {
        a7 <- a7+1
      }else if(miscolc$area[v[i]] == "area_8") {
        a8 <- a8+1
      }else if(miscolc$area[v[i]] == "area_9") {
        a9 <- a9+1
      }else if(miscolc$area[v[i]] == "area_10") {
        a10 <- a10+1
      }else if(miscolc$area[v[i]] == "area_11") {
        a11 <- a11+1
      }else if(miscolc$area[v[i]] == "area_12") {
        a12 <- a12+1
      }else if(miscolc$area[v[i]] == "area_13") {
        a13 <- a13+1
      }else if(miscolc$area[v[i]] == "area_14") {
        a14 <- a14+1
      }else if(miscolc$area[v[i]] == "area_15") {
        a15 <- a15+1
      }else if(miscolc$area[v[i]] == "area_16") {
        a16 <- a16+1
      }else if(miscolc$area[v[i]] == "area_17") {
        a17 <- a17+1
      }else if(miscolc$area[v[i]] == "area_18") {
        a18 <- a18+1
      }

    }

    #calculating the ideal composition - evaluation for checking parameter
    check_par <- (N_MAN-man)^2 + (N_WOMAN-woman)^2 + (N_18-age18)^2 + (N_30-age30)^2 + (N_50-age50)^2 + (N_65-age65)^2 + (N_PRIMARY-primary)^2 + (N_MEDIUM-medium)^2 + (N_HIGHER-higher)^2 +(N_A_1-a1)^2+(N_A_2-a2)^2+(N_A_3-a3)^2+(N_A_4-a4)^2+(N_A_5-a5)^2+(N_A_6-a6)^2+(N_A_7-a7)^2+(N_A_8-a8)^2+(N_A_9-a9)^2+(N_A_10-a10)^2+(N_A_11-a11)^2+(N_A_12-a12)^2+(N_A_13-a13)^2+(N_A_14-a14)^2+(N_A_15-a15)^2+(N_A_16-a16)^2+(N_A_17-a17)^2+(N_A_18-a18)^2

    #results evaluation
    ret <- ret + (N_MAN-man)^2 + (N_WOMAN-woman)^2 + (N_18-age18)^2 + (N_30-age30)^2 + (N_50-age50)^2 + (N_65-age65)^2 + (N_PRIMARY-primary)^2 + (N_MEDIUM-medium)^2 + (N_HIGHER-higher)^2 +(N_A_1-a1)^2+(N_A_2-a2)^2+(N_A_3-a3)^2+(N_A_4-a4)^2+(N_A_5-a5)^2+(N_A_6-a6)^2+(N_A_7-a7)^2+(N_A_8-a8)^2+(N_A_9-a9)^2+(N_A_10-a10)^2+(N_A_11-a11)^2+(N_A_12-a12)^2+(N_A_13-a13)^2+(N_A_14-a14)^2+(N_A_15-a15)^2+(N_A_16-a16)^2+(N_A_17-a17)^2+(N_A_18-a18)^2

    #current loop evaluation
    if(check_par==0 && ret<99999999){
      print("Identificatiors list:")
      print( miscolc$ID[v] )
      print("Characteristics amounts:")
      print( cat('man=', man, ' woman=', woman,'age18=', age18, ' age30=', age30,'age50=', age50, ' age65=', age65,' primary=', primary, ' medium=', medium, ' higher=', higher,' area1=',a1,' area2=',a2,' area3=',a3,' area4=',a4,' area5=',a5,' area6=',a6,' area7=',a7,' area8=',a8,' area9=',a9,' area10=',a10,' area11=',a11,' area12=',a12,' area13=',a13,' area14=',a14,' area15=',a15,' area16=',a16,' area17=',a17,' area18=',a18) )
      write.csv(cbind(miscolc$LP[v],miscolc$ID[v]),'result_1.csv',row.names = TRUE)

      #stop genSA - ideal composition found
      stop("Result found. Function execution stopped.")
    }

  }

  #data output presentation
  if (b) {
    print("Identificatiors list:")
    print( miscolc$ID[v] )
    print("Characteristics amounts:")
    print( cat('man=', man, ' woman=', woman,'age18=', age18, ' age30=', age30,'age50=', age50, ' age65=', age65,' primary=', primary, ' medium=', medium, ' higher=', higher,' area1=',a1,' area2=',a2,' area3=',a3,' area4=',a4,' area5=',a5,' area6=',a6,' area7=',a7,' area8=',a8,' area9=',a9,' area10=',a10,' area11=',a11,' area12=',a12,' area13=',a13,' area14=',a14,' area15=',a15,' area16=',a16,' area17=',a17,' area18=',a18) )
    write.csv(cbind(miscolc$LP[v],miscolc$ID[v]),'result_1.csv',row.names = TRUE)
  }

  ret
}

#simulated annealing
RESULT <- GenSA(par=as.numeric(sample(1:N)*INPUT_SIZE/N), fn=evaluation_function, lower=as.numeric(seq(1,N)), upper=as.numeric(seq(INPUT_SIZE-N+1,INPUT_SIZE)), FALSE, control=list(max.time=3000,smooth=FALSE,verbose=TRUE,temperature=50.0))
print(RESULT)

#main function
evaluation_function(RESULT$par, TRUE)


ChainingTrain <- function(train.name="train",args=list()) {
	# Predicts on successive residuals given a training set
	#
	# Args:
	#	train.name: base name of training dataset
	#	method.args: list of methods to use in order of application on residuals
	#
	#
	# Example usage:
	#	model<-ChainingTrain("train",args=list(RandomForestTrain,GlmnetTrain))
	# 	predictions<-model("test")

	# Initialize training targets
	target<-Slopes(GetAlsfrsData(train.name),3,12,"f")

	# Initialize list to hold models
	model.list<-list()

	for (i in 1:length(args)) {
		# Get ith method
		method<-args[[i]]
		# Train a model on the training data and current targets
		model<-method(train.name,target=target)
		# Store the model in a list
		model.list[[i]]<-model
		# Predict targets on training data
		train.pred<-model(train.name)
		# Update targets to next level of residuals
		target<-target-train.pred[,2]
	}

	ChainingPredict <- function(test.name) {
	# Makes predictions based on a chaining model for residuals
	#
	# Args:
	#	test.name: base name of test data
	#
	# Returns:
	#	Two column matrix, ordered by the first column, with first column
	#   "subject.id" containing test set subject ids and the second column
	#   "prediction" containing predicted slopes.
	#
	# Side effects:
	#	Saves predictions to file

		predictions<-lapply(model.list,function(x){x(test.name)})
		predictions<-Reduce(function(x,y) {merge(x,y,all.x=TRUE)},predictions)
		predictions<-cbind(predictions[,1],rowSums(predictions[,2:dim(predictions)[2]]))
		colnames(predictions)<-c("subject.id","predictions")

		# Write predictions to file
		out.file = sprintf("Predictions/Chaining-%s-%s.txt",train.name,test.name)
		WritePredictions(predictions, out.file)

		return(predictions)
	}

	return(ChainingPredict)
}


# Frequent Words Problem

seq <- "AAAATA"

count_pattern <- 3

seq_count <- nchar(seq)

last_k_mer <- seq_count - count_pattern + 1

all_sub_string <- substring(seq,
                              first = 1:last_k_mer,
                            last = count_pattern:seq_count)

df_count <- table(all_sub_string)
df_count <- data.frame(df_count)

df_count$all_sub_string[df_count$Freq == max(df_count$Freq)]


library(rrBLUP)
library(data.table)
set.seed(42)
args = commandArgs(TRUE)
X_file <- args[1] # your genetic matrix, e.g., geno.csv
Y_file <- args[2] # your phenotypic matrix, e.g., pheno.csv
feat_file <- args[3] # selected features or "all" for all the markers in the genetic matrix
trait <- args[4] # the column name of your target trait, or "all" for all the traits in the pheno matrix
cv <- as.numeric(args[5]) # the fold number of the cross-validation scheme
number <- as.numeric(args[6]) # how many times your want to repeat the cross-validation scheme
cvs_file <- args[7] # the CVs file
save_name <- args[8] # a short name for your file to be saved

Y <- read.csv(Y_file, row.names=1)
cvs <- read.csv(cvs_file, row.names=1)

# Subset X if feat_file is not all
if (feat_file != 'all'){
  print('Pulling features to use...')
  FEAT <- scan(feat_file, what='character')
  X <- fread(X_file,select=c('ID',FEAT))
  fwrite(X,paste('geno',feat_file,'.csv',sep=''),sep = ",",quote=FALSE)
  feat_method <- tail(unlist(strsplit(feat_file, '/')), n=1)
  X <- read.csv(paste('geno',feat_file,'.csv',sep=''), row.names=1)
} else{
	X <- as.matrix(fread(X_file),rownames=1)
	}

# make sure X and Y have the same order of rows
X <- X[rownames(Y),]

if (trait == 'all') {
  print('Modeling all traits')
} else {
  Y <- Y[trait]
}

R2 <- c()
for(i in 1:length(Y)){
	print(names(Y)[i])
	Accuracy <- c()
	Coef <- c()
	for(k in 1:number){
		print(k)
		tst = cvs[,k]
		Coeff <- c()
		yhat <- data.frame(cbind(Y, yhat = 0))
		yhat$yhat <- as.numeric(yhat$yhat)
		row.names(yhat) <- row.names(Y)
		for(j in 1:cv){
			validation <- which(tst==j)
			training <- which(tst!=j)
			yNA <- Y[,i]
			yNA[validation] <- NA # Mask yields for validation set
			# Build rrBLUP model and save yhat for the masked values
			# predict marker effects
			coeff <- mixed.solve(y=Y[training,i], Z=X[training,], K=NULL, method='ML', SE=FALSE, return.Hinv=FALSE)
			Coeff <- rbind(Coeff,coeff$u)
			# predict breeding
			rrblup <- mixed.solve(y=yNA, K=A.mat(X))
			yhat$yhat[validation] <- rrblup$u[validation]
			}
		accuracy <- cor(yhat[,i], yhat$yhat)
		Accuracy <- c(Accuracy,accuracy^2)
		Coef <- rbind(Coef,colMeans(Coeff))
		}
	R2 <- cbind(R2,Accuracy)
	write.csv(Coef,paste('Coef_',save_name,'_',names(Y)[i],'.csv',sep=''),row.names=F,quote=F)
	}
colnames(R2) <- names(Y)
write.csv(R2,paste('R2_results_',save_name,'.csv',sep=''),row.names=F,quote=F)