#' Title
#'
#' @param model
#' @param parms
#' @param over
#' @param xrange
#' @param res
#' @param ini
#' @param t_max
#' @param method
#'
#' @return
#' @export
#'
#' @examples
#'
#' library(foreach)
#' library(doSNOW)
#'
#' workerlist <- c(rep("localhost", times = 3))
#' cl <- makeSOCKcluster(workerlist)
#' registerDoSNOW(cl)
#'
#' p <- set_parms(livestock$parms, set = list(b = 0.9, c = 0.2, f = 0, p = 0, alpha = 0.2))
#' sim_bifurcations(livestock, over = "b", res = 31, parms = p)
#'
#' stopCluster(cl)
#'
sim_bifurcations <- function(
          model,
          parms = model$defparms,
          over = "b",
          xrange = c(0,1),
          res = 31,
          ini = c(0.9, 0.0001),
          t_max = 150,
          func = model$pair,
          method = "ode45"
          ) {

  parms[[over]] <- seq(xrange[1],xrange[2],length = res)
  parms$rho_ini <- ini

  iterations <- expand.grid(parms)
  iterations <- cbind(ID = 1:dim(iterations)[1],iterations)

  iterations$b <- as.numeric(as.character(iterations$b))
  iterations$L <- as.numeric(as.character(iterations$L))

  foreach(iteration = iterations$ID, .packages = c("deSolve", "livestock"), .combine = rbind) %dopar% {

    model_parms <- as.list(iterations[iteration,])

    rho_starting <- ini_rho(model_parms$rho_ini)

    # running the ode-solver
    runmodel <- run_ode(rho_starting, func = model$pair, times = c(0,t_max), parms = model_parms, method = method)

    return(tail(runmodel,1))
  } -> output

  output <- cbind(iterations,output) # CHECK: produces a warning

  return(output)

}


#poweranalysis.r
# David Hope
# Dec 8, 2016

require(tidyverse)

simData <- function(mu, sd, seed, CI = FALSE) {
    set.seed(seed)

    tst <- as.vector(rnorm(1000000, mu, sd), "integer")
    qnt <- quantile(tst,probs =c(0.005,  0.995))
    test <- tst[tst >=qnt[1] & tst<= qnt[2]]
    allRuns <- data.frame(time = test, Rnum = seed)

    SimWESA <- allRuns %>% group_by(time, Rnum) %>%
      summarize(WESA = max(n() +  rnorm(1, 0,2000),0)) %>%
      ungroup %>% mutate(Year = 2016,
                         SiteID = "Simulation",
                         Day.of.Year = time)

    source("muEstimation.R")

    simResults <- function(everyNdays, startingDay,  data = SimWESA, calcCI = FALSE){
      ndaySurveys <- data[seq(startingDay, nrow(data), everyNdays), ]
      if(nrow(ndaySurveys)== 1) {return(NULL)}
      output <-calc.peak.prog(site = "Simulation", year = 2016,
                                                data = ndaySurveys, species = 'WESA', estimateCI = calcCI, errorMethod = "jackknife" )
      if(is_null(output)) {return(NULL)}
      output$results$daySpacing <- everyNdays
      output$results$start <- startingDay
      output$results$seed <- seed

      return(output$results)
    }

    runs <- expand.grid(seq(1,7), seq(1,5))

    outputdf <- map2_df(runs[,1], runs[,2], simResults, calcCI = CI )
    baserun <- simResults(1, 1, data = SimWESA, calcCI = FALSE)

    return(list(outputdf, baserun))

}

# f = file()
# sink(file=f)
# simulationResults <- map(seq(1,1000), function(x) simData(125, 4.2, x))
# sink() ## undo silencing
# close(f)
#
# saveRDS(simulationResults, "simResultsFull2.rds")
simulationResults <- read_rds("cleanVersions/simResultsFull2.rds") %>% transpose()
simfullCounts <- do.call("rbind", simulationResults[[2]])

simboot <- do.call("rbind", simulationResults[[1]]) %>% mutate(err = uci-lci, dev = abs(MU -mean(simfullCounts$MU)))

sum_boot <-
filter(simboot, conv == TRUE & MU > 50) %>% #& !is.na(lci) & !is.na(uci)) %>%
  mutate(dev = MU- mean(simfullCounts$MU)) %>%
  group_by(daySpacing, start) %>%
  summarize(median= median(dev),
            mn=mean(dev),
            conf.low = quantile(dev, 0.025),
            conf.high = quantile(dev, 0.975))  %>% ungroup %>%
  mutate(start = as.factor(start))

### Final figure for paper

N_boot <-
  filter(simboot, conv == TRUE & MU > 50) %>% #& !is.na(lci) & !is.na(uci)) %>%
  mutate(dev = MU- mean(simfullCounts$MU)) %>%
  group_by(N) %>%
  sample_n(1000, replace=T) %>%
  summarize(n= n(),median= median(dev),
            mn = mean(dev),
            conf.low = quantile(dev, 0.025),
            conf.high = quantile(dev, 0.975))  %>% ungroup

require(cowplot)
Spacing_plot <-
  ggplot(sum_boot,
         aes(daySpacing, mn, shape = as.factor(start))) +
  geom_hline(yintercept = 0) +
  geom_pointrange(position = position_jitterdodge(jitter.width = 0.5, dodge.width = 0.1),aes(ymin = conf.low,
                      ymax= conf.high))   + scale_shape_manual( values = c(19, 17, 15, 2, 1)) +
  # ggthemes::theme_few() + #scale_colour_grey() +  #scale_y_continuous(breaks = c(seq(-7,7,2))) +
  theme(legend.position = 'bottom')+#, legend.text = element_text(size=6), text = element_text(size=8)) +
  labs(shape = "Survey Initiation Day", y = "Deviation from\ntrue peak date (days)", x = "Days between Surveys")

N_plot <-
ggplot(N_boot, aes(N, mn)) +
  geom_hline(yintercept = 0) +
  geom_pointrange(aes(ymin = conf.low,
                      ymax= conf.high)) +
  # ggthemes::theme_few() +
  labs(x = "Number of Days Surveyed",
       y= "Deviation from\ntrue peak date (days)") +
  # scale_y_continuous(breaks = c(seq(-6,6))) +
  geom_vline(xintercept = 7, linetype = 2, alpha = 0.4)

Figure6 <- plot_grid(Spacing_plot, N_plot, labels = c("(A)", "(B)"),nrow = 2, align = "v",
                     label_fontfamily = 'times', hjust = -0, vjust = 1.0)

ggsave("../6th Submission/Figure6.tiff", width = 3.5, height = 7, dpi=600, units = 'in')


#------------------------------
# library
#------------------------------

library(data.table)
library(magrittr)
library(digest)
library(plyr)
library(dtplyr)
library(dplyr)

#------------------------------
# set seed
#------------------------------

seed <- as.integer(commandArgs(trailingOnly=TRUE)[1])
if(is.na(seed)) seed <- 1000
cat("seed: ", seed, "\n - - - - - - - - - -\n")

set.seed(seed)

#------------------------------
# function
#------------------------------

is_useful_category <- function(vec){
	length(unique(vec)) > 1
}

replace_NA <- function(vec){
	levels(vec) <- c(levels(vec), "NA")
	vec[is.na(vec)] <- "NA"
	vec
}

define_formula <- function(train_categorical){

	train_categorical_digests <- train_categorical %>% sapply(digest)
	train_categorical_useful <- train_categorical %>% sapply(is_useful_category)

	target <- names(train_categorical_digests)[!duplicated(train_categorical_digests) & train_categorical_useful]

	paste("~", paste(target, collapse=" + "), -1)
}

#------------------------------
# main
#------------------------------

data_dir <- file.path("..", "..", "dataset")
colClasses <- c("integer", rep("factor", 2140))

tic <- proc.time()

# train data ----------

train_categorical <- fread(file.path(data_dir, "train_categorical.csv"), data.table=FALSE,
							na.strings="", showProgress=TRUE, colClasses=colClasses)
train_categorical$Id <- NULL

print("==> Replace NA")
for(i in seq_along(train_categorical)){
	train_categorical[,i] <- replace_NA(train_categorical[,i])
}

print("==> Define formula")
f <- define_formula(train_categorical)

train_categorical_levels <- lapply(train_categorical, levels)

print("==> Expand data")
train_categorical_expand <- model.matrix(as.formula(f), data=train_categorical)

rm(train_categorical)
gc();gc();

train_categorical_expand <- data.frame(train_categorical_expand)

print("==> Get colnames")
expand_colnames <- train_categorical_expand[FALSE,]

train_categorical_id <- fread(file.path(data_dir, "train_categorical.csv"), select="Id") %>% use_series(Id)
train_categorical_expand <- cbind(Id=train_categorical_id, train_categorical_expand)

fwrite(train_categorical_expand, "../../input/train_categorical_expand.csv", quote=FALSE, sep=",")

# save(f, expand_colnames, train_categorical_levels, file="categorical_schema.robj")
# load(file="categorical_schema.robj")

# test data ----------

test_categorical <- fread(file.path(data_dir, "test_categorical.csv"), data.table=FALSE,
							na.strings="", showProgress=TRUE, colClasses=colClasses, drop="Id")

print("==> Update levels")
for(i in seq_along(test_categorical)){
	levels(test_categorical[,i]) <- union(levels(test_categorical[,i]), train_categorical_levels[[i]])
}

print("==> Replace NA")
for(i in seq_along(test_categorical)){
	test_categorical[,i] <- replace_NA(test_categorical[,i])
}

print("==> Expand data")
contrasts <- function(x) return(attr(x, "contrasts"))
test_categorical_expand <- model.matrix(as.formula(f), data=test_categorical)

rm(test_categorical)
gc();gc();

test_categorical_expand <- data.frame(test_categorical_expand)

print("==> Select columns")
use_col <- intersect(colnames(expand_colnames), colnames(test_categorical_expand))
test_categorical_expand <- rbind.fill(as.data.frame(expand_colnames), test_categorical_expand[,use_col])

test_categorical_expand <- replace(test_categorical_expand, is.na(test_categorical_expand), 0)

test_categorical_id <- fread(file.path(data_dir, "test_categorical.csv"), select="Id") %>% use_series(Id)
test_categorical_expand <- cbind(Id=test_categorical_id, test_categorical_expand)

fwrite(test_categorical_expand, "../../input/test_categorical_expand.csv", quote=FALSE, sep=",")

# display computational time
cat("==> Display computational time\n")
proc.time() %>% subtract(tic) %>% print


library(testthat)

#' scatter2d
#'
#' A short-cut function for creating 2 dimensional scatterplots via ggplot2.
#'
#' @param data data.frame or tibble
#' @param x unquoted column name to plot on the x-axis from data data.frame or tibble
#' @param y unquoted column name to plot on the y-axis from data data.frame or tibble
#'
#' @return
#' @export
#'
#' @examples
#' scatter2d(mtcars, hp, mpg)
scatter2d <- function(data, x, y) {
    ggplot2::ggplot(data, ggplot2::aes(x = {{x}}, y = {{y}})) +
        ggplot2::geom_point()
}

test_data <- dplyr::tibble(x_vals = c(2, 4, 6),
                   y_vals = c(2, 4, 6))

plot2d <- scatter2d(test_data, x_vals, y_vals)
plot2d

plot2d$layers

plot2d$layers[[1]]$geom

plot2d$layers[[1]]$geom

class(plot2d$layers[[1]]$geom)

plot2d$mapping$x

rlang::get_expr(plot2d$mapping$x)

test_that('Plot should use geom_point and map x to x-axis, and y to y-axis.', {
    expect_true("GeomPoint" %in% c(class(plot2d$layers[[1]]$geom)))
    expect_true("x_vals"  == rlang::get_expr(plot2d$mapping$x))
    expect_true("y_vals" == rlang::get_expr(plot2d$mapping$y))
})


# http://stackoverflow.com/questions/6461209/how-to-round-up-to-the-nearest-10-or-100-or-x
#library(plyr)

data  <- read.table("./integrity.dat", header=T, sep="|")
counts <- table(data$integrity)

#print(counts)
source("round.r")

#diff <- data$Quantity - data$fixed
#counts <- table(data$fixed, diff)
png(filename="./integrity.png", height=500, width=500, bg="white")
#print(max(counts))
#print(ceiling(max(counts)))
#print(round_any(max(counts), 10, f = ceiling))
barpos <- barplot(counts, ylim=c(0,round_up(max(counts))), main="Vollständigkeit der Produktangaben (in %)", col=c("#468847"))
#print(barpos)
#text(barpos, counts, labels=counts)
title(xlab="Vollständigkeit in %")
title(ylab="Häufigkeit")


#packages
library(dplyr)
library(raster)
library(rworldmap)
library(rworldxtra)
library(NbClust)
library(tidyr)
library(dplyr)
library(ggplot2)
library(fastcluster)
library(FactoMineR)
library(sf)
#land data to mask data
landmask <- rworldmap::getMap(resolution = "high")

#load data
# Test script localy
#wdpaid <- '18_54_22_56'
load("../../Data/baltic/envais.rdata")

#raster 2 datafram
r2df<-function(r){
	tmp<-raster::as.data.frame(r,xy=T)%>%
		tidyr::pivot_longer(3:(2+dim(r)[3]))
	return(tmp)
}
#group vessel cat + reduce spatial resolution + mask to avoid onland info
aggfac<-4 # reduction factor
#allmpa
allmpa<-list(mpa_fishing,mpa_dredging,mpa_sailing,mpa_pleasure,mpa_speedcraft,mpa_passenger,mpa_cargo,mpa_tanker,mpa_service,mpa_tug,mpa_military)
#aggregate
allmpa<-lapply(allmpa,aggregate,fact=aggfac)
#mask
allmpa<-lapply(allmpa,mask,mask=landmask,inverse=T)
#yearly
fsapply<-function(a){return(stackApply(a,indices=substr(names(a),2,5),fun=mean,na.rm=T))}
fsapply(mpa_fishing)
allmpa<-lapply(allmpa,fsapply)

#individual group or sum
#fishing
fishAIS<-r2df(allmpa[[1]])
#dredging
dredAIS<-r2df(allmpa[[2]])
#sailing
tmp1<-r2df(allmpa[[3]])%>%mutate(value1=value)%>%dplyr::select(-value)
tmp2<-r2df(allmpa[[4]])%>%mutate(value2=value)%>%dplyr::select(-value)
tmp<-full_join(tmp1,tmp2)
tmp$sum<-apply(tmp[,4:5],1,sum,na.rm=T)
sailAIS<-tmp%>%transmute(x,y,name,value=sum)
#transport
tmp1<-r2df(allmpa[[5]])%>%mutate(value1=value)%>%dplyr::select(-value)
tmp2<-r2df(allmpa[[6]])%>%mutate(value2=value)%>%dplyr::select(-value)
tmp3<-r2df(allmpa[[7]])%>%mutate(value3=value)%>%dplyr::select(-value)
tmp4<-r2df(allmpa[[8]])%>%mutate(value4=value)%>%dplyr::select(-value)
tmp<-full_join(full_join(full_join(tmp1,tmp2),tmp3),tmp4)
tmp$sum<-apply(tmp[,4:7],1,sum,na.rm=T)
tranAIS<-tmp%>%transmute(x,y,name,value=sum)
#service
tmp1<-r2df(allmpa[[8]])%>%mutate(value1=value)%>%dplyr::select(-value)
tmp2<-r2df(allmpa[[9]])%>%mutate(value2=value)%>%dplyr::select(-value)
tmp3<-r2df(allmpa[[10]])%>%mutate(value3=value)%>%dplyr::select(-value)
tmp<-full_join(full_join(tmp1,tmp2),tmp3)
tmp$sum<-apply(tmp[,4:6],1,sum,na.rm=T)
servAIS<-tmp%>%transmute(x,y,name,value=sum)
#eliminate pt at land
landmask2<-st_as_sf(landmask)
pt2<-st_as_sf(fishAIS,coords=c("x","y"),crs=crs(landmask2))
landmask2<-st_crop(st_as_sf(landmask),extent(pt2))
#pt at sea
ptin<-!apply(st_intersects(pt2,landmask2,sparse=F),1,any)
#plot(alldf[[1]][ptin,1:2])
#list of all stuff
alldf<-list(fishAIS[ptin,],dredAIS[ptin,],sailAIS[ptin,],tranAIS[ptin,],servAIS[ptin,])
#fct to add a name
fname<-function(a,nom){a$type<-nom;return(a)}
maptmp<-do.call("rbind",Map(fname,alldf,c("fish","dred","sail","tran","serv")))
ggplot(maptmp,aes(x=x,y=y,fill=value))+geom_raster()+
	scale_fill_distiller(palette="Spectral",name="Zone",trans="log10")+
	facet_grid(type~name)+
	borders("world",fill="grey",colour=NA)+
	coord_sf(xlim=range(maptmp$x),ylim=range(maptmp$y))+
	xlab("Longitude")+ylab("Latitude")+
	theme_bw()#+
	#theme(legend.position="bottom")

#classif
classif<-function(tmp){
	#tmp<-alldf[[4]]%>%group_by(name)%>%
	tmp<-tmp%>%group_by(name)%>%
		mutate(m=min(value,na.rm=T),
		       q=quantile(value,.95,na.rm=T))%>%
		ungroup()%>%
		mutate(value=ifelse(is.na(value),0,value))%>%
		dplyr::select(-m,-q)
	#tmp<-alldf[[1]]
	#tmp$value<-log10(tmp$value+1)
	tmp$value<-log10(tmp$value+1)
	mat0<-tmp%>%tidyr::pivot_wider(values_from=value,names_from=name)#,values_fill=0)
	idptNA<-is.finite(apply(mat0[,-c(1:2)],1,sum))
	#str(mat0[,-c(1:2)])
	d<-stats::dist((mat0[,-c(1:2)]))
	clust <-fastcluster::hclust(d, method = "ward.D2")
	pipo<-data.frame(x=mat0$x,y=mat0$y,zone=cutree(clust,6))
	return(pipo)
}
allzone<-lapply(alldf,classif)
maptmp<-do.call("rbind",Map(fname,allzone,c("fish","dred","sail","tran","serv")))
ggplot(maptmp,
       aes(x=x,y=y,fill=as.factor(zone)))+geom_raster()+
	scale_fill_brewer(palette="Set3",name="Cluster")+#,trans="log10")+
	#de\n navires\n(h.km^2)",trans="log10")+
	facet_wrap(~type,ncol=2)+
	borders("world",fill="grey",colour=NA)+
	coord_sf(xlim=range(maptmp$x),ylim=range(maptmp$y))+
	xlab("Longitude")+ylab("Latitude")+
	theme_bw()#+

#MCA
uu<-do.call("rbind",Map(fname,allzone,c("fish","dred","sail","tran","serv")))%>%
	mutate(zonetype=paste0(type,"-",zone))%>%
	dplyr::select(-zone)%>%
	pivot_wider(values_from=zonetype,names_from=type)
mca <- MCA(uu[,-c(1,2)], ncp=999, method="Burt", graph=F)
#
#plotellipses(mca, axes = c(1,2))
#plotellipses(mca, axes = c(1,3))

#final classif
d <- dist(mca$ind$coord)
clust <- fastcluster::hclust(d, method="ward.D2")
groups <- cutree(clust,6)

finalzone <- data.frame(uu[,c(1,2)],Cluster=factor(groups))

ggplot(finalzone,
       aes(x=x,y=y,fill=Cluster))+geom_raster()+
	scale_fill_brewer(palette="Set3",name="Cluster")+
	borders("world",fill="grey",colour=NA)+
	coord_sf(xlim=range(finalzone$x),ylim=range(finalzone$y))+
	xlab("Longitude")+ylab("Latitude")+
	theme_bw()#+

#add stuff
allrez<-do.call("rbind",Map(fname,alldf,c("fish","dred","sail","tran","serv")))%>%
	left_join(finalzone)

ggplot()+
	  geom_boxplot(data=allrez,aes(x=type,y=value,fill=type))+
	    facet_wrap(~Cluster,nrow=2)+xlab("type")+ylab("Parameters")+
	    scale_y_log10()+
	      scale_fill_brewer(palette="Set3")


REBOL [
  Title:   "Red run time error test script"
	Author:  "Peter W A Wood"
	File: 	 %run-time-error-test.r
	Rights:  "Copyright (C) 2011-2012 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

~~~start-file~~~ "Red run time errors"

	--test-- "rte-1"
		--compile-and-run-this/error {Red[] i: 1 j: 0 k: i / j}
    	--assert-red-printed? "*** Runtime Error 13: integer divide by zero"

    --test-- "rte-2"
    	--compile-and-run-this/error {Red[] absolute -2147483648}
    	--assert-red-printed? "*** Runtime Error 99: integer overflow"

~~~end-file~~~


#' Summarize ASAP
#'
#' Point estimates and Hessian-based 95 percent CI for SSB, R, and Freport.
#' @param asap name of the variable that read in the asap.rdat file
#' @param a1 list file produced by grab.aux.files function
#' @param od output directory for plots and csv files
#' @export

SummarizeASAP <- function(asap,a1,od){

  if(any(!is.na(a1$asap.std))){
    asap.name <- a1$asap.name
    years <- seq(asap$parms$styr, asap$parms$endyr)
    ssb.std <- a1$asap.std[which(a1$asap.std$name=="SSB") ,4]
    recr.std <- a1$asap.std[which(a1$asap.std$name=="recruits") ,4]
    Frep.std <- a1$asap.std[which(a1$asap.std$name=="Freport") ,4]
    ssb_up <-  asap$SSB + 1.96*ssb.std
    ssb_lo <-  asap$SSB - 1.96*ssb.std
    recr_up <-  asap$N.age[,1] + 1.96*recr.std
    recr_lo <-  asap$N.age[,1] - 1.96*recr.std
    Frep_up <-  asap$F.report + 1.96*Frep.std
    Frep_lo <-  asap$F.report - 1.96*Frep.std
    mwg.out <- cbind("Year"=years, "SSB"=asap$SSB, "SSB_95_lo"=ssb_lo, "SSB_95_hi"=ssb_up,
                     "Recr"=asap$N.age[,1], "Recr_95_lo"=recr_lo, "Recr_95_hi"=recr_up,
                     "Freport"=asap$F.report, "Freport_95_lo"=Frep_lo, "Freport_95_hi"=Frep_up  )

    write.csv(mwg.out, paste0(od,"ASAP_summary_",asap.name,".csv"), row.names=F)
  }
  return()
}


subroutine locn(i,j,kj,nadj,madj,x,y,ntot,eps)

# Find the appropriate location for j in the adjacency list
# of i.  This is the index which j ***will*** have when
# it is inserted into the adjacency list of i in the
# appropriate place.  Called by insrt.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
logical before

n = nadj(i,0)

# If there is nothing already adjacent to i, then j will have place 1.
if(n==0) {
        kj = 1
        return
}

# Run through i's list, checking if j should come before each element
# of that list.  (I.e. if i, j, and k are in anti-clockwise order.)
# If j comes before the kj-th item, but not before the (kj-1)-st, then
# j should have place kj.
do ks = 1,n {
	kj = ks
        k = nadj(i,kj)
        call acchk(i,j,k,before,x,y,ntot,eps)
        if(before) {
                km = kj-1
                if(km==0) km = n
                k = nadj(i,km)
                call acchk(i,j,k,before,x,y,ntot,eps)
                if(before) next
                # If j is before 1 and after n, then it should
                # have place n+1.
                if(kj==1) kj = n+1
                return
        }
}

# We've gone right through the list and haven't been before
# the kj-th item ***and*** after the (kj-1)-st on any occasion.
# Therefore j is before everything (==> place 1) or after
# everything (==> place n+1).
if(before) kj = 1
else kj = n+1

return
end


source("common/src/eval/basic_stats.r") # For "statistics" list

target_shuffle = function(k, x, y, fitModel, stat, returnValues=TRUE, estimateSignificance=TRUE, ...){
  results = rep(NULL, k)
  for(i in 1:k){
    shuffled_y = sample(y, length(y))
    mod = suppressWarnings(fitModel(x, shuffled_y))
    results[i] = stat(mod, x, shuffled_y, ...)
  }
  retval=list()
  if(returnValues) retval$values = results
  if(estimateSignificance){
    retval$mod = suppressWarnings(fitModel(x,y))
    retval$obs_stat = stat(retval$mod, x, y, ...)
    retval$est_pval = 1- mean(retval$obs_stat > results)
  }
  retval
}

#####################################
## Scavenged from bootstrap.r      ##
## Should try abstract this out.   ##
## Basically only changed one line ##
#####################################

args <- commandArgs(TRUE) ## reports/task0/logreg.r_tshuffle.txt accuracy
if(length(args)>0){
  outpath = args[1]
  task_name = gsub("(task.*)/reports/(.*\\.r)_tshuffle.txt","\\1", outpath)
  mod_name  = gsub("(task.*)/reports/(.*\\.r)_tshuffle.txt","\\2", outpath)
  stat_name = args[2]
  data_path = paste0(task_name, "/data/processed/train.rdata")

  load(data_path)
  stat_func = statistics[[stat_name]]

  mod_funcs = paste0(task_name, "/src/models/", mod_name)
  source(mod_funcs)

  k = 200
  results = target_shuffle(k, X, Y, train_model, stat_func, returnValues=TRUE, estimateSignificance=TRUE)

  fname = paste0(task_name, "/data/processed/", mod_name, "_tshuffle.rdata")
  dir.create(dirname(fname), showWarnings = FALSE)
  save(results, file = fname)

  agg_results = data.frame(est_pval = results$est_pval)

  ### If bootstrap has been done, maybe calculate an interval around the p-val estimate.
  dir.create(dirname(outpath), showWarnings = FALSE)
  write.csv(agg_results, file = outpath)

  source("common/src/eval/eval_db/dbapi.r")
  result_name = paste("target_shuffle",stat_name, k, sep="_")
  m = prep_results(agg_results)

  log_model_result(task_name, mod_name, result_name, m)
  dbDisconnect(conn)
}


context("dimnames")

dn = list(c('a','b'),c('x','y'))
a = setNames(1:2, dn[[1]])
A = matrix(1:4, nrow=2, ncol=2, dimnames=dn)
DF = structure(list(y=3:4, z=c(6,5), x=1:2, A=c("b", "a")),
        .Names=c("y","z","x","A"), row.names=1:2, class="data.frame")
ll = list(a=a, A=A, DF=DF)

test_that("vector and dropping rules", {
    expect_equal(dimnames(a), dimnames(a, drop=FALSE), dn[1])
    expect_equal(dimnames(a, drop=TRUE), dn[[1]])
    expect_equal(dimnames(a, along=1), dn[[1]])
    expect_equal(dimnames(a, along=1, drop=FALSE), dn[1])
})

test_that("ignore along for vector, not array", {
    expect_equal(dimnames(a, along=2), dn[[1]])
    expect_error(dimnmaes(as.array(a), along=2))
})

test_that("matrix", {
    expect_equal(dimnames(A), dn)
    expect_equal(dimnames(A, along=2), dn[[2]])
    expect_error(dimnames(A, along=3))
})

test_that("data.frame", {
    expect_equal(dimnames(DF, along=1), as.character(1:2))
})

test_that("list", {
    dnl = dimnames(ll)
    expect_equal(dnl$a, dn[1])
    expect_equal(dnl$A, dn)
    dnl1 = dimnames(ll, along=1)
    expect_equal(dnl1$a, dnl1$A, dn[[1]])
})

test_that("zero-length", {
    expect_equal(dimnames(c()), list(NULL)) #TODO: this should give integer()
    expect_equal(dimnames(c(), null_as_integer=TRUE), list(integer()))

    expect_null(dimnames(c(), drop=TRUE))
    expect_equal(dimnames(c(), null_as_integer=TRUE, drop=TRUE), integer())
})


flights <- nycflights13::flights
airlines <- nycflights13::airlines
glimpse(flights)

demora_max <- flights %>%
  filter(!is.na(arr_delay)) %>%
  group_by(carrier) %>%
  summarise(max_demora = max(arr_delay)) %>%
  arrange(desc(max_demora))
head(demora_max)
airlines %>%
  filter(carrier == "MQ")


hirespath <- "survey_Mar312358"
medrespath <- "surveymrhi"

#hires <- c("v4-7-0-0.3-0", "v4-7-0-0.2-0", "v4-7-0-0.4-0")
#hiresreal <- c("v4-7-0-0.3-0")

hires <- c("v4-7-0-0.3-0", "v4-7-0-0.3-0.5", "v4-8-0-0.3-0", "v4-8-0-0.3-0.5" )
hiresreal <- c("v4-7-0-0.3-0", "v4-8-0-0.3-0")

medres <- c("v1-4-0-0.3-0", "v1-7-0-0.3-0", "v1-4-0-0.3-0.5", "v1-7-0-0.3-0.5", "v1-8-0-0.3-0", "v1-8-0-0.3-0.5", "v1-9-0-0.3-0", "v1-9-0-0.3-0.5", "v1-11-0-0.3-0", "v1-11-0-0.3-0.5", "v1-12-0-0.3-0", "v1-12-0-0.3-0.5")
medresreal <- c("v1-4-0-0.3-0", "v1-7-0-0.3-0", "v1-8-0-0.3-0","v1-9-0-0.3-0","v1-11-0-0.3-0","v1-12-0-0.3-0")

gamma <- numeric(0)
gammaerr1 <- numeric(0)
gammaerr2 <- numeric(0)

vmax <- numeric(0)
vmaxerr1 <- numeric(0)
vmaxerr2 <- numeric(0)

r2 <- numeric(0)
r2err1 <- numeric(0)
r2err2 <- numeric(0)

for (file in hires) {
	path <- paste(hirespath, "/", file, "/curve/mcmc.txt", sep="")
	data <- read.table(path, head=FALSE)
	gamma <- c(gamma, median(abs(data[[4]])))
	vmax <- c(vmax, median(data[[6]]))
	r2 <- c(r2, median(data[[5]]))

	x <- quantile(abs(data[[4]]), c(0.16, 0.86))
	gammaerr1 <- c(gammaerr1, x[[1]])
	gammaerr2 <- c(gammaerr2, x[[2]])

	x <- quantile(data[[6]], c(0.16, 0.86))
	vmaxerr1 <- c(vmaxerr1, x[[1]])
	vmaxerr2 <- c(vmaxerr2, x[[2]])

	x <- quantile(data[[5]], c(0.16, 0.86))
	r2err1 <- c(r2err1, x[[1]])
	r2err2 <- c(r2err2, x[[2]])
}

print(r2)
print(gamma)

plot(gamma, r2, pch=5, col="red", xlim=c(0,2), ylim=c(0,3), xlab=expression(gamma), ylab=expression(r[2]))
segments(gammaerr1, r2, gammaerr2, r2, col="red")
segments(gamma, r2err1, gamma, r2err2, col="red")

gamma <- numeric(0)
gammaerr1 <- numeric(0)
gammaerr2 <- numeric(0)

vmax <- numeric(0)
vmaxerr1 <- numeric(0)
vmaxerr2 <- numeric(0)

r2 <- numeric(0)
r2err1 <- numeric(0)
r2err2 <- numeric(0)

for (file in hiresreal) {
	path <- paste(hirespath, "/", file, "/realcurve/mcmc.txt", sep="")
	data <- read.table(path, head=FALSE)
	gamma <- c(gamma, median(abs(data[[4]])))
	vmax <- c(vmax, median(data[[6]]))
	r2 <- c(r2, median(data[[5]]))

	x <- quantile(abs(data[[4]]), c(0.16, 0.86))
	gammaerr1 <- c(gammaerr1, x[[1]])
	gammaerr2 <- c(gammaerr2, x[[2]])

	x <- quantile(data[[6]], c(0.16, 0.86))
	vmaxerr1 <- c(vmaxerr1, x[[1]])
	vmaxerr2 <- c(vmaxerr2, x[[2]])

	x <- quantile(data[[5]], c(0.16, 0.86))
	r2err1 <- c(r2err1, x[[1]])
	r2err2 <- c(r2err2, x[[2]])

}

points(gamma, r2, pch=5, col="black")
segments(gammaerr1, r2, gammaerr2, r2, col="black")
segments(gamma, r2err1, gamma, r2err2, col="black")

gamma <- numeric(0)
gammaerr1 <- numeric(0)
gammaerr2 <- numeric(0)

vmax <- numeric(0)
vmaxerr1 <- numeric(0)
vmaxerr2 <- numeric(0)

r2 <- numeric(0)
r2err1 <- numeric(0)
r2err2 <- numeric(0)

for (file in medres) {
	path <- paste(medrespath, "/", file, "/curve/mcmc.txt", sep="")
	data <- read.table(path, head=FALSE)
	gamma <- c(gamma, median(abs(data[[4]])))
	vmax <- c(vmax, median(data[[6]]))
	r2 <- c(r2, median(data[[5]]))

	x <- quantile(abs(data[[4]]), c(0.16, 0.86))
	gammaerr1 <- c(gammaerr1, x[[1]])
	gammaerr2 <- c(gammaerr2, x[[2]])

	x <- quantile(data[[6]], c(0.16, 0.86))
	vmaxerr1 <- c(vmaxerr1, x[[1]])
	vmaxerr2 <- c(vmaxerr2, x[[2]])

	x <- quantile(data[[5]], c(0.16, 0.86))
	r2err1 <- c(r2err1, x[[1]])
	r2err2 <- c(r2err2, x[[2]])
}

points(gamma, r2, pch=5, col="blue")
segments(gammaerr1, r2, gammaerr2, r2, col="blue")
segments(gamma, r2err1, gamma, r2err2, col="blue")

gamma <- numeric(0)
gammaerr1 <- numeric(0)
gammaerr2 <- numeric(0)

vmax <- numeric(0)
vmaxerr1 <- numeric(0)
vmaxerr2 <- numeric(0)

r2 <- numeric(0)
r2err1 <- numeric(0)
r2err2 <- numeric(0)

for (file in medresreal) {
	path <- paste(medrespath, "/", file, "/realcurve/mcmc.txt", sep="")
	data <- read.table(path, head=FALSE)
	gamma <- c(gamma, median(abs(data[[4]])))
	vmax <- c(vmax, median(data[[6]]))
	r2 <- c(r2, median(data[[5]]))

	x <- quantile(abs(data[[4]]), c(0.16, 0.86))
	gammaerr1 <- c(gammaerr1, x[[1]])
	gammaerr2 <- c(gammaerr2, x[[2]])

	x <- quantile(data[[6]], c(0.16, 0.86))
	vmaxerr1 <- c(vmaxerr1, x[[1]])
	vmaxerr2 <- c(vmaxerr2, x[[2]])

	x <- quantile(data[[5]], c(0.16, 0.86))
	r2err1 <- c(r2err1, x[[1]])
	r2err2 <- c(r2err2, x[[2]])

}

points(gamma, r2, pch=5, col="grey")
segments(gammaerr1, r2, gammaerr2, r2, col="grey")
segments(gamma, r2err1, gamma, r2err2, col="grey")


 DSPOSV Example Program Results

 Solution
        1.0000    -1.0000     2.0000    -3.0000


## https://wikis.utexas.edu/display/bioiteam/Clustering+using+WGCNA

library(WGCNA)

library(flashClust)

matrix<-read.table("matrix.txt",h=T)
pheno<-read.table("trait.txt",h=T)

# Run this to check if there are gene outliers
gsg = goodSamplesGenes(matrix, verbose = 3)
gsg$allOK

#If the last statement returns TRUE, all genes have passed the cuts. If not, we remove the offending genes and samples from the data with the following:
#if (!gsg$allOK)
#   {if (sum(!gsg$goodGenes)>0)
#       printFlush(paste("Removing genes:", paste(names(matrix)[!gsg$goodGenes], collapse= ", ")));
#       if (sum(!gsg$goodSamples)>0)
#           printFlush(paste("Removing samples:", paste(rownames(matrix)[!gsg$goodSamples], collapse=", ")))
#       matrix= matrix[gsg$goodSamples, gsg$goodGenes]
#       }

table(rownames(matrix)==rownames(pheno))

save(matrix, pheno, file="SamplesAndTraits.RData")

# Choose a soft threshold power- USE A SUPERCOMPUTER IRL ------------------------------------

powers = c(c(1:10), seq(from =10, to=30, by=1)) #choosing a set of soft-thresholding powers
sft = pickSoftThreshold(matrix, powerVector=powers, verbose =5, networkType="signed") #call network topology analysis function

sizeGrWindow(9,5)
par(mfrow= c(1,2))
cex1=0.9
plot(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2], xlab= "Soft Threshold (power)", ylab="Scale Free Topology Model Fit, signed R^2", type= "n", main= paste("Scale independence"))
text(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2], labels=powers, cex=cex1, col="red")
abline(h=0.90, col="red")
plot(sft$fitIndices[,1], sft$fitIndices[,5], xlab= "Soft Threshold (power)", ylab="Mean Connectivity", type="n", main = paste("Mean connectivity"))
text(sft$fitIndices[,1], sft$fitIndices[,5], labels=powers, cex=cex1, col="red")

#from this plot, we would choose a power of 18 becuase it's the lowest power for which the scale free topology index reaches 0.90

#build a adjacency "correlation" matrix
enableWGCNAThreads()
softPower = 7
adjacency = adjacency(matrix, power = softPower, type = "signed") #specify network type
head(adjacency)

# Construct Networks- USE A SUPERCOMPUTER IRL -----------------------------
#translate the adjacency into topological overlap matrix and calculate the corresponding dissimilarity:
TOM = TOMsimilarity(adjacency, TOMType="signed") # specify network type
dissTOM = 1-TOM

# Generate Modules --------------------------------------------------------
 # Generate Modules --------------------------------------------------------

 library(flashClust)
# Generate a clustered gene tree
geneTree = flashClust(as.dist(dissTOM), method="average")
plot(geneTree, xlab="", sub="", main= "Gene Clustering on TOM-based dissimilarity", labels= FALSE, hang=0.04)
#This sets the minimum number of genes to cluster into a module
minModuleSize = 30
dynamicMods = cutreeDynamic(dendro= geneTree, distM= dissTOM, deepSplit=2, pamRespectsDendro= FALSE, minClusterSize = minModuleSize)
dynamicColors= labels2colors(dynamicMods)
MEList= moduleEigengenes(matrix, colors= dynamicColors,softPower = softPower)
MEs= MEList$eigengenes
MEDiss= 1-cor(MEs)
METree= flashClust(as.dist(MEDiss), method= "average")
save(dynamicMods, MEList, MEs, MEDiss, METree, file= "Network_allSamples_signed_RLDfiltered.RData")

## TOM graph
TOMplot(dissTOM,geneTree,dynamicColors)

## mds plot
cmd1=cmdscale(as.dist(dissTOM),2)

plot(cmd1,col=dynamicColors,main="MDS plot",xlab="Scaling Dimension 1",ylab="Scaling Dimension 2")

#plots tree showing how the eigengenes cluster together
#INCLUE THE NEXT LINE TO SAVE TO FILE
#pdf(file="clusterwithoutmodulecolors.pdf")
plot(METree, main= "Clustering of module eigengenes", xlab= "", sub= "")
#set a threhold for merging modules. In this example we are not merging so MEDissThres=0.0
MEDissThres = 0.0
merge = mergeCloseModules(matrix, dynamicColors, cutHeight= MEDissThres, verbose =3)
mergedColors = merge$colors
mergedMEs = merge$newMEs
#INCLUE THE NEXT LINE TO SAVE TO FILE
#dev.off()

#plot dendrogram with module colors below it
#INCLUE THE NEXT LINE TO SAVE TO FILE
#pdf(file="cluster.pdf")
plotDendroAndColors(geneTree, cbind(dynamicColors, mergedColors), c("Dynamic Tree Cut", "Merged dynamic"), dendroLabels= FALSE, hang=0.03, addGuide= TRUE, guideHang=0.05)
moduleColors = mergedColors
colorOrder = c("grey", standardColors(50))
moduleLabels = match(moduleColors, colorOrder)-1
MEs = mergedMEs
#INCLUE THE NEXT LINE TO SAVE TO FILE
#dev.off()

save(MEs, moduleLabels, moduleColors, geneTree, file= "Network_allSamples_signed_nomerge_RLDfiltered.RData")

# Correlate traits --------------------------------------------------------

#Define number of genes and samples
nGenes = ncol(matrix)
nSamples = nrow(matrix)
#Recalculate MEs with color labels
MEs0 = moduleEigengenes(matrix, moduleColors)$eigengenes
MEs = orderMEs(MEs0)
moduleTraitCor = cor(MEs, pheno, use= "p")
moduleTraitPvalue = corPvalueStudent(moduleTraitCor, nSamples)

#Print correlation heatmap between modules and traits
textMatrix= paste(signif(moduleTraitCor, 2), "\n(",
                        signif(moduleTraitPvalue, 1), ")", sep= "")
dim(textMatrix)= dim(moduleTraitCor)
par(mar= c(6, 8.5, 3, 3))

#display the corelation values with a heatmap plot
#INCLUE THE NEXT LINE TO SAVE TO FILE
#pdf(file="heatmap.pdf")
labeledHeatmap(Matrix= moduleTraitCor,
            xLabels= names(pheno),
            yLabels= names(MEs),
            ySymbols= names(MEs),
            colorLabels= FALSE,
            colors= blueWhiteRed(50),
            textMatrix= textMatrix,
            setStdMargins= FALSE,
            cex.text= 0.5,
            zlim= c(-1,1),
            main= paste("Module-trait relationships"))
#INCLUE THE NEXT LINE TO SAVE TO FILE
#dev.off()

## gene names from turquoise modulle
names(matrix)[moduleColors=="turquoise"]
turquoise<-data.frame(names(matrix)[moduleColors=="turquoise"])
write.table(turquoise,file="module_turquoise.txt")

################# cytoscape export
# select modules
modules = c("turquoise")
# Select module probes
inModule=is.finite(match(dynamicColors,modules))
probes = names(matrix)
modProbes=probes[inModule]

# Select the corresponding Topological Overlap
modTOM = TOM[inModule, inModule]
dimnames(modTOM) = list(modProbes, modProbes)
# Export the network into edge and node list files for Cytoscape
cyt = exportNetworkToCytoscape(modTOM,
edgeFile=paste("CytoEdge",paste(modules,collapse="-"),".txt",sep=""),
nodeFile=paste("CytoNode",paste(modules,collapse="-"),".txt",sep=""),
weighted = TRUE, threshold = 0.2,nodeNames=modProbes, nodeAttr = dynamicColors[inModule])

cyt$nodeData$nodeName

edge<-data.frame(cyt$edgeData)
node<-data.frame(cyt$nodeData)
write.table(edge,file="turquoise_edge.txt")
write.table(node,file="turquoise_node.txt")


filterData <- function (type, raw) {
    res <- array('', dim=c(nrow(raw),ncol(raw)))
    idx <- 1;

    for (i in 1:nrow(raw)) {
        if (raw[i,3]==type) {
            for (j in 1:ncol(raw)) {
                res[idx,j] <- toString(raw[i,j])
            }
            idx <- idx + 1
        }
    }

    return(res[1:idx-1,])
}

nodes <- as.matrix(read.csv('nodes.list', sep=',', header=FALSE), quote=FALSE)
#print(nodes)

n <- length(nodes)
nodesMap <- new.env(hash=T, parent=emptyenv())
for(i in 1:n) {
  nodesMap[[nodes[i]]] <- i
}
#print(ls(nodesMap))

raw <- filterData('latency', read.csv('data.csv', sep='\t', header=FALSE))
data <- as.matrix(raw, quote=FALSE)
#print(data)

RTT <- matrix(nrow=n, ncol=n)
Latency <- matrix(nrow=n, ncol=n)
# The first n columns represent to clock error for each node
# The second n times n columns represent the one way latency from node n1 to node n2 (including self ping time)
# The first n rows are used to add up the one-way latency and the clock errors or each of the two nodes
# The second n rows are used to sum up the one-way latency in both direction to equal the round trip time
# The third n rows are used to zero out the sum of one-way latency. This is obviously not a correct assumption but required to let the solver find a solution.
# The fourth n rows are used to minimize the error for the sum of both nodes' clock error to not exceed the difference of the sum of measured one-way latencies and round trip time
X <- matrix(0L, nrow=4*nrow(data), ncol=n+(n*n), byrow=T)
W <- diag(x=1, nrow=4*nrow(data), ncol=4*nrow(data))
y <- array(0L, dim = c(4*nrow(data)))
IdxErr <- 3*nrow(data)+1

for(i in 1:nrow(data)) {
    a <- nodesMap[[data[i,1]]]
    b <- nodesMap[[data[i,4]]]
    Lab <- as.numeric(data[i,10])
    RTTab <- as.numeric(data[i,15])
    IdxL <- (a-1)*n+b
    IdxLRev <- (b-1)*n+a
    LbaDash <- Latency[b,a]
    RTTbaDash <- RTT[b,a]

    if (!is.null(a) && !is.null(b) && !is.null(Lab) && !is.null(RTTab)) {
        Latency[a,b] = Lab
        RTT[a,b] = RTTab

        X[i,a] = ifelse(a==b, 0, -1)
        X[i,b] = ifelse(a==b, 0, 1)
        X[i,n+IdxL] = 1
        y[i] = Lab
        X[nrow(data)+i,n+IdxL] = ifelse(IdxL==IdxLRev, 2, 1)
        X[nrow(data)+i,n+IdxLRev] = ifelse(IdxL==IdxLRev, 2, 1)
        y[nrow(data)+i] = RTTab
        X[2*nrow(data)+i,n+IdxL] = ifelse(IdxL==IdxLRev, 0, 1)
        X[2*nrow(data)+i,n+IdxLRev] = ifelse(IdxL==IdxLRev, 0, 1)
        y[2*nrow(data)+i] = 0

        if (!is.na(LbaDash) && !is.na(RTTbaDash)) {
            if (IdxErr <= nrow(X)) {
                X[IdxErr,a] = 1
                X[IdxErr,b] = 1
                y[IdxErr] = abs(Lab) + abs(LbaDash) - RTTab
                IdxErr = IdxErr + 1
            } else {
                print('WARN: Too much data')
            }
            if (IdxErr <= nrow(X)) {
                X[IdxErr,b] = 1
                X[IdxErr,a] = 1
                y[IdxErr] = abs(LbaDash) + abs(Lab) - RTTbaDash
                IdxErr = IdxErr + 1
            } else {
                print('WARN: Too much data')
            }
        }
    }
}

#print(X)
#print(y)

for (i in 1:nrow(data)) {
    # Clock Error
    W[i,i] = 100
    # One way latency adds up to round trip time
    W[i+nrow(data),i+nrow(data)] = 100
    # Do we want one way latency do zero out? It's an assumption that's not true
    W[i+2*nrow(data),i+2*nrow(data)] = 0.001
    # Minimize clock error estimation
    W[i+3*nrow(data),i+3*nrow(data)] = 1
}

X.T <- t(W %*% X)
#print(X.T)

betaHat <- solve(X.T %*% W %*% X) %*% X.T %*% W %*% y

#print(W)
print(betaHat)

TimeOffset <- matrix(0L, nrow=n, ncol=1, byrow=T)
TimeOffset[,1] = betaHat[1:n,1]
rownames(TimeOffset) <- nodes[,1]
colnames(TimeOffset) <- c('TimeOffset')

print(round(TimeOffset, digits=3))

LatencyHat <- matrix(betaHat[(n+1):(4*n),1], nrow=n, ncol=n, byrow=T)
rownames(LatencyHat) <- nodes[,1]
colnames(LatencyHat) <- nodes[,1]

#print(round(LatencyHat, digits=3))


print("Performed by Yash Verma 18BCS1814")
print("Sequence of numbers from 20 to 50:")
print(seq(20,50))
print("Mean of numbers from 20 to 60:")
print(mean(20:60))
print("Sum of numbers from 51 to 91:")
print(sum(51:91))


#' Test associations at CpG sites
#'
#' Fit generalized linear model (GLM) to methylation levels each CpG site.
#'
#' Note: \code{\link{mclapply}} is used to fit regression models
#' using multiple cores.
#'
#' @param formula An object of class \code{\link{formula}}:
#' a symbolic description of the model to be fitted.
#' DNA methylation is referred to by the variable name 'methylation'.
#' @param methylation DNA methylation matrix, one row per CpG site,
#' one column per sample.
#' @param variable.of.interest Name of variable(s) in the model formula
#' for which to save summary statistics.  If it is the dependent variable
#' in the formula, then it must be numeric or binary; otherwise, it may
#' be any type of variable or even a vector of variables.
#' The value is ignored if \code{method == "coxph"}.
#' @param data Data frame of variables to include in the model.
#' @param family See description for \code{\link{glm}}.
#' @param method Method for regressions: "glm", "rlm", "limma" or "coxph" (Default: "glm").
#' @param generate.confounders Generate variables from the methylation data
#' to adjust for unknown confounders. May be \code{NULL} for none (default),
#' "sva" or "smartsva" to generate surrogate variables, or "pca" to generate
#' prinicipal components. If \code{method == "coxph"}, then \code{generate.confounders}
#' must be \code{NULL} or \code{"pca"}.
#' @param n.confounders Number of unknown confounders to generate.  A value of
#' \code{NULL} allows \code{\link{sva}} to select the number automatically
#' or if principal components the maximum number (Default: NULL).
#' @param most.variable Generate confounders from the
#' #' given most variable CpG sites rather than the whole matrix (Default: NULL).
#' @param random.subset Generate surrogate variables from the
#' given percentage of randomly selected CpG sites rather than the whole matrix (Default: 0.05, i.e. 5 percent).
#' @param ... Arguments to \code{\link{glm}}, \code{\link{rlm}}, \code{\link{limma::eBayes}},
#' or \code{\link{survival::coxph}}.
#' @return List containing a table of association statistics ('table') and the
#' model design matrix ('design').
#'
#' @export
ewaff.sites <- function(formula,
                        variable.of.interest,
                        methylation,
                        data,
                        family=gaussian,
                        method="glm",
                        generate.confounders=NULL,
                        n.confounders=NULL,
                        most.variable=NULL,
                        random.subset=0.05,
                        ...,
                        debug=F) {

    if (debug) browser()

    stopifnot(method %in% c("glm","rlm","limma","coxph"))
    stopifnot(is.null(generate.confounders)
              || generate.confounders == "sva"
              || generate.confounders == "smartsva"
              || generate.confounders == "pca"
              && !is.null(n.confounders) && n.confounders > 0 && n.confounders < ncol(methylation))
    stopifnot(method != "coxph" || is.null(generate.confounders) || generate.confounders=="pca")

    if (method == "coxph")
        variable.of.interest <- as.character(formula)[2]

    design <- build.design.matrix(formula=formula,
                                  variable.of.interest=variable.of.interest,
                                  methylation=methylation,
                                  data=data,
                                  family=family,
                                  method=method,
                                  generate.confounders=generate.confounders,
                                  n.confounders=n.confounders,
                                  most.variable=most.variable,
                                  random.subset=random.subset,
                                  ...)

    ## get names of the dependent variable
    ## and the independent variable of interest
    dependent.variable <- design$dependent.variable
    independent.variable <- design$independent.variable
    family <- design$family
    sample.idx <- design$sample.idx
    design <- design$matrix

    methylation <- methylation[,sample.idx,drop=F]

    stopifnot(method %in% c("glm","coxph") || dependent.variable == "methylation")

    if (length(independent.variable) == 0 || length(dependent.variable) == 0)
        stop("The variable.of.interest is missing")

    if (length(dependent.variable) > 1)
        stop("When methylation is an independent variable, variable.of.interest must name a single numeric or binary variable")

    if (length(independent.variable) > 1 && !(method %in% c("glm","limma")))
        stop("When method is not 'limma' or 'glm', variable.of.interest must be a single numeric or binary variable")

    if (method != "coxph")
        stats <- sites.glm(methylation, design, dependent.variable, independent.variable, method, family, ...)
    else
        stats <- sites.coxph(methylation, design, dependent.variable, ...)

    stats$p.adjust <- p.adjust(stats$p.value, "bonferroni")
    rownames(stats) <- rownames(methylation)

    list(class="sites",
         formula=paste(as.character(formula)[c(2,1,3)], collapse=" "),
         variable.of.interest=variable.of.interest,
         data=data,
         family=family,
         method=method,
         generate.confounders=generate.confounders,
         n.confounders=n.confounders,
         dependent.variable=dependent.variable,
         independent.variable=independent.variable,
         design=design[,-which(colnames(design) == "methylation"),drop=F],
         sample.idx=sample.idx,
         table=stats)
}

is.sites.object <- function(object)
    is.list(object) && "class" %in% names(object) && object$class == "sites"


#Jenny Smith

#December 2017

#Purpose: Create a barcode plot using either SNR (or is Kolmogorov-Smirnov statistic?) statistics from Broad GSEA, or limma moderated t-stats.
# Will check on that. I know genes are ranked by Signal-to-noise (SNR) and KS stat is used to
#determine the significance of genes "inside" the geneset vs genes "outside" the geneset. So that is just the nominal P-value.
#or right, so using the rank stat is SNR.

#Create Barcode Plots of Enrichement

GSEA.res <- read.csv("GSEA/only_1031/GSEA_50TPM.Filter_1000xPhenoPerm_C2.Kegg.Gsea.1510966589373/gsea_report_for_pos.1031_1510966589373.csv", stringsAsFactors = FALSE)

HH.res <- read.csv("GSEA/only_1031/GSEA_50TPM.Filter_1000xPhenoPerm_C2.Kegg.Gsea.1510966589373/KEGG_HEDGEHOG_SIGNALING_PATHWAY.csv", stringsAsFactors = FALSE)

Rank.Stat <- read.csv("GSEA/only_1031/GSEA_50TPM.Filter_1000xPhenoPerm_C2.Kegg.Gsea.1510966589373/ranked_gene_list_pos.1031_versus_neg.1031_1510966589373.csv", stringsAsFactors = FALSE)

head(Rank.Stat)

# library(limma)
idx <- Rank.Stat$NAME %in% HH.res$PROBE #49 genes

# SigtoNoise.stat <- HH.res$RANK.METRIC.SCORE %>%
#   set_names(HH.res$PROBE)

SigtoNoise.stat <- Rank.Stat$SCORE %>%
  set_names(Rank.Stat$NAME)

# idx <- HH.res$CORE.ENRICHMENT == "Yes"
# HH.res$RANK.METRIC.SCORE[idx] <- HH.res$RANK.METRIC.SCORE[idx] + 1

# tiff("GBCGLIS_vs_OtherAML_C2.HH.Kegg_Barcodeplot.tiff", height= 5, width = 7, units="in", res=600)
barcodeplot(SigtoNoise.stat, index=idx)
# dev.off()

t.stat <- CBFGLISvsOtherAML$DE$eBayesFit$t[,1]
idx <- names(t.stat) %in% HH.res$PROBE #36
# tiff("GBCGLIS_vs_OtherAML_C2.HH.Kegg_Limma_tstat_Barcodeplot.tiff", height= 5, width = 7, units="in", res=600)
barcodeplot(t.stat, index = idx)
# dev.off()

head(GSEA.res)

sel.gsea <- GSEA.res %>%
  slice(1:5) %>%
  select(NAME,FDR.q.val) %>%
  mutate(FDR.q.val.fix = ifelse(FDR.q.val == 0, 1e-3, FDR.q.val)) %>%
  mutate(negLog2FDR = -log2(FDR.q.val.fix)) %>%
  mutate(path=gsub("_", "\n", NAME))

# tiff("GBCGLIS_vs_OtherAML_C2.Kegg_FDR_barplot_addExtraRoom.tiff", height= 7, width = 7, units="in", res=600)
ggplot(sel.gsea, aes(y=negLog2FDR,x=reorder(sel.gsea$path, -sel.gsea$FDR.q.val), fill=NAME)) +
  geom_bar(stat="identity") +
  scale_y_continuous(limits = c(0,14),breaks = seq(0,14,by=2)) +
  scale_fill_brewer(palette="Dark2") +
  geom_hline(aes(yintercept = -log2(0.05)), linetype="dashed") +
  theme_numX + labs(x="", y="-log2(FDR)") + guides(fill=FALSE) +
  coord_flip()
# dev.off()


# R script
#
# author: Xavier Devroey

library(ggplot2)
library(dplyr)

source('dataclean.r')

cat('======================', '\n')
cat('Benchmark description:', '\n')
cat('======================', '\n')

benchmark <- getBenchmark()

simplified <- benchmark %>%
  distinct(application, application_name, case, exception_factor) %>%
  mutate(application_name = ifelse(application %in% c('math', 'time', 'chart', 'mockito', 'lang'), 'Defects4J', application_name))

cat('Stacktraces statistics per application:', '\n')
df <- benchmark %>%
  distinct(application, application_name, case, exception_class, exception, exception_factor, frame_count) %>%
  group_by(application, application_name) %>%
  summarise(n_cases = n(), mean_frame_count = mean(frame_count), sd_frame_count = sd(frame_count))
print(df)

cat('Stacktraces statistics per application per exception type:', '\n')
df <- benchmark %>%
  distinct(application, case, exception_class, exception, exception_factor, frame_count) %>%
  group_by(application, exception_factor) %>%
  summarise(n_cases = n(), mean_frame_count = mean(frame_count), sd_frame_count = sd(frame_count))
print(df)

cat('CCN for applications:', '\n')
df <- benchmark %>%
  distinct(application, application_name, case, avg_ccn) %>%
  group_by(application,application_name) %>%
  summarise(min_avg_ccn = min(avg_ccn), max_avg_ccn = max(avg_ccn), mean_avg_ccn= mean(avg_ccn))
print(df)

cat('CCN for application groups:', '\n')
df <- benchmark %>%
  distinct(application, application_name, case, avg_ccn) %>%
  mutate(application_name = ifelse(application %in% c('math', 'time', 'chart', 'mockito', 'lang'), 'Defects4J', application_name)) %>%
  group_by(application_name) %>%
  summarise(min_avg_ccn = min(avg_ccn), max_avg_ccn = max(avg_ccn), mean_avg_ccn= mean(avg_ccn))
print(df)

cat('NCSS for applications:', '\n')
df <- benchmark %>%
  distinct(application, application_name, case, application_ncss) %>%
  group_by(application,application_name) %>%
  summarise(min_ncss = min(application_ncss), max_ncss = max(application_ncss), mean_ncss = mean(application_ncss))
print(df)

cat('NCSS for application groups:', '\n')
df <- benchmark %>%
  distinct(application, application_name, case, application_ncss) %>%
  mutate(application_name = ifelse(application %in% c('math', 'time', 'chart', 'mockito', 'lang'), 'Defects4J', application_name)) %>%
  group_by(application_name) %>%
  summarise(min_ncss = min(application_ncss), max_ncss = max(application_ncss), mean_ncss = mean(application_ncss))
print(df)

cat('Total number of frames:')
df <- benchmark %>%
  distinct(application, case, frame_count) %>%
  summarise(total_stack_traces = n(), total_frames=sum(frame_count))
print(df)


#' ---
#' title: "Script 4 of pipeline: differential abundance anaysis"
#' author: "Francesco Vitali"
#' output: html_document
#' ---

#' ```{r setup library load, include=FALSE}

library(phyloseq)
library(tidyverse)
library(data.table)
library(ggsci)
library(ggpubr)
library(Maaslin2)
library(microbiome)
library(genefu)
library(metagenomeSeq)

# red in workspace from script 1

load ("./WP3WP4_workspace")

palette_custom <- c("#1F78B4", "#E31A1C", "#FF7F00", "#33A02C")

#' knitr::opts_chunk$set(fig.width=unit(15,"cm"), fig.height=unit(11,"cm"))

#' ```

#' ```

#' *BACTERIA*

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

#' **WP3 BACTERIA**

#############
#' ```{r betadiv bact WP3, include=TRUE, echo = FALSE}

# how to transform data for beta diversity analysis?

# calculate the variation in read obtained per sample
sdt = data.table(as(sample_data(WP3_initial_bact), "data.frame"),
                 TotalReads = sample_sums(WP3_initial_bact), keep.rownames = TRUE)
summary(sdt$TotalReads)
max(sdt$TotalReads)/min(sdt$TotalReads)
# variation in read depth is 7X

# plot reads to find outliers

sdt %>%
  filter(AnimalID != "E149-40") %>%
  ggboxplot(.,y = "TotalReads")

sdt %>%
  filter(AnimalID != "E149-40") %>%
  summary()

# generate a 10% prevalece filter dataset (see https://www.nature.com/articles/s41467-022-28034-z)
# calculate prevalence for each ASV
WP3.bact.ASVprev <- prevalence(subset_samples(WP3_initial_bact, AnimalID != "E149-40"), detection=0, sort=TRUE, count=F)
summary(names(WP3.bact.ASVprev[WP3.bact.ASVprev > 0.1]))
summary(names(WP3.bact.ASVprev[WP3.bact.ASVprev < 0.1]))
# create an object with only the ASV in more than 10% of samples
WP3_initial_bact_prevalence <- prune_taxa(names(WP3.bact.ASVprev[WP3.bact.ASVprev > 0.1]), subset_samples(WP3_initial_bact, AnimalID != "E149-40"))
#check
min(prevalence(WP3_initial_bact_prevalence, detection=0, sort=TRUE, count=F))

# NORMALIZATION: CSS

# CSS scaling (not removing singletons) on the full dataset
data.metagenomeSeq = phyloseq_to_metagenomeSeq(subset_samples(WP3_initial_bact_prevalence, AnimalID != "E149-40"))
p = cumNormStat(data.metagenomeSeq) #default is 0.5
data.cumnorm = cumNorm(data.metagenomeSeq, p=p)
#data.cumnorm
data.CSS = MRcounts(data.cumnorm, norm=TRUE, log=TRUE)
WP3_CSS_bact <- subset_samples(WP3_initial_bact_prevalence, AnimalID != "E149-40")
otu_table(WP3_CSS_bact) <- otu_table(data.CSS, taxa_are_rows = T)

# NORMALIZATION: TSS

WP3_TSS_bact <- transform(WP3_initial_bact_prevalence, "compositional")

# NORMALIZATION: rarefaction
WP3_raref_bact<- rarefy_even_depth(subset_samples(WP3_initial_bact_prevalence, AnimalID != "E149-40"),
                                   rngseed=1234,
                                   sample.size=round(0.99*min(sample_sums(subset_samples(WP3_initial_bact_prevalence, AnimalID != "E149-40")))),
                                   replace=F)

WP3_raref_TSS_bact <- transform(WP3_raref_bact, "compositional")

# RUN MAASLIN2 WITH CSS

# build input data: df with ASV
df_input_data <- as.data.frame(otu_table(tax_glom(WP3_CSS_bact, taxrank = "Genus")))
# build input data: change row.names from OTU to phylum_genus
tax_input_data <- as.data.frame(tax_table(tax_glom(WP3_CSS_bact, taxrank = "Genus")))
tax_input_data$label <- paste(tax_input_data$Phylum, tax_input_data$Genus, sep = ".")
# remove spaces
tax_input_data$label <- gsub(" ", replacement = ".", x = tax_input_data$label)
# solve duplicates
duplicated <- genefu::rename.duplicate(x=tax_input_data$label, verbose=TRUE)
tax_input_data$label <- duplicated$new.x
# check
row.names(tax_input_data) == row.names(df_input_data)
# rename
row.names(df_input_data) <- tax_input_data$label
#transpose
df_input_data <- t(df_input_data)

# build input metadata:

df_input_metadata <- as(sample_data(WP3_CSS_bact), "data.frame")

# build new variable pasting the diet and time variables, to use and test for interaction between the two;
# maaslin has no proper interaction term like there would be for example in a ANOVA

df_input_metadata$TimeDiet <- paste(df_input_metadata$Time, df_input_metadata$Diet, sep = "_")

# run maaslin on all data, this allows to not loose statistical power

fit_data_WP3_bact <- Maaslin2(
  input_data = df_input_data,
  input_metadata = df_input_metadata,
  output = "fit_data_WP3_bact_CSS_LM",
  fixed_effects = c("Time", "Diet", "TimeDiet"),
  random_effects = c("AnimalID", "end_body_weight"),
  reference = "Diet,CTR;Time,T0;TimeDiet,T0_CTR",
  normalization = "NONE",
  transform = "NONE",
  analysis_method = "LM",
  cores = 7)

# Select only T3 then run with numerical vars

df_input_metadata %>%
  filter(Time == "T3") -> df_input_metadata_T3

df_input_data[row.names(df_input_data) %in% row.names(df_input_metadata_T3),] -> df_input_data_T3

fit_data_WP3_bact <- Maaslin2(
  input_data = df_input_data_T3,
  input_metadata = df_input_metadata_T3,
  output = "fit_data_WP3_bact_CSS_LM_colonTum",
  fixed_effects = c("Colon_tumor"),
  normalization = "NONE",
  transform = "NONE",
  analysis_method = "LM",
  cores = 7)

fit_data_WP3_bact <- Maaslin2(
  input_data = df_input_data_T3,
  input_metadata = df_input_metadata_T3,
  output = "fit_data_WP3_bact_CSS_CPLM_colonTum",
  fixed_effects = c("Colon_tumor"),
  normalization = "NONE",
  transform = "NONE",
  analysis_method = "CPLM",
  cores = 7)

# fit_data_WP3_bact <- Maaslin2(
#   input_data = df_input_data,
#   input_metadata = df_input_metadata,
#   output = "fit_data_WP3_bact_CSS_ZINB",
#   fixed_effects = c("Time", "Diet", "TimeDiet"),
#   random_effects = c("AnimalID", "end_body_weight"),
#   reference = "Diet,CTR;Time,T0;TimeDiet,T0_CTR",
#   normalization = "NONE",
#   transform = "NONE",
#   analysis_method = "ZINB",
#   cores = 7)
#
# fit_data_WP3_bact <- Maaslin2(
#   input_data = df_input_data,
#   input_metadata = df_input_metadata,
#   output = "fit_data_WP3_bact_CSS_NEGBIN",
#   fixed_effects = c("Time", "Diet", "TimeDiet"),
#   random_effects = c("AnimalID", "end_body_weight"),
#   reference = "Diet,CTR;Time,T0;TimeDiet,T0_CTR",
#   normalization = "NONE",
#   transform = "NONE",
#   analysis_method = "NEGBIN",
#   cores = 7)

# RUN MAASLIN2 WITH TSS

# build input data: df with ASV
df_input_data <- as.data.frame(otu_table(tax_glom(WP3_TSS_bact, taxrank = "Genus")))
# build input data: change row.names from OTU to phylum_genus
tax_input_data <- as.data.frame(tax_table(tax_glom(WP3_TSS_bact, taxrank = "Genus")))
tax_input_data$label <- paste(tax_input_data$Phylum, tax_input_data$Genus, sep = ".")
# remove spaces
tax_input_data$label <- gsub(" ", replacement = ".", x = tax_input_data$label)
# solve duplicates
duplicated <- genefu::rename.duplicate(x=tax_input_data$label, verbose=TRUE)
tax_input_data$label <- duplicated$new.x
# check
row.names(tax_input_data) == row.names(df_input_data)
# rename
row.names(df_input_data) <- tax_input_data$label
#transpose
df_input_data <- t(df_input_data)

# build input metadata:

df_input_metadata <- as(sample_data(WP3_TSS_bact), "data.frame")

# build new variable pasting the diet and time variables, to use and test for interaction between the two;
# maaslin has no proper interaction term like there would be for example in a ANOVA

df_input_metadata$TimeDiet <- paste(df_input_metadata$Time, df_input_metadata$Diet, sep = "_")

# run maaslin on all data, this allows to not loose statistical power

fit_data_WP3_bact <- Maaslin2(
  input_data = df_input_data,
  input_metadata = df_input_metadata,
  output = "fit_data_WP3_bact_TSS_LM",
  fixed_effects = c("Time", "Diet", "TimeDiet"),
  random_effects = c("AnimalID", "end_body_weight"),
  reference = "Diet,CTR;Time,T0;TimeDiet,T0_CTR",
  normalization = "NONE",
  transform = "NONE",
  analysis_method = "LM",
  cores = 7)

# Select only T3 then run with numerical vars

df_input_metadata %>%
  filter(Time == "T3") -> df_input_metadata_T3

df_input_data[row.names(df_input_data) %in% row.names(df_input_metadata_T3),] -> df_input_data_T3

fit_data_WP3_bact <- Maaslin2(
  input_data = df_input_data_T3,
  input_metadata = df_input_metadata_T3,
  output = "fit_data_WP3_bact_TSS_LM_colonTum_abb",
  fixed_effects = c("Colon_tumor"),
  normalization = "NONE",
  min_abundance = 0.001,
  transform = "NONE",
  analysis_method = "LM",
  cores = 7)

fit_data_WP3_bact <- Maaslin2(
  input_data = df_input_data_T3,
  input_metadata = df_input_metadata_T3,
  output = "fit_data_WP3_bact_TSS_CPLM_colonTum",
  fixed_effects = c("Colon_tumor"),
  normalization = "NONE",
  transform = "NONE",
  analysis_method = "CPLM",
  cores = 7)

# RUN MAASLIN2 WITH RAREFACTION

# build input data: df with ASV
df_input_data <- as.data.frame(otu_table(tax_glom(WP3_raref_TSS_bact, taxrank = "Genus")))
# build input data: change row.names from OTU to phylum_genus
tax_input_data <- as.data.frame(tax_table(tax_glom(WP3_raref_TSS_bact, taxrank = "Genus")))
tax_input_data$label <- paste(tax_input_data$Phylum, tax_input_data$Genus, sep = ".")
# remove spaces
tax_input_data$label <- gsub(" ", replacement = ".", x = tax_input_data$label)
# solve duplicates
duplicated <- genefu::rename.duplicate(x=tax_input_data$label, verbose=TRUE)
tax_input_data$label <- duplicated$new.x
# check
row.names(tax_input_data) == row.names(df_input_data)
# rename
row.names(df_input_data) <- tax_input_data$label
#transpose
df_input_data <- t(df_input_data)

# build input metadata:

df_input_metadata <- as(sample_data(WP3_raref_TSS_bact), "data.frame")

# build new variable pasting the diet and time variables, to use and test for interaction between the two;
# maaslin has no proper interaction term like there would be for example in a ANOVA

df_input_metadata$TimeDiet <- paste(df_input_metadata$Time, df_input_metadata$Diet, sep = "_")

# run maaslin on all data, this allows to not loose statistical power

fit_data_WP3_bact <- Maaslin2(
  input_data = df_input_data,
  input_metadata = df_input_metadata,
  output = "fit_data_WP3_bact_raref_LM",
  fixed_effects = c("Time", "Diet", "TimeDiet"),
  random_effects = c("AnimalID", "end_body_weight"),
  reference = "Diet,CTR;Time,T0;TimeDiet,T0_CTR",
  normalization = "NONE",
  transform = "NONE",
  analysis_method = "LM",
  cores = 7)

#
#
# # analysis have to be done inside each diet, as binary variable is better dealt with.
#
# # MBD
#
# df_input_metadata %>%
#   filter(Diet == "MBD") -> df_input_metadata_MBD
#
# df_input_data[row.names(df_input_data) %in% row.names(df_input_metadata_MBD),] -> df_input_data_MBD
#
# fit_data_WP3_bact <- Maaslin2(
#   input_data = df_input_data_MBD,
#   input_metadata = df_input_metadata_MBD,
#   output = "fit_data_WP3_bact_MBD",
#   fixed_effects = c("Time"),
#   random_effects = c("AnimalID"),
#   normalization = "TSS",
#   transform = "LOG",
#   analysis_method = "LM",
#   cores = 7)
#
#
# #

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

#' **WP4 BACTERIA**

###########

#' ```{r betadiv bact WP4, include=TRUE, echo = FALSE}

# Optimization of transformation and of methods was performed only for WP3, here take the same

# calculate the variation in read obtained per sample
sdt = data.table(as(sample_data(WP4_initial_bact), "data.frame"),
                 TotalReads = sample_sums(WP4_initial_bact), keep.rownames = TRUE)
summary(sdt$TotalReads)
max(sdt$TotalReads)/min(sdt$TotalReads)

# plot reads to find outliers

sdt %>%
  filter(AnimalID != "WP4-928") %>%
  ggboxplot(.,y = "TotalReads")

sdt %>%
  filter(AnimalID != "WP4-928") %>%
  summary()

# generate a 10% prevalece filter dataset (see https://www.nature.com/articles/s41467-022-28034-z)

# calculate prevalence for each ASV
WP4.bact.ASVprev <- prevalence(subset_samples(WP4_initial_bact, AnimalID != "WP4-928"), detection=0, sort=TRUE, count=F)
summary(names(WP4.bact.ASVprev[WP4.bact.ASVprev > 0.1]))
summary(names(WP4.bact.ASVprev[WP4.bact.ASVprev < 0.1]))
# create an object with only the ASV in more than 10% of samples
WP4_initial_bact_prevalence <- prune_taxa(names(WP4.bact.ASVprev[WP4.bact.ASVprev > 0.1]), subset_samples(WP4_initial_bact, AnimalID != "WP4-928"))
#check
min(prevalence(WP4_initial_bact_prevalence, detection=0, sort=TRUE, count=F))

# CSS scaling (not removing singletons) on the prevalence dataset
data.metagenomeSeq = phyloseq_to_metagenomeSeq(subset_samples(WP4_initial_bact_prevalence, AnimalID != "WP4-928"))
p = cumNormStat(data.metagenomeSeq) #default is 0.5
data.cumnorm = cumNorm(data.metagenomeSeq, p=p)
#data.cumnorm
data.CSS = MRcounts(data.cumnorm, norm=TRUE, log=TRUE)
WP4_CSS_bact.prevalence <- subset_samples(WP4_initial_bact_prevalence, AnimalID != "WP4-928")
otu_table(WP4_CSS_bact.prevalence) <- otu_table(data.CSS, taxa_are_rows = T)

# Perform ordination now
# PCOA

WP4_bact_ord <- ordinate(WP4_CSS_bact.prevalence, "PCoA", distance = "bray")
p.WP4_bact_ord <- plot_ordination(physeq = WP4_CSS_bact.prevalence, WP4_bact_ord, axes = c(1,2))
p.WP4_bact_ord <- p.WP4_bact_ord + geom_point(size = 3, stroke = 0.8, aes(fill = Inoculum_diet, shape = Time))
p.WP4_bact_ord <- p.WP4_bact_ord +
  theme_bw() +
  theme( panel.grid.major =  element_blank(),
         panel.grid.minor =  element_blank()) +
  scale_fill_manual(values = palette_custom) +
  scale_shape_manual(values = c(24,21,22,23))+
  xlab("PCoA1 (24%)") +
  ylab("PCoA2 (14.5%)") +
  labs(fill = "Diet", shape = "Time") +
  theme(legend.position="right") +
  guides(fill = guide_legend(override.aes = list(shape = 23))) -> p.WP4_bact_ord_1

## Plot with WP3
figure2 <- p.WP3_bact_ord_final / p.WP4_bact_ord + plot_layout(guides = "collect") & theme(legend.position = 'left')

#ggsave('./Figure 2.png', figure2)

# pairwise adonis
df <- as(sample_data(subset_samples(WP4_CSS_bact.prevalence, Time == "T3" & Type != "Inoculum")), "data.frame")
d.bacteria = phyloseq::distance(subset_samples(WP4_CSS_bact.prevalence, Time == "T3"  & Type != "Inoculum"), "bray")
set.seed(12387)
pw_ad_bactWP4 <- pairwise.adonis(d.bacteria, factors = df$Diets, p.adjust.m = "BH", perm = 999)

mat1 <- data.frame(matrix(nrow=4,ncol=4,byrow=TRUE))

mat1[1,1] <- 0
mat1[1,2] <- pw_ad_bactT3$R2[1]
mat1[1,3] <-pw_ad_bactT3$R2[2]
mat1[1,4] <-pw_ad_bactT3$R2[4]
mat1[2,1] <- pw_ad_bactT3$R2[1]
mat1[2,2] <- 0
mat1[2,3] <-pw_ad_bactT3$R2[4]
mat1[2,4] <-pw_ad_bactT3$R2[5]
mat1[3,1] <-pw_ad_bactT3$R2[2]
mat1[3,2] <- pw_ad_bactT3$R2[4]
mat1[3,3] <- 0
mat1[3,4] <-pw_ad_bactT3$R2[6]
mat1[4,1] <- pw_ad_bactT3$R2[3]
mat1[4,2] <- pw_ad_bactT3$R2[5]
mat1[4,3] <-pw_ad_bactT3$R2[6]
mat1[4,4] <- 0

colnames(mat1) <- c("MBDT", "PVD", "MBD", "CTR")
row.names(mat1) <- c("MBDT", "PVD", "MBD", "CTR")

corrplot(as.matrix(mat1), type = "lower", diag = F, method = 'number', col = "black")

###########

#' **WP3 WP4 BACTERIA**

###########

# here analysis of WP3 at T3 and WP4 all timepoint, to highlight the "passage" in the FTM
# optionally, one could select only the ID that actually were used for the pool

WP3WP4_initial_bact <- subset_samples(phyloseq_obj_initial_bact,
                                      AnimalID != "E149-40" &  AnimalID != "WP4-928") %>% prune_taxa(taxa_sums(.) > 0, .)

# select sample subset of interest (i.e. only T3 of WP3)

WP3WP4_initial_bact <- subset_samples(WP3WP4_initial_bact, WP != "WP3" | Time != "T0")

# obtain rarefied object for alpha diversity

WP3WP4_raref_bact<- rarefy_even_depth(WP3WP4_initial_bact,
                                   rngseed=1234,
                                   sample.size=round(0.99*min(sample_sums(WP3WP4_initial_bact))),
                                   replace=F)

# calculate the variation in read obtained per sample
sdt = data.table(as(sample_data(WP3WP4_initial_bact), "data.frame"),
                 TotalReads = sample_sums(WP3WP4_initial_bact), keep.rownames = TRUE)
summary(sdt$TotalReads)
max(sdt$TotalReads)/min(sdt$TotalReads)

# plot reads to find outliers

sdt %>%
  ggboxplot(.,y = "TotalReads")

sdt %>%
  summary()

# generate a 10% prevalece filter dataset (see https://www.nature.com/articles/s41467-022-28034-z)

# calculate prevalence for each ASV
WP34.bact.ASVprev <- prevalence(WP3WP4_initial_bact, detection=0, sort=TRUE, count=F)
summary(names(WP34.bact.ASVprev[WP34.bact.ASVprev > 0.1]))
summary(names(WP34.bact.ASVprev[WP34.bact.ASVprev < 0.1]))
# create an object with only the ASV in more than 10% of samples
WP34_initial_bact_prevalence <- prune_taxa(names(WP34.bact.ASVprev[WP34.bact.ASVprev > 0.1]), WP3WP4_initial_bact)
#check
min(prevalence(WP34_initial_bact_prevalence, detection=0, sort=TRUE, count=F))

# CSS scaling (not removing singletons) on the prevalence dataset
data.metagenomeSeq = phyloseq_to_metagenomeSeq(WP34_initial_bact_prevalence)
p = cumNormStat(data.metagenomeSeq) #default is 0.5
data.cumnorm = cumNorm(data.metagenomeSeq, p=p)
#data.cumnorm
data.CSS = MRcounts(data.cumnorm, norm=TRUE, log=TRUE)
WP34_CSS_bact.prevalence <- WP34_initial_bact_prevalence
otu_table(WP34_CSS_bact.prevalence) <- otu_table(data.CSS, taxa_are_rows = T)

sample_data(WP34_CSS_bact.prevalence)$Time

WP34_bact_ord <- ordinate(WP34_CSS_bact.prevalence, "PCoA", distance = "bray")
p.WP34_bact_ord <- plot_ordination(physeq = WP34_CSS_bact.prevalence, WP34_bact_ord, axes = c(1,2))
p.WP34_bact_ord <- p.WP34_bact_ord +
  geom_point(size = 3, stroke = 0.8, aes(fill = Diets, shape = Time))+
  #geom_line(aes(group = AnimalID)) +
  geom_vline(xintercept= 0, linetype="dotted") +
  geom_hline(yintercept= 0, linetype="dotted") +
  theme_bw() +
  theme( panel.grid.major =  element_blank(),
         panel.grid.minor =  element_blank()) +
  scale_fill_manual(values = palette_custom) +
  scale_shape_manual(values = c(24,21,22,25))+
  xlab("PCoA1 (24.1%)") +
  ylab("PCoA2 (11.9%)") +
  labs(fill = "Diet", shape = "Time") +
  theme(legend.position="right") +
  guides(fill = guide_legend(override.aes = list(shape = 23))) +
  theme(legend.position="none")

p.WP34_bact_ord

# Calculate alpha-div
# richness
alphadiv_WP34_bact <- microbiome::richness(WP3WP4_raref_bact)
df <- as(sample_data(WP3WP4_raref_bact), "data.frame")
df <- cbind(df, alphadiv_WP34_bact)

row.names(alphadiv_WP34_bact$vectors) == row.names(df)

df <- cbind(df, WP34_bact_ord$vectors[,1:2])

ggscatter(data = df, x = "Axis.1", y = "observed", add = "reg.line", add.params = list(linetype = "dotted")) +
  stat_cor(method = "pearson") +
  xlab("PCoA1") +
  ylab("Richness (n° of observed ASVs)")

ggscatter(data = df, x = "Axis.2", y = "observed", add = "reg.line", add.params = list(linetype = "dotted")) +
  stat_cor(method = "pearson") +
  xlab("PCoA2") +
  ylab("Richness (n° of observed ASVs)")

ggboxplot(data = df, x = "WP", y = "observed", add = "jitter",
          fill = "WP", palette ="grey", rotate = F, dot.size = 4) + theme_bw() +
  stat_compare_means(label.y = 100) +
  #ggtitle(label = "Bacteria", subtitle =  "Richness (n° of ASVs)") +
  xlab("") +
  ylab("Richness (n° of observed ASVs)") +
  coord_flip() +
  theme(legend.position="none") -> sottoplot_b_ord

# evenness
alphadiv_WP34_bact <- microbiome::evenness(WP3WP4_raref_bact)
df <- as(sample_data(WP3WP4_raref_bact), "data.frame")
df <- cbind(df, alphadiv_WP34_bact)

row.names(alphadiv_WP34_bact$vectors) == row.names(df)

df <- cbind(df, WP34_bact_ord$vectors[,1:2])

ggscatter(data = df, x = "Axis.1", y = "pielou", add = "reg.line", add.params = list(linetype = "dotted")) +
  stat_cor(method = "pearson") +
  xlab("PCoA1") +
  ylab("Richness (n° of observed ASVs)")

ggscatter(data = df, x = "Axis.2", y = "pielou", add = "reg.line", add.params = list(linetype = "dotted")) +
  stat_cor(method = "pearson") +
  xlab("PCoA2") +
  ylab("Richness (n° of observed ASVs)")

ggboxplot(data = df, x = "WP", y = "pielou", add = "jitter",
          fill = "WP", palette ="grey", rotate = F, dot.size = 4) + theme_bw() +
  stat_compare_means(label.y = .3, label.x = 2) +
  #ggtitle(label = "Bacteria", subtitle =  "Richness (n° of ASVs)") +
  xlab("") +
  ylab("Pielou's Evenness") +
  coord_flip() +
  theme(legend.position="none") -> sottoplot_b_ord_eve

## Plot with other single

figure2 <- p.WP34_bact_ord + p.WP3_bact_ord_final/p.WP4_bact_ord + plot_layout(guides = "collect") & theme(legend.position = 'bottom')

#ggsave('./Figure 2.png', figure2)

layout <- "
A
A
A
B
C
"

p.WP34_bact_ord / sottoplot_b_ord / sottoplot_b_ord_eve+
  plot_layout(design = layout) -> panel_ord_bact

#####

#' *FUNGI*

#' **WP3 FUNGI**

#' ```{r betadiv fungi WP3, include=TRUE, echo = FALSE}

#' **WP4 FUNGI**

#' ```{r betadiv fungi WP4, include=TRUE, echo = FALSE}

# how to transform data for alpha diversity analysis?

#########################
#' **WP3 WP4 FUNGI**
######################

# here analysis of WP3 at T3 and WP4 all timepoint, to highlight the "passage" in the FTM
# optionally, one could select only the ID that actually were used for the pool

WP3WP4_initial_fung <- subset_samples(phyloseq_obj_initial_fungi,
                                      AnimalID != "E149-40" &  AnimalID != "WP4-928") %>% prune_taxa(taxa_sums(.) > 0, .)

# select sample subset of interest (i.e. only T3 of WP3)

WP3WP4_initial_fung <- subset_samples(WP3WP4_initial_fung, WP != "WP3" | Time != "T0")

# obtain rarefied object for alpha diversity

WP3WP4_raref_fung<- rarefy_even_depth(WP3WP4_initial_fung,
                                      rngseed=1234,
                                      sample.size=round(0.99*min(sample_sums(WP3WP4_initial_fung))),
                                      replace=F)

# calculate the variation in read obtained per sample
sdt = data.table(as(sample_data(WP3WP4_initial_fung), "data.frame"),
                 TotalReads = sample_sums(WP3WP4_initial_fung), keep.rownames = TRUE)
summary(sdt$TotalReads)
max(sdt$TotalReads)/min(sdt$TotalReads)

# plot reads to find outliers

sdt %>%
  ggboxplot(.,y = "TotalReads")

sdt %>%
  summary()

# generate a 10% prevalece filter dataset (see https://www.nature.com/articles/s41467-022-28034-z)

# calculate prevalence for each ASV
WP34.fung.ASVprev <- prevalence(WP3WP4_initial_fung, detection=0, sort=TRUE, count=F)
summary(names(WP34.fung.ASVprev[WP34.fung.ASVprev > 0.01]))
summary(names(WP34.fung.ASVprev[WP34.fung.ASVprev < 0.01]))
# create an object with only the ASV in more than 10% of samples
WP34_initial_fung_prevalence <- prune_taxa(names(WP34.fung.ASVprev[WP34.fung.ASVprev > 0.1]), WP3WP4_initial_fung)
#check
min(prevalence(WP34_initial_fung_prevalence, detection=0, sort=TRUE, count=F))

# CSS scaling (not removing singletons) on the prevalence dataset
data.metagenomeSeq = phyloseq_to_metagenomeSeq(WP34_initial_fung_prevalence)
p = cumNormStat(data.metagenomeSeq) #default is 0.5
data.cumnorm = cumNorm(data.metagenomeSeq, p=p)
#data.cumnorm
data.CSS = MRcounts(data.cumnorm, norm=TRUE, log=TRUE)
WP34_CSS_fung.prevalence <- WP34_initial_fung_prevalence
otu_table(WP34_CSS_fung.prevalence) <- otu_table(data.CSS, taxa_are_rows = T)

sample_data(WP34_CSS_fung.prevalence)$Time

# Ordination and plot

WP34_fung_ord <- ordinate(WP34_CSS_fung.prevalence, "PCoA", distance = "bray")
p.WP34_fung_ord <- plot_ordination(physeq = WP34_CSS_fung.prevalence, WP34_fung_ord, axes = c(1,2))
p.WP34_fung_ord <- p.WP34_fung_ord +
  geom_point(size = 3, stroke = 0.8, aes(fill = Diets, shape = Time))+
  #geom_line(aes(group = AnimalID)) +
  geom_vline(xintercept= 0, linetype="dotted") +
  geom_hline(yintercept= 0, linetype="dotted") +
  theme_bw() +
  theme( panel.grid.major =  element_blank(),
         panel.grid.minor =  element_blank()) +
  scale_fill_manual(values = palette_custom) +
  scale_shape_manual(values = c(24,21,22,25))+
  xlab("PCoA1 (40.9%)") +
  ylab("PCoA2 (5.4%)") +
  labs(fill = "Diet", shape = "Time") +
  theme(legend.position="right") +
  guides(fill = guide_legend(override.aes = list(shape = 23))) +
  theme(legend.position="none")

p.WP34_fung_ord

# Calculate alpha-div
alphadiv_WP34_fung <- microbiome::richness(WP3WP4_raref_fung)
df <- as(sample_data(WP3WP4_raref_fung), "data.frame")
df <- cbind(df, alphadiv_WP34_fung)

row.names(WP34_fung_ord$vectors) == row.names(df)

df <- cbind(df, WP34_fung_ord$vectors[,1:2])

ggscatter(data = df, x = "Axis.1", y = "observed", add = "reg.line", add.params = list(linetype = "dotted")) +
  stat_cor(method = "pearson") +
  xlab("PCoA1") +
  ylab("Richness (n° of observed ASVs)")

ggscatter(data = df, x = "Axis.2", y = "observed", add = "reg.line", add.params = list(linetype = "dotted")) +
  stat_cor(method = "pearson") +
  xlab("PCoA2") +
  ylab("Richness (n° of observed ASVs)")

ggboxplot(data = df, x = "WP", y = "observed", add = "jitter",
          fill = "WP", palette ="grey", rotate = F, dot.size = 4) + theme_bw() +
  stat_compare_means(label.y = 90) +
  #ggtitle(label = "Fungi", subtitle =  "Richness (n° of ASVs)") +
  xlab("") +
  ylab("Richness (n° of observed ASVs)") +
  coord_flip() +
  theme(legend.position="none") -> sottoplot_f_ord

# evenness
alphadiv_WP34_fung <- microbiome::evenness(WP3WP4_raref_fung)
df <- as(sample_data(WP3WP4_raref_fung), "data.frame")
df <- cbind(df, alphadiv_WP34_fung)

row.names(alphadiv_WP34_fung$vectors) == row.names(df)

df <- cbind(df, WP34_fung_ord$vectors[,1:2])

ggscatter(data = df, x = "Axis.1", y = "pielou", add = "reg.line", add.params = list(linetype = "dotted")) +
  stat_cor(method = "pearson") +
  xlab("PCoA1") +
  ylab("Pielou's Evenness")

ggscatter(data = df, x = "Axis.2", y = "pielou", add = "reg.line", add.params = list(linetype = "dotted")) +
  stat_cor(method = "pearson") +
  xlab("PCoA2") +
  ylab("Pielou's Evenness")

ggboxplot(data = df, x = "WP", y = "pielou", add = "jitter",
          fill = "WP", palette ="grey", rotate = F, dot.size = 4) + theme_bw() +
  stat_compare_means(label.y = .2, label.x = 2) +
  #ggtitle(label = "Bacteria", subtitle =  "Richness (n° of ASVs)") +
  xlab("") +
  ylab("Pielou's Evenness") +
  coord_flip() +
  theme(legend.position="none") -> sottoplot_f_ord_eve

layout <- "
A
A
A
B
C
"

p.WP34_fung_ord / sottoplot_f_ord / sottoplot_f_ord_eve+
  plot_layout(design = layout) -> panel_ord_fung

ggarrange(panel_ord_bact, panel_ord_fung,
          labels = c("A", "B"),
          ncol = 2) -> figure2

ggsave('./Figure 2.png', figure2)

#' ```

#' ```{r write images, include=FALSE}
#' knitr::opts_chunk$set(echo = TRUE)

# use ggsave for images

#' ```


'

The file "figure1_mortality.r" creates two figures, plotting
expropriation risk and log GDP against settler mortality respectively.
It accounts for campaign/laborer indicators and distinguishes between
countries with original data and countries with conjectured mortality data.

'

rm(list=ls())

source("project_paths.r")

library(foreign)

data <- read.table(paste(PATH_OUT_DATA, "ajrcomment_all.txt", sep = "/"))

## Rebuilding of Figures 2A and 2B

datacamp <- data[grep(1,data$campaign),] #mortality from campaign

data2 <- data[grep(0,data$campaign),]

databar <- data2[grep(0,data2$slave),] #mortality from barrack
datalab <- data2[grep(1,data2$slave),] #mortality from laborer

## Plot that data first against risk
datacamphome <- datacamp[grep(1,datacamp$source0),]
datacampcon <- datacamp[grep(0,datacamp$source0),]

databarhome <- databar[grep(1,databar$source0),]
databarcon <- databar[grep(0,databar$source0),]

datalabhome <- datalab[grep(1,datalab$source0),]
datalabcon <- datalab[grep(0,datalab$source0),]

png(filename=paste(PATH_OUT_FIGURES, "risk_mort.png", sep="/"))
plot(
     datacamphome$logmort0, datacamphome$risk, pch=15,
     xlab="Logarithm of settler mortality", ylab="Expropriation risk",
     ylim=c(3,10), xlim=c(2,8), bty="L"
)
lines(datacampcon$logmort0, datacampcon$risk, pch=22, type="p")

lines(databarhome$logmort0, databarhome$risk, pch=16, type="p")
lines(databarcon$logmort0, databarcon$risk, pch=21, type="p")

lines(datalabhome$logmort0, datalabhome$risk, pch=17, type="p")
lines(datalabcon$logmort0, datalabcon$risk, pch=2, type="p")

dev.off()

plot.new()
png(filename=paste(PATH_OUT_FIGURES, "gdp_mort.png", sep="/"))
## Plot that data against loggdp
plot(
     datacamphome$logmort0, datacamphome$loggdp, pch=15,
     xlab="Logarithm of settler mortality", ylab="Logarithm of GDP per capita",
     ylim=c(6,10.5), xlim=c(2,8), bty="L"
)
lines(datacampcon$logmort0, datacampcon$loggdp, pch=22, type="p")

lines(databarhome$logmort0, databarhome$loggdp, pch=16, type="p")
lines(databarcon$logmort0, databarcon$loggdp, pch=21, type="p")

lines(datalabhome$logmort0, datalabhome$loggdp, pch=17, type="p")
lines(datalabcon$logmort0, datalabcon$loggdp, pch=2, type="p")

# coordinates of legend box using plot units

dev.off()


# Title     : Communication {r}Evolution
# Created by: Zoriana Yuzvin and Viktoria Lavrynenko
library(tidyverse)
library(ggplot2)
library(lubridate)
library(scales)

csv <- read.csv("./66f923f3-06c6-4f16-b8dd-32c4539ad8cc_Data.csv")
internet_users <- csv %>% filter(!is.na(Percent)) %>% group_by(Time) %>% summarise(avg = mean(Percent))
print(internet_users)

ggplot(internet_users, aes(Time, avg))


library(tidyverse)
library(ggrepel)
library(hrbrthemes)
library(gcookbook)
library(Cairo)

# Load Data
#url("https://github.com/tomsaunders98/CovidTests/raw/master/Testnumbers.csv")
testnumbers <- read_csv("Testnumbers.csv")

# Universal Wrangling
for(i in 1:nrow(testnumbers)){
  val = toString(testnumbers$DataType[i])
  if (val == "People"){
    temp = "Number of People Tested"
  }
  if (val == "Unclear"){
    temp = "Measurement Not Specified"
  }
  if (val == "Samples"){
    temp = "Number of Laboratory Samples Analysed"
  }
  if (val == "Cases"){
    temp = "Number of Cases Tested"
  }
  testnumbers$DataType[i] = temp
}

####################################
## Tests Per Thousand (Bar Graph) ##
####################################

# Bar Chart Per Cap Wrangling
Barpercap <- testnumbers
Barpercap$datemax <- colnames(Barpercap[7:ncol(Barpercap)])[apply(Barpercap[7:ncol(Barpercap)],1,which.max)]
Barpercap$max <- apply(Barpercap[7:(ncol(Barpercap)-1)], 1, max,na.rm=TRUE)

testnumbersBar <- Barpercap %>%
  mutate(
    TestsPerCap = as.double(max)/as.double(Population),
    TestsPerMil = (as.double(max)/as.double(Population))*1000
  ) %>%
  arrange(desc(max)) %>%
  filter(Country != "ICE") # Just puts everything way out of proportion

# Aesthetics
maxnum = max(testnumbersBar$TestsPerMil, na.rm=TRUE) + 20

plotPM <- ggplot(data = testnumbersBar, aes(x = reorder(CountryNames, TestsPerMil), y = TestsPerMil, fill = DataType)) +
  geom_bar(stat = "identity") +
  geom_text(aes(label=datemax, colour = DataType),  vjust=0.5, hjust=0, show.legend = FALSE)

plotPM +
  scale_y_continuous(limits=c(0,maxnum)) +
  xlab("Countries ")+
  ylab("Tests Per Thousand") +
  ggtitle("COVID-19 Tests Completed Per Thousand") +
  labs(fill = "Data Collected As:") +
  coord_flip() +
  scale_color_ipsum() +
  scale_fill_ipsum() +
  theme_ipsum_rc(grid="X", axis="X")

#####################################
## Tests Per Thousand (Line Graph) ##
#####################################

# Line Graph Data Wrangling
LineperCap <- testnumbers
LineperCap$datemax <- colnames(LineperCap[7:ncol(LineperCap)])[apply(LineperCap[7:ncol(LineperCap)],1,which.max)]
LineperCap[7:(ncol(LineperCap)-1)] <- LineperCap[7:(ncol(LineperCap)-1)]/LineperCap$Population
LineperCap[7:(ncol(LineperCap)-1)] <- LineperCap[7:(ncol(LineperCap)-1)]*1000

num = 10 #Add up to 32 Countries

linedata <- LineperCap %>%
  arrange(desc(Population)) %>%
  head(n=num) %>%
  pivot_longer(7:(ncol(testnumbers)-1), names_to="dates", values_to="Total") %>%
  drop_na(Total) %>%
  mutate(dates = as.Date(dates, "%d/%m/%Y")) %>%
  mutate(datemax = as.Date(datemax, "%d/%m/%Y")) %>%
  mutate(label = if_else(dates == datemax, as.character(CountryNames), NA_character_)) %>%
  arrange(desc(dates))

# Aesthetics
LinePM <- ggplot(data = linedata, aes(x = dates, y = Total, group = CountryNames,color=CountryNames)) +
  geom_point(aes(shape=DataType)) +
  geom_line() +
  geom_label_repel(aes(label = label),
                 nudge_x=1,
                 na.rm = TRUE,
                 nudge_y=0.01,
                 min.segment.length = Inf)

LinePM +
  #scale_y_continuous(limits=c(0,1.2)) +
  xlab("Dates")+
  ylab("Tests Per Million") +
  ggtitle("COVID-19 Tests Completed Per Thousand") +
  labs(shape = "Data Collected As:") +
  guides(color=FALSE) +
  theme_minimal()

##################################
## UK 100,000 target evaluation ##
##################################

# Data Wrangling
countries <- list( "UK")
df0 <- testnumbers[7:(ncol(testnumbers)-11)]
TestingTories <- cbind(testnumbers[1], df0[-length(df0)] - df0[-1])
TestingTories[TestingTories < 0] <- NA

TestingToriesLine <- TestingTories %>%
  filter(Country %in% countries) %>%
  pivot_longer(2:ncol(TestingTories), names_to="dates", values_to="Total") %>%
  drop_na(Total) %>%
  mutate(dates = as.Date(dates, "%d/%m/%Y")) %>%
  arrange(desc(dates))

latestvalue = as.double(TestingToriesLine[1, "Total"])

# Aesthetics
TestTheT <- ggplot(data = TestingToriesLine, aes(x = dates, y = Total, color=Country), cex.lab=1.5, cex.axis=1.5 ) +
  geom_line(col="#003f5c") +
  geom_point(col="#003f5c") +
  scale_y_continuous(limits=c(0,120000)) +
  scale_x_date(limits = as.Date(c("2020-04-07","2020-05-01")))+
  xlab("Dates")+
  ylab("Tests Per Day") +
  guides(color=FALSE) +
  theme_minimal(base_size = 20) +
  theme(legend.position="none") +
  annotate("segment", x = min(TestingToriesLine$dates), y = 100000, xend =as.Date("2020-05-01"), yend = 100000, colour = "#333333", alpha = .8, size=1) +
  annotate("text", x = median(TestingToriesLine$dates), y = 105000, label = "100,000 Tests Per Day", colour = "#333333", size=6) +
  annotate("segment", x = max(TestingToriesLine$dates), linetype = "dashed", y = latestvalue, xend =as.Date("2020-05-01"), yend = 100000, colour = "#bc5090", size=1) +
  annotate("text", x = sort(TestingToriesLine$dates,T)[2], y = (max(TestingToriesLine$Total) + 10000), label = paste("Current Tests: ", latestvalue), colour = "#003f5c", size=5) +
  annotate("rect", xmin = max(TestingToriesLine$dates), xmax = as.Date("2020-05-01"), ymin = 0, ymax = 100000,alpha = .1)


# install these packages
library(tidyverse)
library(reshape2)
library(here)
library(ggthemes)
library(knitr)

source("functions.r") # sourcing all functions

########################################################################
#### Read in data ------------------------------------------------------
########################################################################

# Read in raw NHTS datasets
raw.person2001 <- read.table(here("data", "person2001.csv"),
                             fill=TRUE, header=TRUE, sep=",", na.strings = c(".", seq(-10,-1)))
raw.trip2001 <- read.table(here("data", "trip2001.csv"),
                           fill=TRUE, header=TRUE, sep=",", na.strings = c(".", seq(-10,-1)))
raw.person2009 <- read.table(here("data", "person2009.csv"),
                             fill=TRUE, header=TRUE, sep=",", na.strings = c(".", seq(-10,-1)))
raw.trip2009 <- read.table(here("data", "trip2009.csv"),
                           fill=TRUE, header=TRUE, sep=",", na.strings = c(".", seq(-10,-1)))

# Read in CDC Vital Stats files
list_of_cdc_travel_files <- c("cdc_travel_2001_2010",
                              "cdc_travel_2001_2010_ped",
                              "cdc_travel_2001_2010_pveh")

# 2000 population distribution for age-standardized calculations
pop2000stand <- read.csv(here("pop2000stand.csv"))

########################################################################
#### Clean data and perform preliminary calculations--------------------
########################################################################

# clean all CDC data and bring them into the R environment
cleaned.cdc.travel<-lapply(list_of_cdc_travel_files, make_cdc_travel_df)
names(cleaned.cdc.travel) <- list_of_cdc_travel_files
list2env(cleaned.cdc.travel, .GlobalEnv)

# clean NHTS data
person2001 <- clean_all_nhts(raw.person2001)
trip2001 <- clean_all_nhts(raw.trip2001)
person2009 <- clean_all_nhts(raw.person2009)
trip2009 <- clean_all_nhts(raw.trip2009)

# get national population represented by the data
popgroup2001 <- get_pop_bygroup(person2001)
popgroup2009 <- get_pop_bygroup(person2009)

# calculate risk and exposure for each survey year
exp2001.all <- get_exposure_1year(year_in = 2001)
exp2001.ped <- get_exposure_1year(year_in = 2001, mode_in = "Walk")
exp2001.pveh <- get_exposure_1year(year_in = 2001, mode_in = "Pvehicle")

exp2009.all <- get_exposure_1year(year_in = 2009)
exp2009.ped <- get_exposure_1year(year_in = 2009, mode_in = "Walk")
exp2009.pveh <- get_exposure_1year(year_in = 2009, mode_in = "Pvehicle")

# calculate risk and exposure for 2001-2010 (averaged for the two survey years)
exp.all <- calc_exp_risk_2000(df_2001 = exp2001.all, df_2009 = exp2009.all, df_cdc = cdc_travel_2001_2010)
exp.ped <- calc_exp_risk_2000(df_2001 = exp2001.ped, df_2009 = exp2009.ped, df_cdc = cdc_travel_2001_2010_ped)
exp.pveh <- calc_exp_risk_2000(df_2001 = exp2001.pveh, df_2009 = exp2009.pveh, df_cdc = cdc_travel_2001_2010_pveh)

# calculate decompositions for each type of MV death
decomp.all <- decompose(df_in = exp.all) %>% mutate(type = "Total")
decomp.ped <- decompose(df_in = exp.ped) %>% mutate(type = "Pedestrian")
decomp.pveh <- decompose(df_in = exp.pveh) %>% mutate(type = "Passenger Vehicle")

# combine the previous decompositions into one df
decomp_combined <- rbind(decomp.all, decomp.ped, decomp.pveh)
decomp_combined$type <- as.factor(decomp_combined$type)
decomp_combined$type <- factor(decomp_combined$type,
                               levels = c("Total", "Passenger Vehicle", "Pedestrian"))

# age standardized rates for death, exposure, and risk
age_stand_all <- calculate_as_rates(exp.all)
age_stand_pveh <- calculate_as_rates(exp.pveh)
age_stand_ped <- calculate_as_rates(exp.ped)


args = commandArgs(trailingOnly=TRUE)
# the file with adjacency matrix for all trees on a terrace (IQ-TREE format rf_all)
file=args[1]
file_tsc=args[2]
file_out=args[3]
file_conn_info=args[4]
trivial_terr_NUM=as.numeric(args[5])

f_scripts=args[6]
source(paste(f_scripts,"/script-colors.r",sep=""))
source(paste(f_scripts,"/script-donut-plot.r",sep=""))
source(paste(f_scripts,"/script-plot_one_terrace.r",sep=""))
####################################################################################################
# aux function
###################################################################################################
get_edges_attributes<-function(g,comm,e_col_OUT,e_col_IN,e_width_OUT,e_width_IN,e_lty_OUT,e_lty_IN){
	e=get.edgelist(g)
	E(g)$color=c(rep(e_col_OUT,ecount(g)))
	E(g)$lty=c(rep(e_lty_OUT,ecount(g)))
	E(g)$width=c(rep(e_width_OUT,ecount(g)))

	for(i in 1:nrow(e)){
        	if(V(g)$community[e[i,1]] == V(g)$community[e[i,2]]){
                	E(g)$color[i]=e_col_IN
                	E(g)$width[i]=e_width_IN
                	E(g)$lty[i]=e_lty_IN
        	}
	}
	return(g)
}

#########################################################################################
#actual script
#########################################################################################

#print(file)

d=read.table(paste(file,sep=""),skip=1)
d=d[,-1]
d=as.matrix(d)

#print(d)

# get only 1-NNI neighbours
n=nrow(d)
rfdist=matrix(0,n,n)
for(i in 1:n){
    for(j in 1:n){
        if(d[i,j]==2){
            rfdist[i,j]=1
        }
    }
}
d=rfdist

library(igraph)
g<-graph.adjacency(t(d),mode="undirected")

vNUM=length(V(g))
if(vNUM>105){
	V(g)$size=2
}else{
	V(g)$size=3
}

# get info about tree space configuration
t=read.table(file_tsc)
t=as.matrix(t)

tsc=cluster_label_prop(g)
tsc$membership=t[,1]
V(g)$community=tsc$membership

# compute layout, weighting connections within terrace more

w=10
if(vNUM==15){
	w=3
}
weights <- ifelse(crossing(tsc, g), w, 1)	# 10,1 is best for kk | for fr 1,50
layout <- layout_with_kk(g, weights=weights)
#layout <- layout.reingold.tilford(g, circular=T)
#layout <- layout_with_fr(g, weights=weights)

# With kk easier to see the whole space
# With fr easier to see connections within terrace, but terraces overlap more then with kk. This one is possibly better to use for a subset of terraces.

################################
# colors
################################
library(RColorBrewer)
#royalColors=colorRampPalette(c("yellowgreen","royalblue"),bias=1,interpolate="linear",alpha=.5)

#cols <- brewer.pal(9, "YlGnBu")
#cols=c("red", "green", "blue", "yellow")
cols=brewer.pal(11, 'Spectral')

pal <- colorRampPalette(cols)

# color of vertices
new_cols=pal(max(t))[membership(tsc)]

# color of borders of communities
mark_border_cols=pal(max(t))

# color of communities
pal2=colorRampPaletteAlpha(cols, n = max(t),alpha = 0.4)
mark_cols=pal2

# color of edges
#E(g)$color <- apply(as.data.frame(get.edgelist(g)), 1, function(x) ifelse(V(g)$community[x[1]] == V(g)$community[x[2]],"black","grey"))

##### PLOTs ############################################
wd=20
ht=20

if(vNUM==15){
        V(g)$size=7

}

E(g)$width=1
if(vNUM<=105){
	#if(vNUM==15){
        	V(g)$size=7
		E(g)$width=5
        	E(g)$color="grey"
	#}

	# EDGE attributes
	e_OUT=1
	e_IN=2
	g=get_edges_attributes(g,tsc$membership,"lightgrey","black",e_OUT,e_IN,1,1)

	pdf(paste(file_out,"-1.pdf",sep=""),w=wd,h=ht)
	plot(tsc,g, layout=layout,vertex.label=NA,col=new_cols,mark.col=mark_cols,edge.width=E(g)$width,mark.border=mark_border_cols,edge.color=E(g)$color,edge.lty=E(g)$lty)
	dev.off()

	#------------------------------------------
	e_OUT=1
        e_IN=2
	g=get_edges_attributes(g,tsc$membership,"lightgrey","black",e_OUT,e_IN,3,1)

	pdf(paste(file_out,"-2.pdf",sep=""),w=wd,h=ht)
	plot(tsc,g, layout=layout,vertex.label=NA,col=new_cols,mark.col=mark_cols,edge.width=E(g)$width,mark.border=mark_border_cols,edge.color=E(g)$color,edge.lty=E(g)$lty)
	dev.off()

}
#------------------------------------------
e_OUT=1
e_IN=2
g=get_edges_attributes(g,tsc$membership,NA,"black",e_OUT,e_IN,3,1)

if(vNUM<1000){
	pdf(paste(file_out,"-3.pdf",sep=""),w=wd,h=ht)
	plot(tsc,g, layout=layout,vertex.label=NA,col=new_cols,mark.col=mark_cols,edge.width=E(g)$width,mark.border=mark_border_cols,edge.color=E(g)$color,edge.lty=E(g)$lty)
	dev.off()
}

#######################################################
conn_info=read.table(file_conn_info)
conn_info=as.matrix(conn_info)

terrNUM=nrow(conn_info)

terrMAX=max(conn_info[,2])
conn_terr=which(conn_info[,3]==1)
dis_terr=which(conn_info[,3]==0)
disNUM=length(dis_terr)
connNUM=length(conn_terr)
#------------------------------------------------------
# the above is used for plotting separate terraces
#------------------------------------------------------

#########################################
# Plotting terrace subgraphs
########################################
terrPLOT="TRUE"

if(terrPLOT=="TRUE"){
	terr_to_plot=which(conn_info[,2]>3)
	if(length(terr_to_plot)>0){
		for(terrID in terr_to_plot){
			if(conn_info[terrID,3]!=1 && conn_info[terrID,2]!=5){
			V_list=which(V(g)$community[]==terrID)
			plot_terrace_subgraph(g,V_list,terrNUM,terrID,cols=cols,
				file=paste(file_out,"-terrace_sub-conn_",conn_info[terrID,3],"-N_",conn_info[terrID,2],"-comp_",conn_info[terrID,4],"-ID_",terrID,".pdf",sep=""))
			}
		}
	}
}
########################################
terrEXAMPLE="FALSE"

if(terrEXAMPLE=="TRUE"){

# plot one example with 2 taxa
terr_to_plot=which(conn_info[,2]==2)
if(length(terr_to_plot)>0){
	terrID=terr_to_plot[1]
	V_list=which(V(g)$community[]==terrID)
	plot_terrace_subgraph(g,V_list,terrNUM,terrID,cols=cols,file=paste(file_out,"-terrace_sub-conn_",conn_info[terrID,3],"-N_",conn_info[terrID,2],"-comp_",conn_info[terrID,4],"-ID",terrID,".pdf",sep=""))
}

# plot one example with 3 taxa
terr_to_plot=which(conn_info[,2]==3)
if(length(terr_to_plot)>0){
        terrID=terr_to_plot[1]
        V_list=which(V(g)$community[]==terrID)
        plot_terrace_subgraph(g,V_list,terrNUM,terrID,cols=cols,file=paste(file_out,"-terrace_sub-conn_",conn_info[terrID,3],"-N_",conn_info[terrID,2],"-comp_",conn_info[terrID,4],"-ID",terrID,".pdf",sep=""))
}
}


library("plot3D")
library("ggplot2")
library("GGally")
library("gridExtra")
library("dplyr")

# create table for relative improvement on dataset level (HPO on DL)
create_table_datasets = function(data.list, objective, target, depth){
  # data.list: list with evaluation data for each dataset
  # objective: character string with name of objective e.g. "SS_L2"
  # target:    name of column of evaluation data to be aggregated e.g. "conf.rel"
  # depth:     tree depth

  # output:    table with results aggregated on dataset level

  df = lapply(1:length(data.list), function(i){

    data = data.list[[i]]
    data = data[which(data$objective == objective & data$depth == depth),]
    if(target == "neg_loglik.rel"){
      data$neg_loglik.rel = (data$source.neg_loglik - data$neg_loglik)/abs(data$source.neg_loglik)
    }
    if(target == "gt.diff.sd"){
      data$gt.diff.sd = (data$source.gt.diff.sd - data$gt.diff.sd)/data$source.gt.diff.sd
    }
    data.features = data %>% group_by(feature) %>% summarise(mean = mean(get(target)))
    data.frame("dataset" = names(data.list)[i], "mean" = mean(data[,target]), "sd" = sd(data[,target]),
               "best.feat" = data.features[which.max(data.features$mean), "feature"], "best.mean" = data.features[which.max(data.features$mean), "mean"],
               "worst.feat" = data.features[which.min(data.features$mean), "feature"], "worst.mean" = data.features[which.min(data.features$mean), "mean"])

  })
  return(do.call("rbind", df))
}

# create table for relative improvement on hyperparameter level (HPO on DL)
create_table_features = function(data.list, objective, target, depth){
  # data.list: list with evaluation data for each dataset
  # objective: character string with name of objective e.g. "SS_L2"
  # target:    name of column of evaluation data to be aggregated e.g. "conf.rel"
  # depth:     tree depth

  # output:    table with results aggregated on hyperparameter level

  df = lapply(1:length(data.list), function(i){

    data = data.list[[i]]
    data = data[which(data$objective == objective & data$depth == depth),]
    if(target == "neg_loglik.rel"){
      data$neg_loglik.rel = (data$source.neg_loglik - data$neg_loglik)/abs(data$source.neg_loglik)
    }
    if(target == "neg_loglik"){
      data$neg_loglik = (data$source.neg_loglik - data$neg_loglik)
    }
    if(target == "gt.diff.sd"){
      data$gt.diff.sd = (data$source.gt.diff.sd - data$gt.diff.sd)/data$source.gt.diff.sd
    }
    data.features = data %>% group_by(feature) %>% summarise(mean = median(get(target)))
    data.features$dataset = names(data.list)[i]
    data.features

  })
  df = do.call("rbind", df)
  df %>% group_by(feature) %>% summarise(mean.feat = mean(mean), sd = sd(mean))
}

# determine optimal node of last split of tree
find_optimal_node = function(tree, optimum){
  # tree:     return value of compute_tree function
  # optimum:  named vector with values of best configuration found during training

  # output:   node of final split containing optimum

  node = tree[[1]][[1]]

  max_depth = length(tree)

  while(node$depth < max_depth) {

    split.feature = node$split.feature
    split.value = node$split.value

    if (!is.null(split.value) & !is.null(split.value) & !is.null(optimum[split.feature])) {
      if(optimum[split.feature] <= split.value){
        node = node$children$left.child
      } else {
        node = node$children$right.child
      }
    } else {
      break
    }
  }

  return(node)
}

# extract split criteria of tree for node in final split that contains the optimum
find_split_criteria = function(tree, optimum){
  # tree:     return value of compute_tree function
  # optimum:  named vector with values of best configuration found during training

  # output:   list that contains split features, split values and direction

  node = tree[[1]][[1]]
  id = c()
  features = c()
  values = c()

  for(depth in seq_len(length(tree) - 1)){

    split.feature = node$split.feature
    split.value = node$split.value
    if(optimum[split.feature] <= split.value){
      id = c(id, 1)
    }
    else id = c(id,2)
    node = tree[[depth+1]]
    for(i in id){
      if(i == 1) node = node[1:(0.5*length(node))]
      else node = node[(0.5*length(node)+1):length(node)]

    }
    node = node[[1]]
    features = c(features, split.feature)
    values = c(values, split.value)

  }

  return(list("features" = features, "values" = values, "id" = id))
}

plot_function = function(obj) {
  ps = getParamSet(obj)
  x1 <- seq(from = ps$pars$x$lower[1], to = ps$pars$x$upper[1], length.out = 100)
  x2 <- seq(from = ps$pars$x$lower[2], to = ps$pars$x$upper[2], length.out = 100)
  gg <- expand.grid(x1 = x1, x2 = x2)
  gg$y = apply(gg, 1, obj)

  p = ggplot() + geom_tile(data = gg, aes(x = x1, y = x2, fill = y))
  p = p + scale_fill_distiller(palette = "Spectral")
  p
}

concatenate_runs = function(runs) {
  opdf = lapply(runs, function(x) {
    df = as.data.table(as.data.frame(x$opt.path))
    names(df)[ncol(df)] = "cb.lambda"
    df$type = attr(x, "type")
    return(df)
  }
  )
  do.call(rbind, opdf)
}

get_type_of_run = function(x) {
  type = attr(x, "type")
  lambda = x$control$infill.crit$params$cb.lambda
  if (type == "MBO")
    type = paste(type, lambda, sep = "_")
  return(type)
}

get_types_of_runs = function(runs) {
  types = lapply(runs, get_type_of_run)
  unlist(types)
}

extract_models = function(runs) {
  models = lapply(seq_along(runs), function(i) {
    type = get_type_of_run(runs[[i]])
    models = runs[[i]]$models
    model = models[[length(models)]]
    if (type == "LHS")
      model = models[[1]]
    return(model)
  })
}

extract_performances = function(runs) {
  lapply(seq_along(runs), function(i) {
    performance = runs[[i]]$model.performances
  })
}

predict_on_grid = function(model, grid) {
  pred = predict(model, newdata = grid)$data
  pred$residual = pred$response - grid$y
  pred$abs_error = abs(pred$response - grid$y)
  cbind(grid, pred)
}

concatenate_runs = function(runs) {
  opdf = lapply(runs, function(x) {
    df = as.data.table(as.data.frame(x$opt.path))
    names(df)[ncol(df)] = "cb.lambda"
    df$type = get_type_of_run(x)
    return(df)
  }
  )
  do.call(rbind, opdf)
}