# This code compares the seroprevalence surveys and
# representative survey KOUZh-18 for
# COVID-19 pandemic in Saint Petersburg, Russia
# paper
library(data.table)
library(stringi)
library(stringr)
library(lubridate)
library(Publish)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

# Load Сomprehensive monitoring of living
# conditions 2018 data for Saint Petersburg
load("data/kouzh_2018/kouzh_2018_data_spb.rdata")
kouzh_2018_data_spb[, male := NA_real_]
kouzh_2018_data_spb[sex == 1, male := 1]
kouzh_2018_data_spb[sex == 2, male := 0]

# Keep only adults in KOUZh data
kouzh_2018_data_spb <- kouzh_2018_data_spb[ age >= 18 ]

# Define age groups
kouzh_2018_data_spb[, agegroup := NA_character_]
kouzh_2018_data_spb[age < 35, agegroup := "18-34"]
kouzh_2018_data_spb[age >= 35 & age < 50, agegroup := "35-49"]
kouzh_2018_data_spb[age >= 50 & age < 65, agegroup := "50-64"]
kouzh_2018_data_spb[age >= 65, agegroup := "65+"]
kouzh_2018_data_spb[, agegroup := as.factor(agegroup)]

# Make education levels conformable
kouzh_2018_data_spb[ education_level %in% c("Primary education", "Complete secondary education"), education_level := "Primary / secondary education" ]
kouzh_2018_data_spb[, education_level := droplevels(education_level)]

# Lives alone variable
kouzh_2018_data_spb[, lives_alone := 0]
kouzh_2018_data_spb[household_size == 1, lives_alone := 1]

# Load the prepared per-wave survey data
waves <- c(1, 2)

# Init an object to store the seroprevalence data
serosurvey_data_bywave_list <- list()

# Load the per-wave data and store them in one object
for(w in waves) {

	source(paste0("code/analysis/wave", w , "/create_serosurvey_data_for_model_fit.r"))

	# Make variables conformable across the waves
	if( w %in% c(1, 1.5) ) {

		serosurvey_data[, education_level := factor(education_level, ordered = F)]
		serosurvey_data[ education_level %in% c("Complete secondary education", "Primary education"), education_level := "Primary / secondary education"]
		serosurvey_data[, education_level := droplevels(education_level)]

	}

	setnames(serosurvey_data, "offered_taxi", "encouragement", skip_absent = T)
	setnames(serosurvey_data, "lenta_card", "encouragement", skip_absent = T)
	serosurvey_data[ , wave := NULL ]

	serosurvey_data_bywave_list[[ as.character(w) ]] <- serosurvey_data

	rm(serosurvey_data)

}

# Aggregate the results
serosurvey_data_bywave <- rbindlist(serosurvey_data_bywave_list, idcol = "wave", fill = T)
serosurvey_data_bywave[, wave := as.numeric(wave)]

# Load paper survey data from wave 1 to get data on smoking
load("data/wave1/paper_survey/paper_survey_data_matched_to_phone_survey_ids.rdata")
serosurvey_data_bywave <- merge(serosurvey_data_bywave, unique(paper_survey_data_matched_to_phone_survey_ids[, c("ID", "smoking_now")]), by = "ID", all.x = T, all.y = F)
serosurvey_data_bywave[ is.na(smoking) & !is.na(smoking_now) & wave %in% c(1, 1.5, 3), smoking := smoking_now ]
serosurvey_data_bywave[, smoking_now := NULL]

# Assume that all surveyed by phone have a cell phone
serosurvey_data_bywave[, has_cellphone := 1]

# Smoking now variable
setnames(kouzh_2018_data_spb, "smoking_now", "smoking")

# We need to expand factors by their levels
# NB: this results in a complete-case comparison
called_wave1 <- model.matrix(~ male + age + agegroup + education_level + work_status + health_level + lives_alone + has_cellphone - 1, data = serosurvey_data_bywave[wave == 1], contrasts.arg = lapply(serosurvey_data_bywave[ wave == 1, sapply(serosurvey_data_bywave, is.factor), with = F], contrasts, contrasts = F))

smoking_wave1 <- model.matrix(~ smoking - 1, data = serosurvey_data_bywave[wave == 1], contrasts.arg = lapply(serosurvey_data_bywave[ wave == 1, sapply(serosurvey_data_bywave, is.factor), with = F], contrasts, contrasts = F))

called_wave2 <- model.matrix(~ male + age + agegroup + education_level + work_status + smoking + health_level + lives_alone + has_cellphone - 1, data = serosurvey_data_bywave[wave == 2], contrasts.arg = lapply(serosurvey_data_bywave[ wave == 2, sapply(serosurvey_data_bywave, is.factor), with = F], contrasts, contrasts = F))

kouzh <- model.matrix(~ male + age + agegroup + education_level + work_status + smoking + health_level + lives_alone + has_cellphone - 1, data = kouzh_2018_data_spb, contrasts.arg = lapply(kouzh_2018_data_spb[, sapply(kouzh_2018_data_spb, is.factor), with = F], contrasts, contrasts = F))

# Function that computes per-column
# variable means and their CIs
compute_column_means_with_ci <- function(mat) {

	# Multiple dummy variables by 100 (i.e. all except age) to arrive at percentages
	age_ind <- which(grepl("age$", colnames(mat)))
	if( !length(age_ind) == 0 ) {
		mat[, -age_ind] <- mat[, -age_ind]*100
	} else {
		mat <- mat*100
	}

	out <- lapply(apply(mat, 2, ci.mean), function(x) { data.table(mean = x$mean, lower = x$lower, upper = x$upper) })
	out <- rbindlist(out, id = "variable")
	# Add number of observations
	out <- rbind(out, data.table(variable = "N", mean = nrow(mat)), fill = T)
	return(out)

}

# Perform the computation
mean_computation_results <- rbind(
									data.table(type = "called_wave_1", compute_column_means_with_ci(called_wave1)),
									data.table(type = "smoking_wave_1", compute_column_means_with_ci(smoking_wave1)),
									data.table(type = "called_wave_2", compute_column_means_with_ci(called_wave2)),
									data.table(type = "kouzh", compute_column_means_with_ci(kouzh))

)

# Round variables to two digits
mean_computation_results[, c("mean", "lower", "upper") := lapply(.SD, function(x) { round(x, 1) } ), .SDcols = c("mean", "lower", "upper")]

# Add smoking data for wave 1
mean_computation_results <- mean_computation_results[ !( type == "smoking_wave_1" & variable == "N") ]
mean_computation_results[ type == "smoking_wave_1" , type := "called_wave_1" ]

# To latex code
## CIs to one variable
mean_computation_results[, ci := paste0("\\begin{footnotesize}(", lower, "; ", upper, ")\\end{footnotesize}")]

# Transform to a table with means and CIs underneath
mean_computation_results_long <- melt(mean_computation_results, id.vars = c("type", "variable"), measure.vars = c("mean", "ci"), variable.name = "indicator", value.name = "value")
mean_computation_results_wide <- dcast(mean_computation_results_long, variable + indicator ~ type, value.var = "value", fill = NA)

# Order rows manually
row_order <- c("male", "age", "agegroup18-34", "agegroup35-49", "agegroup50-64", "agegroup65+", "education_levelPrimary / secondary education", "education_levelSpecial secondary education", "education_levelHigher education", "work_status", "smoking", "health_levelVery good", "health_levelGood", "health_levelSatisfactory", "health_levelBad", "health_levelVery bad", "lives_alone", "has_cellphone", "N")

current_order <- match(row_order, mean_computation_results_wide$variable)
# Add CIs
target_order <- as.numeric(c(stri_split_fixed(paste(current_order, current_order + 1, sep = ",", collapse = ","), ",", simplify = T)))

mean_computation_results_output <- mean_computation_results_wide[target_order]
mean_computation_results_output <- mean_computation_results_output[!(variable == "N" & indicator == "ci")]
mean_computation_results_output[, indicator := NULL]

# Order columns
setcolorder(mean_computation_results_output, c("variable", "called_wave_1", "called_wave_2", "kouzh"))

# Add line break to last column
mean_computation_results_output[, kouzh := paste0(kouzh, " \\\\")]

# Rename colums
mean_computation_results_output[variable == "male", variable := "Male, \\%"]
mean_computation_results_output[variable == "age", variable := "Age, years"]
mean_computation_results_output[grepl("agegroup", variable), variable := paste0(gsub("agegroup", "\\indentintable ", variable, fixed = T), ", \\%") ]
mean_computation_results_output[grepl("education_level", variable), variable := paste0(gsub("education_level", "\\indentintable ", variable, fixed = T), ", \\%") ]
mean_computation_results_output[variable == "work_status", variable := "Employed, \\%"]
mean_computation_results_output[variable == "smoking", variable := "Smokes, \\%"]
mean_computation_results_output[grepl("health_level", variable), variable := paste0(gsub("health_level", "\\indentintable ", variable, fixed = T), ", \\%") ]
mean_computation_results_output[variable == "lives_alone", variable := "Lives alone, \\%"]
mean_computation_results_output[variable == "has_cellphone", variable := "Has cellphone, \\%"]
mean_computation_results_output[variable == "consumes_alcohol", variable := "Consumes alcohol, \\%"]

# Remove CI variable names
mean_computation_results_output[duplicated(variable), variable := ""]

## Write to special temp file that will
## form the respective table after manual work
#fwrite(mean_computation_results_output, file = "temp/temp.tex", sep = "&", quote = F)

# Manually add dividers to the table:
# Education & \\
# Self-reported health status & \\
# \multicolumn{4}{l}{Self-reported smoking status (from paper-based survey)} & \\


# Kevin P. Keegan - all rights reserved - 11-12-12
# Function to remove "single counts -- or any count that is <= abundance_limit
remove_singletons <- function(
                              my.matrix, abundance_limit = 1, debug=FALSE
                              )
{

  if ( nargs() == 0 ){
     writeLines("
     You supplied no arguments

     DESCRIPTION: (remove_singletons):
     This is a script to remove singleton counts (or any counts that fail to meet a specified threshold)
     from a data matrix.  It assumes that columns are samples, rows are observations (taxons or functions).
     Rows with a sum of counts < abundance limit are removed.
     - Returns a filtered matrix.
     - Produces a matrix object called filtered.matrix with the filtered matrix
       and a list object, fail.list with names of rows that were filtered

     USAGE:
     my.matrix.without_singletons <- remove_singletons(my.matrix, abundance_limit = 1, debug=FALSE)

     EXAMPLE:
     my.matrix.without_singletons <- remove_singletons(my.matrix, abundance_limit = 1, debug=FALSE)

     )
     "
                )
   }

  dim_matrix <- dim(my.matrix)
  num_row <- dim_matrix[1]
  num_col <- dim_matrix[2]
  filtered.matrix <<- matrix(0,num_row,num_col)
  dimnames(filtered.matrix)[1] <<- dimnames(filtered.matrix)[1]
  dimnames(filtered.matrix)[2] <<- dimnames(filtered.matrix)[2]
  row_sums <<- matrix(0, num_row, 1)
  zero_row_count <<- 0

  # create a filtered matrix in with all NA's replaced with 0's
  my.matrix[ is.na(my.matrix) ]<-0

  # determine the sum of counts for each row
  for (i in 1:num_row){
    #for (j in 1:num_col){
    #  if (my_matrix[i,j] > abundance_limit){
    #    filtered_matrix[i,j] <<- my_matrix[i,j]
    #  }
    #}
    row_sums[i,1] <<- sum(my.matrix[i,])
    #if (debug == TRUE){print(paste("row:", i, "sum:", row_sums[i,1]))}
    if ( row_sums[i,1] <= abundance_limit ){
      zero_row_count <<- zero_row_count + 1
    }
  }

  if (debug==TRUE){ print(paste("zero_row_count:", zero_row_count)) }
  filtered.matrix <<- matrix(0, (num_row - zero_row_count), num_col)
  fail.list <<- vector(mode="list", length=zero_row_count)
  dimnames(filtered.matrix)[[1]] <<- c(1:(num_row - zero_row_count))
  dimnames(filtered.matrix)[[2]] <<- dimnames(my.matrix)[[2]]

  # now build a filtered matrix that tosses any rows entirely populated with zeros (anything with row count < abundance_limit)
  # as well as a list with the names of the rows that were tossed
  screen.row_count = 1
  zero.row_count = 1
  for (i in 1:num_row){
    if (row_sums[i,1] > abundance_limit){
      for (j in 1:num_col){
        filtered.matrix[screen.row_count, j] <<- my.matrix[i,j]
        #if(debug==TRUE){print(paste("i: ",i))}
        #if(debug==TRUE){print(paste("screen.row_count: ",screen.row_count))}
        #if(debug==TRUE){print(paste("j: ",j))}
        dimnames(filtered.matrix)[[1]][screen.row_count] <<- dimnames(my.matrix)[[1]][i]
      }
      screen.row_count = screen.row_count + 1
    }else{
      fail.list[zero.row_count] <<- dimnames(my.matrix)[[1]][i]
      zero.row_count = zero.row_count + 1

    }
  }

  return(filtered.matrix)

}


###ABP
ABP <-
"{5 < logKo_w.contour &
logKo_w.contour < 7 &
-4 < logKa_w.contour &
logKa_w.contour < -1}"

###LRTP
LRTP <-
"{(-5 < logKa_w.contour &
logKa_w.contour < -1) |
(-1 < logKa_w.contour &
5 < logKo_a.contour)}"

###ACP
ACP <-
"{(-0.5 < logKa_w.contour &
logKa_w.contour < 4) & logKo_a.contour < 9 |
(-3 < logKa_w.contour &
6.5 < logKo_a.contour &
logKo_a.contour < 10)}"

###TBP
TBP <-
"{2 < logKo_w.contour &
logKo_w.contour < 5 &
6 <= logKo_a.contour}"

###ATBP
ATBP <-
"{2 < logKo_w.contour &
6 <= logKo_a.contour}"

###BAP
BAP <-
"{(2 < logKo_w.contour &
logKo_w.contour < 11) &
(6 < logKo_a.contour &
logKo_a.contour < 12)}"

###For multiple condition
domain.element <- strsplit(domain.name, "&")
d.length <- length(domain.element[[1]])
if ( d.length > 1 ){
	condi.text.bind <- 0
	for (ii in 1:d.length){
		condi.text <- eval(parse(text=(domain.element[[1]][ii])))
		condi.text.bind <- cbind(condi.text.bind,condi.text)
	}
	condi.text.bind <- condi.text.bind[-c(1)]
	remain.condition <- paste(condi.text.bind[1:d.length],collapse="&")
} else {
	remain.condition <- eval(parse(text=domain.name))
}
topic.name <- domain.name


rf <- RFclust.SGE ( dat=dat, SGE=F, slices=3, slurm=T, settings=list( 'A' = "lsens2017-3-2", t="00:20:00" ,p="dell" ) )

rf <- runRFclust ( rf, nforest=5)

for ( i in 1:3 ) {
	fn <- paste( 'runRFclust_RFrun_',i,'.sh', sep="" )
	expect_true ( file.exists( fn ), info=fn)
}

## this will break everywhere but on aurora-ls2.lunarc.lu.se

#expect_equal(dim(rf@distRF[[1]]$cl1),c(100,100))

#groups <- createGroups( rf, c( 2,4,6,8), name="RFrun"  )

#expect_equal( dim(groups), c(100,6))

#rf <- RFclust.SGE ( dat=dat, SGE=F, slices=2 )
#rf <- runRFclust ( rf, nforest=5 )
#groups <- createGroups( rf, c( 2,4,6,8) )
#
#
#rf <- RFclust.SGE ( dat=dat, SGE=T, slices=2, email='someMail@somewhere.se' )
#rf <- runRFclust ( rf, nforest=5 )
#groups <- createGroups( rf, c( 2,4,6,8) )


#script for counting number of predictable taxa in and out of sample.
#some latex evangelist will take this opportunity to tell me I should use latex. no.
rm(list=ls())
source('paths_fall2019.r')
source('paths.r')

#Load calibration/validation rsq.1 data, Moran's I data.----
d.ITS <- readRDS(NEON_dmilti.ddirch_analysis_summary.path)
d.16S <- readRDS(NEON_dmilti.ddirch_analysis_summary_16S.path)

#1. Workup ITS calibration/validation rsq.1 values across phylo/function scales.----
#calibration rsq.1 values by functional/taxonomic group.
cal.check.ITS   <- list()
cal.mu.ITS      <- list()
cal.mu.ITS.bias <- list()
for(i in 1:length(d.ITS$calibration$cal.stat)){
  check <- d.ITS$calibration$cal.stat[[i]]
  check$rsq.1 <- ifelse(check$rsq.1 < 0, 0, check$rsq.1)
  cal.check.ITS  [[i]] <- check
  cal.mu.ITS     [[i]] <- mean(check$rsq.1)
  cal.mu.ITS.bias[[i]] <- mean(check$rsq)
}
cal.mu.ITS      <- unlist(cal.mu.ITS)
cal.mu.ITS.bias <- unlist(cal.mu.ITS.bias)
names(cal.mu.ITS     ) <- names(d.ITS$calibration$cal.stat)
names(cal.mu.ITS.bias) <- names(d.ITS$calibration$cal.stat)

#validation rsq.1 values by functional/taxonomic group.
val.check.ITS   <- list()
val.mu.ITS      <- list()
val.mu.ITS.bias <- list()
for(i in 1:length(d.ITS$validation$val.stat$site.stat)){
  check <- d.ITS$validation$val.stat$site.stat[[i]]
  check <- check[check$name %in% cal.check.ITS[[i]]$name,]
  check$rsq.1 <- ifelse(check$rsq.1 < 0, 0, check$rsq.1)
  val.check.ITS  [[i]] <- check
  val.mu.ITS     [[i]] <- mean(check$rsq.1)
  val.mu.ITS.bias[[i]] <- mean(check$rsq)
}
val.mu.ITS      <- unlist(val.mu.ITS)
val.mu.ITS.bias <- unlist(val.mu.ITS.bias)
names(val.mu.ITS     ) <- names(d.ITS$validation$val.stat$site.stat)
names(val.mu.ITS.bias) <- names(d.ITS$validation$val.stat$site.stat)

#2. Workup 16S calibration/validation rsq.1 values across phylo/function scales.----
#get calibration rsq.1 values by group.
cal.check.16S <- list()
cal.mu.16S <- list()
for(i in 1:length(d.16S$calibration$cal.stat)){
  check <- d.16S$calibration$cal.stat[[i]]
  check$rsq.1 <- ifelse(check$rsq.1 < 0, 0, check$rsq.1)
  cal.check.16S[[i]] <- check
  cal.mu.16S   [[i]] <- mean(check$rsq.1)
}
cal.mu.16S <- unlist(cal.mu.16S)
names(cal.mu.16S) <- names(d.16S$calibration$cal.stat)

#get validation rsq.1 values by group.
val.check.16S   <- list()
val.mu.16S      <- list()
val.mu.16S.bias <- list()
for(i in 1:length(d.16S$validation$val.stat$site.stat)){
  check <- d.16S$validation$val.stat$site.stat[[i]]
  check <- check[check$name %in% cal.check.16S[[i]]$name,]
  check$rsq.1 <- ifelse(check$rsq.1 < 0, 0, check$rsq.1)
  val.check.16S  [[i]] <- check
  val.mu.16S     [[i]] <- mean(check$rsq.1)
  val.mu.16S.bias[[i]] <- mean(check$rsq)
}
val.mu.16S      <- unlist(val.mu.16S)
val.mu.16S.bias <- unlist(val.mu.16S.bias)
names(val.mu.16S     ) <- names(d.16S$validation$val.stat$site.stat)
names(val.mu.16S.bias) <- names(d.16S$validation$val.stat$site.stat)

#Get calibration / validation rsq1 numbers together, calculate statistics.----
cal.ITS <- data.frame(do.call(rbind, cal.check.ITS))
cal.16S <- data.frame(do.call(rbind, cal.check.16S))
val.ITS <- data.frame(do.call(rbind, val.check.ITS))
val.16S <- data.frame(do.call(rbind, val.check.16S))

fun <- merge(cal.ITS[,c('name','rsq.1')], val.ITS[,c('name','rsq.1','rsq')], by = 'name')
colnames(fun) <- c('name','rsq.cal','rsq.val','rsq.val.bias')
bac <- merge(cal.16S[,c('name','rsq.1')], val.16S[,c('name','rsq.1','rsq')], by = 'name')
colnames(bac) <- c('name','rsq.cal','rsq.val','rsq.val.bias')

#predictability cutoff
pc <- 0.1
tot.fun <- nrow(fun)
tot.bac <- nrow(bac)
n.fun.pred.cal      <- nrow(fun[fun$rsq.cal >= pc,])
n.fun.pred.val      <- nrow(fun[fun$rsq.cal >= pc & fun$rsq.val >= pc,])
n.fun.pred.val.bias <- nrow(fun[fun$rsq.cal >= pc & fun$rsq.val.bias >= pc,])
n.bac.pred.cal      <- nrow(bac[bac$rsq.cal >= pc,])
n.bac.pred.val      <- nrow(bac[bac$rsq.cal >= pc & bac$rsq.val >= pc,])
n.bac.pred.val.bias <- nrow(bac[bac$rsq.cal >= pc & bac$rsq.val.bias >= pc,])

#predictability statistics in and out of sample.
insamp.pred.fun       <- round((n.fun.pred.cal     /tot.fun)*100, 2)
insamp.pred.bac       <- round((n.bac.pred.cal     /tot.bac)*100, 2)
outsamp.pred.fun      <- round((n.fun.pred.val     /n.fun.pred.cal)*100, 2)
outsamp.pred.bac      <- round((n.bac.pred.val     /n.bac.pred.cal)*100, 2)
outsamp.pred.fun.bias <- round((n.fun.pred.val.bias/n.fun.pred.cal)*100, 2)
outsamp.pred.bac.bias <- round((n.bac.pred.val.bias/n.bac.pred.cal)*100, 2)

#report.----
msg1 <- paste0(insamp.pred.fun,'% of fungal taxa and ',insamp.pred.bac,'% of bacterial taxa were predictable in sample at an r-square threshold of ',round(pc*100,2),'%.\n')
msg2 <- paste0(outsamp.pred.fun,'% of fungal taxa and ',outsamp.pred.bac,'% of bacterial taxa predictable in sample were predictable out of sample at an r-square threshold of ',round(pc*100,2),'%.\n')
msg3 <- paste0(outsamp.pred.fun.bias,'% of fungal taxa and ',outsamp.pred.bac.bias,'% of bacterial taxa predictable in sample were predictable out of sample at an r-square threshold of ',round(pc*100,2),'% once prediction biases were accounted for.\n')
cat(msg1);cat(msg2);cat(msg3)


setwd("E:/code/R")
fi<-read.csv("heart.csv")
print(fi)
install.packages("caret")
library("caret")
w=createDataPartition(y=fi$target,p=0.7,list=FALSE)
train=fi[w,]
test=fi[-w,]
print(train)
print(test)
fj<-read.csv("heart_failure_clinical_records_dataset.csv")
print(fj)

w=createDataPartition(y=fj$DEATH_EVENT,p=0.7,list=FALSE)
train=fj[w,]
test=fj[-w,]
print(train)
print(test)
print(nrow(fj))
print(ncol(fj))
print(nrow(train))
print(nrow(test))


  regrid.lonlat = function (old, res, vr.to.sum=NULL, vr.to.cp=NULL) {
    old$gridid = paste(old$plon%/%res*res, old$plat%/%res*res, sep="." )
    new=data.frame( gridid = I(sort(unique(old$gridid)) ))
    for (vr in vr.to.sum) {
      l = aggregate(old[,vr], by=list(old$gridid), FUN=sum, na.rm=T)
      names(l) = c("gridid", vr)
      l$gridid = as.character(l$gridid)
      new = merge(x=new, y=l, by="gridid", all.x=T, all.y=F, sort=F)
    }
    if (!is.null(vr.to.cp) ) {
    for (vr in vr.to.cp) {
      l = aggregate(old[,vr], by=list(old$gridid), FUN=function(x) sort(unique(x))[1] )
      names(l) = c("gridid", vr)
      l$gridid = as.character(l$gridid)
      new = merge(x=new, y=l, by="gridid", all.x=T, all.y=F, sort=F)
    }}
    new$gridid = as.character( new$gridid )

    return( new )
  }


library(phyloseq)
library(dada2)
library(ggplot2)
library(RColorBrewer)
# Load libraries

# Import sequence processing table and check it out
# How many sequences were retained at each step?
track = readRDS("track.rds")
track

# Import final otu table
OTUs = readRDS("OTUtab.nochim.rds")
# Change rows and columns so taxa are rows
OTUs = t(OTUs)
# Import as phyloseq object table
otutab = otu_table(OTUs, taxa_are_rows=TRUE)
head(otutab)
# Look at lowest-abundance samples
head(sort(sample_sums(otutab)))

name = row.names(otutab)[1]
name
hist(nchar(row.names(otutab)))

colnames(otutab)
# The sample names have suffixes appended to them - we just want sample IDs
# Get names
names = colnames(otutab)
# Remove last 17 characters
newnames = gsub('.{17}$', '', names)
# Check out names
newnames

# Assign new names to samples
colnames(otutab) = newnames

# Same thing if we wanted to simplify OTU names to IDs
# Instead of sequences (although that's useful)
otunames=row.names(otutab)
length(otunames)
newotunames = paste("OTU",rep(1:length(otunames)),sep="")
head(newotunames)
row.names(otutab) = newotunames
head(otutab)

# Cut off the sampling ID to match metadata
for (i in 1:length(colnames(otutab))){
  newname = strsplit(colnames(otutab[i]),"_")[[i]][1]
  colnames(otutab)[i]=newname
}

# Import sample data
samdat = read.csv("Hatch-Metadata.csv")
samdat$Sample.ID = as.character(samdat$Sample.ID)
samdat$Sample.ID[1:9] = paste("00",samdat$Sample.ID[1:9],sep="")
samdat$Sample.ID[10:length(samdat$Sample.ID)] = paste("0",samdat$Sample.ID[10:length(samdat$Sample.ID)],sep="")

# Check we have all the same sample names now
samdat$Sample.ID == colnames(otutab)[1:65]
samdat = sample_data(samdat)

row.names(samdat) = samdat$Sample.ID

# Create phyloseq object
ps = phyloseq(otu_table=otutab,sample_data=samdat)

ps.melt = psmelt(ps)
ps.melt

head(ps.melt)

hist(sample_sums(ps))

# Relative abundances
ps.norm = transform_sample_counts(ps,function(x) x/sum(x))
head(otu_table(ps.norm))
sample_sums(ps.norm)
# Looks good

ps.norm.noC = prune_samples(sample_names(ps.norm) != "049-W3-Compost",ps.norm)
ps.norm.noC = prune_samples(sample_names(ps.norm.nocompost) != "004-K2-Muck",ps.norm.nocompost)
ps.norm.noC

colnames(sample_data(ps.norm))

ps.ord.nmds = ordinate(ps.norm.noC, "NMDS", "bray",trymax=1000,k=2)
p = plot_ordination(ps.norm.noC, ps.ord.nmds, type="samples")
palette = brewer.pal(8, "Spectral")
p = p + aes(colour=Soil.pH) + geom_point(size=3) + scale_colour_gradientn(colors=palette)
p

row.names(samdat)
ps.ord.pcoa = ordinate(ps, "PCoA", "bray")
p = plot_ordination(ps, ps.ord.pcoa, type="samples",label="Names")
p


common_source_folder <- "~/Documents/R_Projects/Common_R_Source_Files/";	# directory to folder where you keep common source
source(paste(common_source_folder,"RevBayes_Setup.r",sep=""));

# This will take the Mesquite file and break it down into three matrices for 2-, 3- & 4-state characters.
# None of the notes or information about taxa, characters & states are retained; these choke RevBayes
analysis_name <- "Cinctamania_2019";
mesquite_to_RevBayes <- diffindo_character_matrix_by_state_numbers_and_other_partitions(analysis_name);

# This will take a nexus file plus a intervals.tsv file and an FBD parameterization script, and create a script for a strict clock analysis in RevBayes
set_wdir <- "/Users/bilbo_baggins/Documents/RevBayes_Projects/";
scribio_RevBayes_scripts_from_chosen_nexus_file_and_existing_FBD_script_and_data(analysis_name=analysis_name,set_wdir=set_wdir);

end();


  figure.interpolated.results = function( p, outdir, all.areas=T, alt.zero.y=F ) {

    varstoplot = matrix(ncol=3, byrow=T, data=
      c( "R0.mass", "Fishable biomass", "B"  #,
#       "R0.no", "Number of fishable crab", "N",
#       "R1.no", "Number of recruits", "N"#,

       #"totno.female.imm",  "Number of immature females", "N",
       #"totno.female.mat",  "Number of mature females", "N",
       #"totno.female.berried",  "Number of berried females", "N",
       #"totno.female.primiparous", "Number of primiparous females", "N",
       # "totno.female.multiparous",  "Number of multiparous females", "N",

       # "mi6.no", "Number of immature - instar 6", "N",
       # "mi7.no", "Number of immature - instar 7", "N",
       # "mi8.no", "Number of immature - instar 8", "N",
       # "mi9.no", "Number of immature - instar 9", "N",
       # "mi10.no", "Number of immature - instar 10", "N",
       # "mi11.no", "Number of immature - instar 11", "N",
       # "mi12.no", "Number of immature - instar 12", "N",

       # "mi9.skip.moulter.no", "Number of immature skip moulter - instar 9", "N",
       # "mi10.skip.moulter.no", "Number of immature skip moulter - instar 10", "N",
       # "mi11.skip.moulter.no", "Number of immature skip moulter - instar 11", "N",
       # "mi12.skip.moulter.no", "Number of immature skip moulter - instar 12", "N",

       # "ma9.CC1to2.no", "Number of mature - instar 9 CC1 & 2", "N",
       # "ma10.CC1to2.no", "Number of mature - instar 10 CC1 & 2", "N",
       # "ma11.CC1to2.no", "Number of mature - instar 11 CC1 & 2", "N",
       # "ma12.CC1to2.no", "Number of mature - instar 12 CC1 & 2", "N",
       # "ma13.CC1to2.no", "Number of mature - instar 13 CC1 & 2", "N",

       # "ma9.CC3to4.no", "Number of mature - instar 9 CC3 & 4", "N",
       # "ma10.CC3to4.no", "Number of mature - instar 10 CC3 & 4", "N",
       # "ma11.CC3to4.no", "Number of mature - instar 11 CC3 & 4", "N",
       # "ma12.CC3to4.no", "Number of mature - instar 12 CC3 & 4", "N",
       # "ma13.CC3to4.no", "Number of mature - instar 13 CC3 & 4", "N",

       # "ma9.CC5.no", "Number of mature - instar 9 CC5", "N",
       # "ma10.CC5.no", "Number of mature - instar 10 CC5", "N",
       # "ma11.CC5.no", "Number of mature - instar 11 CC5", "N",
       # "ma12.CC5.no", "Number of mature - instar 12 CC5", "N",
       # "ma13.CC5.no", "Number of mature - instar 13 CC5", "N"

    ) )

    eps = 1e-6

    p$vars.to.model = varstoplot[,1]
#     p$yrs = 1998:p$year.assessment
    p$runindex = list(y=p$yrs, v=p$vars.to.model )

    K = interpolation.db( DS="interpolation.simulation", p=p )

    year.assessment = p$year.assessment
    K = K[ -which( as.character(K$region)=="cfa4x" & K$yr <= 2002 ), ]
    K = K[ which( K$yr >1997 ), ]

    if (all.areas) {
      areas = c("cfa4x", "cfasouth", "cfanorth" )
      regions = c("4X", "S-ENS", "N-ENS")
    } else {
      areas = c("cfasouth", "cfanorth" )
      regions = c("S-ENS", "N-ENS")
    }

    n.regions = length(regions)
    K$region = factor(as.character(K$region), levels=areas, labels=regions)
    K$ubound = K$total.ub
    K$lbound = K$total.lb

    zero.value = K[1,]
    zero.value$yr = year.assessment
    zero.value$total = 0
    zero.value$lbound = 0
    zero.value$ubound = 0

    xlim=range(K$yr, na.rm=T)
    xlim[1]=xlim[1]-0.5
    xlim[2]=xlim[2]+0.5

    nvarstoplot = dim(varstoplot)[1]

    for (i in c(1:nvarstoplot)) {

      v = varstoplot[i,1]
      tt = varstoplot[i,2]

      # td = K[ which(as.character(K$vars)==v) ,]
      td = K

      if (varstoplot[i,3] == "B") {
        yy = expression(paste( "Biomass (X ", 10^3, " t)"))
        convert = 10^3 # from t to kt
        eps = 1e-6
      } else if (varstoplot[i,3] == "N") {
        yy = expression(paste( "Number (X ", 10^6, " )"))
        convert = 1  # convert to
        eps = 1e-6
      }

      if (v=="R0.mass") {
        ii = which(td$yr==1998 & td$region=="S-ENS")
        if ( length(ii)>0 ) td[ ii, "total" ] = NA  # strange data
      }
      if (v=="R1.no") {
  #      mm = zero.value
  #      mm$region = "N-ENS"
  #      td = rbind(td, mm)
      }

      varstocheck = c("total", "ubound", "lbound")
      for (vs in varstocheck) {
        td[,vs] = td[,vs] / convert
        kk = which(td[,vs] <= eps)
        if ( length(kk)>0 ) td[kk,vs] = 0
      }

      td = td[is.finite(td$total) ,]
      td = td[order(td$region,td$yr),]

      # last check to make sure data exists for all regions for the plots
      limits = list()
      for (rr in 1:n.regions) {
        nr = NULL
        pp = which( td$region==regions[rr] )
        nr = length( pp )
        if (nr ==0) {
          mm = zero.value
          mm$region = regions[rr]
          td = rbind( td, mm)
          qq = 1
        } else {
          qq = max(td$ubound[pp], na.rm=T)
        }
        limits[[rr]] = c(0, qq )
      }

      dir.create( outdir, recursive=T, showWarnings=F  )
      fn = file.path( outdir, paste(v, "png", sep=".") )
      print (fn)

      png( filename=fn, width=3072, height=2304, pointsize=30, res=300 )

      setup.lattice.options()

      scales=list()
      if (alt.zero.y) {
        scales = list(y = list(relation="free", limits=limits  ))
      }

      pl = xyplot( total~yr|region, data=td, ub=td$ubound, lb=td$lbound,
        layout=c(1,n.regions), xlim=xlim, scales=scales,
        par.strip.text = list(cex=1),
        par.settings=list(
          axis.text=list(cex=1.5),
          par.main.text = list(cex=1.5),
          layout.heights=list(strip=1, panel=1, main=0.5 )
        ),
        main=list(label=tt), xlab=list(label="Survey year", cex=2), ylab=list(label=yy, cex=2),
        panel = function(x, y, subscripts, ub, lb, ...) {
          larrows(x, lb[subscripts],
                  x, ub[subscripts],
                 angle = 90, code = 3, length=0.02, lwd=4)
          panel.xyplot(x, y, type="b", lty=1, lwd=4, pch=19, col="black", cex=1.2, ...)
          panel.abline(v=2001.5, col="gray", lty=5, lwd=4, ...)
          panel.abline(h=0, col="gray", lty=1, lwd=4, ...)
          panel.abline(h=mean(y,na.rm=TRUE), col="gray", lty=2, lwd=3, ...)
       }
     )

     print(pl)
     dev.off()
    }
    return("Done")
  }


# Detect and prevent collisions.
# Powers dodging, stacking and filling.
collide_setup <- function(data, width = NULL, name, strategy,
                          check.width = TRUE, reverse = FALSE) {
  # Determine width
  if (!is.null(width)) {
    # Width set manually
    if (!(all(c("xmin", "xmax") %in% names(data)))) {
      data$xmin <- data$x - width / 2
      data$xmax <- data$x + width / 2
    }
  } else {
    if (!(all(c("xmin", "xmax") %in% names(data)))) {
      data$xmin <- data$x
      data$xmax <- data$x
    }

    # Width determined from data, must be floating point constant
    widths <- unique(data$xmax - data$xmin)
    widths <- widths[!is.na(widths)]

#   # Suppress warning message since it's not reliable
#     if (!zero_range(range(widths))) {
#       warn(name, " requires constant width: output may be incorrect")
#     }
    width <- widths[1]
  }

  list(data = data, width = width)
}

collide <- function(data, width = NULL, name, strategy,
                    ..., check.width = TRUE, reverse = FALSE) {
  dlist <- collide_setup(data, width, name, strategy, check.width, reverse)
  data <- dlist$data
  width <- dlist$width

  # Reorder by x position, then on group. The default stacking order reverses
  # the group in order to match the legend order.
  if (reverse) {
    ord <- order(data$xmin, data$group)
  } else {
    ord <- order(data$xmin, -data$group)
  }
  data <- data[ord, ]

  # Check for overlap
  intervals <- as.numeric(t(unique(data[c("xmin", "xmax")])))
  intervals <- intervals[!is.na(intervals)]

  if (length(unique(intervals)) > 1 & any(diff(scale(intervals)) < -1e-6)) {
    warn(glue("{name} requires non-overlapping x intervals"))
    # This is where the algorithm from [L. Wilkinson. Dot plots.
    # The American Statistician, 1999.] should be used
  }

  if (!is.null(data$ymax)) {
    data <- dapply(data, "xmin", strategy, ..., width = width)
  } else if (!is.null(data$y)) {
    data$ymax <- data$y
    data <- dapply(data, "xmin", strategy, ..., width = width)
    data$y <- data$ymax
  } else {
    abort("Neither y nor ymax defined")
  }
  data[match(seq_along(ord), ord), ]
}

# Alternate version of collide() used by position_dodge2()
collide2 <- function(data, width = NULL, name, strategy,
                     ..., check.width = TRUE, reverse = FALSE) {
  dlist <- collide_setup(data, width, name, strategy, check.width, reverse)
  data <- dlist$data
  width <- dlist$width

  # Reorder by x position, then on group. The default stacking order is
  # different than for collide() because of the order in which pos_dodge2 places
  # elements
  if (reverse) {
    data <- data[order(data$x, -data$group), ]
  } else {
    data <- data[order(data$x, data$group), ]
  }

  pos <- match.fun(strategy)
  pos(data, width, ...)
}


# Extracting observed interaction matrix
empirical_matrix <- function(S1, interactions_source, source) {
    # Parameters:
    #   S1                      Set of taxa in predicted community structure
    #   interactions_source     Binary interactions with source identified
    #   source                  Source of the empirical community

    #   Output                  Food web matrix with dimensions S1 x S1 with consumers as columns
    empirical.matrix <- matrix(nrow = length(S1), ncol = length(S1), data = 0, dimnames = list(S1,S1))
    interactions <- interactions_sources[which(interactions_sources[, 'source'] == source), ]
    inter <- which(interactions[, 'inter'] == 1)

    for(i in inter) {
        empirical.matrix[interactions[i, 'resource'], interactions[i, 'consumer']] <- 1
    }
    return(empirical.matrix)
}


library(rtweet)
tweet2 <- tweet
is.data.frame(tweet2)
is.data.frame(tweet)
tweet1 <- tweet
tweet1 <- as.data.frame(tweet1)
tweet2 <- as.data.frame(tweet2)

#TWEETS FROM 24TH JUNE TO 10TH JULY
tweetcompleto <- rbind(tweet1, tweet2)

#Sample of 10k tweets
set.seed(12345)
tweetcampione <- sample(tweetcompleto$text, 10000, replace = F)

library(tm)
library(textclean)
library(igraph)
library(ggraph)
library(ggplot2)

#Data-cleaning (URL, EMOTICON, HASHTAG, NON ASCII)
tweetcampione <- replace_url(tweetcampione, mgsub = "")
tweetcampione <- replace_emoticon(tweetcampione, mgsub="")
tweetcampione <- replace_hash(tweetcampione,mgsub="")
tweetcampione <- replace_non_ascii(tweetcampione, mgsub="")
tweetcampione

#CORPUS creation
corpus <- VCorpus(VectorSource(tweetcampione))
summary(corpus)

#Pre-processing
corpus <- tm_map(corpus, content_transformer(tolower))

corpus <- tm_map(corpus, removeNumbers)

corpus <- tm_map(corpus, removeWords, stopwords("english"))

removeTwitterHandles <- function(x) gsub("@\\S+", "", x)
corpus <- tm_map(corpus, content_transformer(removeTwitterHandles))

corpus <- tm_map(corpus, removeNumbers)

corpus <- tm_map(corpus, removeWords, stopwords("english"))
corpus <- tm_map(corpus, removeWords, "amp")

corpus <- tm_map(corpus, removePunctuation)

corpus <- tm_map(corpus, stripWhitespace)

summary(corpus)

corpus2 <- tm_map(corpus, removeWords, c("pride", "happi", "celebr", "day", "year", "month", "last", "via"))

corpus2 <- tm_map(corpus2, removePunctuation)

corpus2 <- tm_map(corpus2, stripWhitespace)

#STEMMING
library("SnowballC")
corpus <- tm_map(corpus, stemDocument)
corpus2 <- tm_map(corpus2, stemDocument)

# Term-document matrix
termdoc <- TermDocumentMatrix(corpus) #9406 termini
termdoc2 <- TermDocumentMatrix(corpus2) #9398
termdoc_nospar <- removeSparseTerms(termdoc, 0.992) #192 termini
termdoc_nospar2 <- removeSparseTerms(termdoc2, 0.992) #184 termini

termdoc_matrix <- as.matrix(termdoc_nospar)
termdoc_matrix2 <- as.matrix(termdoc_nospar2)

v <- sort(rowSums(termdoc_matrix),decreasing=TRUE)
v2 <- sort(rowSums(termdoc_matrix2),decreasing=TRUE)
df_ordinato <- data.frame(word = names(v),freq=v)
df_ordinato2 <- data.frame(word = names(v2),freq=v2)

findAssocs(termdoc_nospar, terms = findFreqTerms(termdoc_nospar, lowfreq = 500), corlimit = 0.10)
#lgbtq and member

#WordCloud
library("wordcloud")
library("RColorBrewer")
par(bg="midnightblue")
png(file="WordCloud2.png",width=600,height=500, bg="midnightblue")
wordcloud(df_ordinato$word[1:192], df_ordinato$freq[1:192], col=rainbow(length(df_ordinato$word), alpha=0.9), random.order=FALSE, rot.per=0.3 )
title(main = "Word cloud #Pride2020", font.main = 1, col.main= "gold", cex.main = 2)
dev.off()

library('syuzhet')

# corpus into dataframe
dfcorpus <- data.frame(text=unlist(sapply(corpus,'[', "content")), stringsAsFactors=F)
dfcorpus2<- data.frame(text=unlist(sapply(corpus2, '[', "content")), stringsAsFactors = F)

sentiment <- get_nrc_sentiment(dfcorpus$text, language = "english")

sentimentitot <- data.frame(colSums(sentiment))

names(sentimentitot)[1] <- "count"
sentimentitot <- cbind("sentiment" = rownames(sentimentitot), sentimentitot)
rownames(sentimentitot) <- NULL

sentimentitot2<-sentimentitot[1:8,]
posneg <- sentimentitot[9:10, ]

# barplot
library("ggplot2")
qplot(sentiment, data=sentimentitot2, weight=count, geom="bar",fill=sentiment)+ggtitle("Sentimenti")

qplot(sentiment, data=posneg, weight=count, geom = "bar", fill=sentiment)+ggtitle("Sentimenti")

#Grapf of words with 184 words -except "pride", "happi", "celebr", "day", "year", "month", "last", "via"-
library(igraph)
library(ggraph)
library(ggplot2)

par(mar=c(1, 2, 1, 2)+0.1)

matriceadiacenza <- termdoc_matrix2 %*% t(termdoc_matrix2)#ADIACENCY MATRIX
grafotermini <- graph_from_adjacency_matrix(matriceadiacenza, "undirected", diag = F, weighted = T)

E(grafotermini)$width <- (E(grafotermini)$weight)*0.1
E(grafotermini)$color <- "green"
E(grafotermini)$alpha <- (E(grafotermini)$weight)*0.1
which.max(E(grafotermini)$weight)
E(grafotermini)$weight[14151]

Matches <- E(grafotermini)$weight

#PLOTS WITH GGPLOT
ggraph(grafotermini, layout = "fr") +
  geom_edge_link(aes(edge_width = Matches, edge_alpha = Matches), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafotermini)))*0.1, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Fruchterman Reingold")

ggraph(grafotermini, layout = layout.kamada.kawai(grafotermini)) +
  geom_edge_link(aes(edge_width = Matches, edge_alpha = Matches), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafotermini)))*0.1, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Kamada Kawai")

ggraph(grafotermini, layout = layout_nicely(grafotermini)) +
  geom_edge_link(aes(edge_width = Matches, edge_alpha = Matches), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafotermini)))*0.1, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Nicely")

ggraph(grafotermini, layout = layout.mds(grafotermini)) +
  geom_edge_link(aes(edge_width = Matches, edge_alpha = Matches), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafotermini)))*0.1, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Multi-Dimensional Scaling")

ggraph(grafotermini, layout =layout_randomly(grafotermini)) +
  geom_edge_link(aes(edge_width = Matches, edge_alpha = Matches), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafotermini)))*0.1, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Randomly")

ggraph(grafotermini, layout =layout.davidson.harel(grafotermini)) +
  geom_edge_link(aes(edge_width = Matches, edge_alpha = Matches), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafotermini)))*0.1, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Davison Harel")

ggraph(grafotermini, layout =layout.auto(grafotermini)) +
  geom_edge_link(aes(edge_width = Matches, edge_alpha = Matches), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafotermini)))*0.1, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Automatico")

degree <- degree(grafotermini,v=V(grafotermini),loops=FALSE)

mean(degree)
var(degree)
degree.distribution(grafotermini)

V <- V(grafotermini)

diameter(grafotermini,weights=E(grafotermini)$weights)

farthest_vertices(grafotermini) #can communiti

edge_density (grafotermini)

vcount(grafotermini)

ecount(grafotermini)

betg<-betweenness(grafotermini,directed=F,normalized=T,weights=E(grafotermini)$weights)
which.max(betg)
which.min(betg)

closg<-closeness(grafotermini,normalized=T,weights=E(grafotermini)$weights)
which.max(closg)
which.min(closg)

distance_table(grafotermini, directed=FALSE)

#COMMUNITY DETECTION
par(bg = "white")
par(mar=c(2, 2, 1, 1) + 0.1)
c1 <- cluster_fast_greedy(grafotermini)
modularity(c1)
c1$modularity
plot(c1, grafotermini)
length(c1)
sizes(c1)

c2 <- cluster_optimal(grafotermini)
plot(c1, vertex.color=membership(c1), grafotermini)

member <- c1$membership
member1 <- which(member==1)
member2 <- which(member==2)
member3 <- which(member==3)
member4 <- which(member==4)
member5 <- which(member==5)
member6 <- which(member==6)

grafo1 <- grafotermini - vertices(c(member2, member3, member4, member5, member6))
Matches1 <- E(grafo1)$weight
ggraph(grafo1, layout = "fr") +
  geom_edge_link(aes(edge_width = Matches1, edge_alpha = Matches1), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafo1)))*0.3, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Fruchterman Reingold")
degree(grafo1)
max_cliques(grafo1, min=20)

grafo2 <- grafotermini - vertices(c(member1, member3, member4, member5, member6))
Matches2 <-E(grafo2)$weight
ggraph(grafo2, layout = "fr") +
  geom_edge_link(aes(edge_width = Matches2, edge_alpha = Matches2), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafo2)))*0.3, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Fruchterman Reingold")
degree(grafo2)
max_cliques(grafo2)

grafo3 <- grafotermini - vertices(c(member1, member2, member4, member5, member6))
Matches3 <-E(grafo3)$weight
ggraph(grafo3, layout = "fr") +
  geom_edge_link(aes(edge_width = Matches3, edge_alpha = Matches3), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafo3)))*0.3, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Fruchterman Reingold")
degree(grafo3)
max_cliques(grafo3)

grafo4 <- grafotermini - vertices(c(member1, member2, member3, member5, member6))
Matches4 <-E(grafo4)$weight
ggraph(grafo4, layout = "fr") +
  geom_edge_link(aes(edge_width = Matches4, edge_alpha = Matches4), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafo4)))*0.3, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Fruchterman Reingold")
degree(grafo4)
max_cliques(grafo4, min = 29)

grafo5 <- grafotermini - vertices(c(member1, member2, member3, member4, member6))
Matches5 <-E(grafo5)$weight
ggraph(grafo5, layout = "fr") +
  geom_edge_link(aes(edge_width = Matches5, edge_alpha = Matches5), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafo5)))*0.3, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Fruchterman Reingold")
degree(grafo5)
max_cliques(grafo5, min = 38)

grafo6 <- grafotermini - vertices(c(member1, member2, member3, member4, member5))
Matches6 <-E(grafo6)$weight
ggraph(grafo6, layout = "fr") +
  geom_edge_link(aes(edge_width = Matches6, edge_alpha = Matches6), edge_colour = "springgreen4") +
  geom_node_point(size=(sqrt(graph.strength(grafo6)))*0.3, color="gold") +
  geom_node_text(aes(label = name), col = "darkred", size = 4) +
  theme(legend.position = "right") +
  labs(title = "Grafo dei termini", subtitle = "Layout Fruchterman Reingold")
degree(grafo6)
max_cliques(grafo6)

#BIGRAMS AND TRIGRAMS

library(udpipe)
library(lattice)
udmodel_en <- udpipe_download_model(language = "english")
udmodel_en <- udpipe_load_model(udmodel_en)

dfcorpus2m <- as.matrix(dfcorpus2)
dfcorpus2c <- as.character(dfcorpus2m)

x <- udpipe_annotate(udmodel_en, x = dfcorpus2c)
x <- as.data.frame(x)

x$phrase_tag <- as_phrasemachine(x$upos, type = "upos")
stats <- keywords_phrases(x = x$phrase_tag, term = tolower(x$token),
                          pattern = "(A|N)*N(P+D*(A|N)*N)*",
                          is_regex = TRUE, detailed = FALSE)
stats2 <- subset(stats, ngram==2 & freq > 3)
stats2$key <- factor(stats2$keyword, levels = rev(stats2$keyword))
barchart(key ~ freq, data = head(stats2, 30), col = "cadetblue",
         main = "Keywords - simple noun phrases", xlab = "Frequency")

stats3 <- subset(stats, ngram==3 & freq>3)
stats3$key <- factor(stats3$keyword, levels = rev(stats3$keyword))
barchart(key ~ freq, data = head(stats3, 30), col = "cadetblue",
         main = "Keywords - simple noun phrases", xlab = "Frequency")


# Most of the code lines in this file don't run on their own
# They are to help you add them to the interactive document

## ----load packages, echo=FALSE-------------------------------------------
library(tidyverse)
library(ggmap)
library(plotly)
library(gganimate)
# install.packages("learnr")

# This is current tuberculosis data taken from
# [WHO](http://www.who.int/tb/country/data/download/en/), the case notifications table.
# It is read into R using this code:

## ----echo=FALSE, fig.width=10, fig.height=8, out.width="100%"------------
tb <- read_csv(here::here("data/TB_notifications_2019-07-01.csv")) %>%
  select(country, iso3, year, g_whoregion, new_sp_m04:new_sp_fu) %>%
  gather(stuff, count, new_sp_m04:new_sp_fu) %>%
  separate(stuff, c("stuff1", "stuff2", "sexage")) %>%
  select(-stuff1, -stuff2) %>%
  mutate(sex=substr(sexage, 1, 1),
         age=substr(sexage, 2, length(sexage))) %>%
  select(-sexage) %>%
  filter(year > 1996, year < 2013) %>%
  filter(!(age %in% c("04", "014", "514", "u")))
p <- tb %>% filter(iso3 == "IND") %>%
  filter(!is.na(count)) %>%
  ggplot() +
  geom_point(aes(x=year, y=count, colour=sex, frame=age, label=iso3)) +
  geom_smooth(aes(x=year, y=count, colour=sex, frame=age),  se=FALSE) +
  scale_colour_brewer(palette = "Dark2") +
  ylim(c(0, 100000))
ggplotly(p)

# Add to the header of your Rmd
knitr::opts_chunk$set(
  echo = FALSE,
  message = FALSE,
  warning = FALSE,
  error = FALSE)

# Example quiz format
quiz(
  question("Which package contains functions for installing other R packages?",
           answer("base"),
           answer("tools"),
           answer("utils", correct = TRUE),
           answer("codetools")
  )
)

# Adding a shiny element
library(plotly)
p <- tb %>% filter(iso3 == "IND") %>%
  filter(!is.na(count)) %>%
  ggplot() +
  geom_point(aes(x=year, y=count, colour=sex, frame=age, label=iso3)) +
  geom_smooth(aes(x=year, y=count, colour=sex, frame=age),  se=FALSE) +
  scale_colour_brewer(palette = "Dark2") +
  ylim(c(0, 100000))
ggplotly(p)

# Styling and cuteness
# remotes::install_github("hadley/emo")
library(emo)
set.seed(20190709)
emo::ji("fantasy")
emo::ji("clock")

# remotes::install_github('emitanaka/anicon')
library(anicon)
anicon::nia("You've got 30 seconds!", colour="#FA700A", anitype="hover")
anicon::faa("hand-paper", animate="spin", grow=20, color="#B78ED2",
            position=c(0,0,0,200))

# Data dashboard
# install.packages("flexdashboard")


library(Biobase)

fn.esets = file.path(PROJECT_DIR, "generated_data","HIPC", "HIPC_IS_esets.rds")
eset_list = readRDS(fn.esets)

studies = names(eset_list)

for (sdy in studies) {

  eset = eset_list[[sdy]]

  # generate probe to gene map
  probes.map = featureData(eset)@data %>%
    tibble::rownames_to_column("ID") %>%
    dplyr::filter(gene_symbol != "")
  colnames(probes.map) = c("ID","gene")
  fn.map = file.path(PROJECT_DIR, "generated_data", "HIPC",
                     paste0(sdy,"_probe_map.txt"))
  fwrite(probes.map, file=fn.map, sep="\t", quote=T)

  source(file.path(PROJECT_DIR, "R/functions/pick.probeset.r"))
  pick.probeset(eset,fn.map)
}


library(reshape2)
library(dplyr)
library(ggplot2)
library(tidyverse)

###########
#LOAD DATA#
###########
n2_1998 <- read.csv("../N2.1998_eps/n2.1998_gmrf_reconstruction1.tsv", sep = "\t", header = TRUE)
n2_1998_2 <- read.csv("../N2.1998_eps/n2.1998_gmrf_reconstruction2.tsv", sep = "\t", header = TRUE)
n2_1998_B <- read.csv("../split_eps_plots/98Bdata.csv", sep = "\t", header = TRUE)
n2_2002 <- read.csv("../N2.2002_eps/n2.2002_gmrf_reconstruction1.tsv", sep = "\t" , header = TRUE)
n2_2002_2 <- read.csv("../N2.2002_eps/n2.2002_gmrf_reconstruction2.tsv", sep = "\t" , header = TRUE)
delta2 <- read.csv("../H1.delta2_eps/h1.delta2_gmrf_reconstruction1.tsv", sep = "\t" , header = TRUE)
delta2_2 <- read.csv("../H1.delta2_eps/h1.delta2_gmrf_reconstruction2.tsv", sep = "\t" , header = TRUE)

###############################
#PRETTY PLOT EPS N2 Figure S1 #
###############################
#using tiff() and dev.off
tiff('test.tiff', units="in", width=13.5, height=9, res=300, compression = 'lzw')

#Data starts in August 2009, or at 2009.66. Scaled at 800x680
(plot1 <- ggplot(n2_2002, aes(x = Time, y = Median))) +
  geom_ribbon(aes(ymin = Lower, ymax = Upper), fill = "red", alpha = 0.5) +
  geom_ribbon(data = n2_1998, aes(ymin = Lower, ymax = Upper), fill = "blue", alpha = 0.5) +
  geom_line(aes(y = Median, color = "N2.2002"), size = 1.5) +
  geom_line(data = n2_1998, aes(y = Median, color = "N2.1998"), size = 1.5) +
  scale_color_manual(values = c(
    'N2.2002' = 'darkred',
    'N2.1998' = 'darkblue')) +
  #ggtitle("Effective population size over time") +
  labs(y = "Median EPS", x = "Time", color = "Clade") +
  ylim(0,130) +
  theme(legend.position = "bottom",
        panel.background = element_rect(fill = "white"),
        panel.grid.major = element_line(colour = "gray90"),
        panel.grid.minor = element_line(colour = "gray90"),
        title = element_text(size=20,face="bold"),
        axis.title = element_text(size=16,face="bold"),
        axis.text = element_text(size=14,face="bold"),
        legend.title = element_text(size=14,),
        legend.text = element_text(size=14),
        ) +
  scale_x_continuous(minor_breaks = seq(2008 , 2020, 1), breaks = seq(2008, 2020, 2), limits = c(2009.66,2019))

dev.off()

############################
#PRETTY PLOT TOTAL COMBINED#
############################
n2_total <- n2_2002 + n2_1998
n2_total$Time = (n2_2002$Time + n2_1998$Time)/2  #Attempt to average the time

plot3 <- ggplot(n2_total, aes(x = Time, y = Median)) +
  geom_ribbon(aes(ymin = Lower, ymax = Upper), fill = "purple", alpha = 0.5) +
  geom_line(aes(y = Median, color = "N2.2002"), size = 1.5) +
  scale_color_manual(values = c(
    'N2.2002' = 'purple4')) +
  #ggtitle("Effective population size over time") +
  labs(y = "Median EPS", x = "Time", color = "Clade") +
  ylim(0,130) +
  theme(legend.position = "bottom",
        panel.background = element_rect(fill = "white"),
        panel.grid.major = element_line(colour = "gray90"),
        panel.grid.minor = element_line(colour = "gray90"),
        title = element_text(size=20,face="bold"),
        axis.title = element_text(size=16,face="bold"),
        axis.text = element_text(size=14,face="bold"),
        legend.title = element_text(size=14,),
        legend.text = element_text(size=14),
  ) +
  scale_x_continuous(minor_breaks = seq(2008 , 2020, 1), breaks = seq(2008, 2020, 2), limits = c(2009.66,2019))

####################################
#PRETTY PLOT EPS N2.1998 and Delta2#
####################################
plot2 <- ggplot(delta2, aes(x = Time, y = Median)) +
  geom_ribbon(aes(ymin = Lower, ymax = Upper), fill = "red", alpha = 0.5) +
  geom_ribbon(data = n2_1998_B, aes(ymin = Lower, ymax = Upper), fill = "blue", alpha = 0.5) +
  geom_line(aes(y = Median, color = "H1.Delta2"), size = 1.5) +
  geom_line(data = n2_1998_B, aes(y = Median, color = "N2.1998B"), size = 1.5) +
  scale_color_manual(values = c(
    'H1.Delta2' = 'darkred',
    'N2.1998B' = 'darkblue')) +
  #ggtitle("Effective population size over time") +
  labs(y = "Median EPS", x = "Time", color = "Clade") +
  theme(legend.position = "bottom",
        panel.background = element_rect(fill = "white"),
        panel.grid.major = element_line(colour = "gray90"),
        panel.grid.minor = element_line(colour = "gray90"),
        title = element_text(size=20,face="bold"),
        axis.title = element_text(size=16,face="bold"),
        axis.text = element_text(size=14,face="bold"),
        legend.title = element_text(size=14,),
        legend.text = element_text(size=14),
        ) +
  scale_x_continuous(minor_breaks = seq(2008 , 2020, 1), breaks = seq(2008, 2020, 2), limits = c(2009.66,2019))

#Plot first two as subsets
#library(cowplot)
mixplot <- plot_grid(plot1, plot2, labels = "AUTO", label_size = 18)
title <- ggdraw() + draw_label("Effective population size over time", fontface='bold', size = 20)
plot_grid(title, mixplot, ncol=1, rel_heights=c(0.1, 1))

###############################################
#Compare first and 2nd runs 1998, 2002, delta2#
###############################################
#1998
ggplot(n2_1998, aes(x = Time, y = Median)) +
  geom_ribbon(aes(ymin = Lower, ymax = Upper), fill = "red", alpha = 0.5) +
  geom_ribbon(data = n2_1998_2, aes(ymin = Lower, ymax = Upper), fill = "blue", alpha = 0.5) +
  geom_line(aes(y = Median, color = "1998.1"), size = 1.5) +
  geom_line(data = n2_1998_2, aes(y = Median, color = "1998.2"), size = 1.5) +
  scale_color_manual(values = c(
    '1998.1' = 'darkred',
    '1998.2' = 'darkblue')) +
  ggtitle("Effective population size over time") +
  labs(y = "Median EPS", x = "Time", color = "N2 Clade") +
  theme(legend.position = "bottom",
        panel.background = element_rect(fill = "white"),
        panel.grid.major = element_line(colour = "gray90"),
        panel.grid.minor = element_line(colour = "gray90")) +
  scale_x_continuous(minor_breaks = seq(2007 , 2017, 1), breaks = seq(2007, 2017, 2))

#2002
ggplot(n2_2002, aes(x = Time, y = Median)) +
  geom_ribbon(aes(ymin = Lower, ymax = Upper), fill = "red", alpha = 0.5) +
  geom_ribbon(data = n2_2002_2, aes(ymin = Lower, ymax = Upper), fill = "blue", alpha = 0.5) +
  geom_line(aes(y = Median, color = "2002.1"), size = 1.5) +
  geom_line(data = n2_2002_2, aes(y = Median, color = "2002.2"), size = 1.5) +
  scale_color_manual(values = c(
    '2002.1' = 'darkred',
    '2002.2' = 'darkblue')) +
  ggtitle("Effective population size over time") +
  labs(y = "Median EPS", x = "Time", color = "N2 Clade") +
  theme(legend.position = "bottom",
        panel.background = element_rect(fill = "white"),
        panel.grid.major = element_line(colour = "gray90"),
        panel.grid.minor = element_line(colour = "gray90")) +
  scale_x_continuous(minor_breaks = seq(2007 , 2017, 1), breaks = seq(2007, 2017, 2))

#delta2
ggplot(delta2, aes(x = Time, y = Median)) +
  geom_ribbon(aes(ymin = Lower, ymax = Upper), fill = "red", alpha = 0.5) +
  geom_ribbon(data = delta2_2, aes(ymin = Lower, ymax = Upper), fill = "blue", alpha = 0.5) +
  geom_line(aes(y = Median, color = "delta2.1"), size = 1.5) +
  geom_line(data = delta2_2, aes(y = Median, color = "delta2.2"), size = 1.5) +
  scale_color_manual(values = c(
    'delta2.1' = 'darkred',
    'delta2.2' = 'darkblue')) +
  ggtitle("Effective population size over time") +
  labs(y = "Median EPS", x = "Time", color = "N2 Clade") +
  theme(legend.position = "bottom",
        panel.background = element_rect(fill = "white"),
        panel.grid.major = element_line(colour = "gray90"),
        panel.grid.minor = element_line(colour = "gray90")) +
  scale_x_continuous(minor_breaks = seq(2007 , 2017, 1), breaks = seq(2007, 2017, 2))


# A treemap R script produced by the REVIGO server at http://revigo.irb.hr/
# If you found REVIGO useful in your work, please cite the following reference:
# Supek F et al. "REVIGO summarizes and visualizes long lists of Gene Ontology
# terms" PLoS ONE 2011. doi:10.1371/journal.pone.0021800

# author: Anton Kratz <anton.kratz@gmail.com>, RIKEN Omics Science Center, Functional Genomics Technology Team, Japan
# created: Fri, Nov 02, 2012  7:25:52 PM
# last change: Fri, Nov 09, 2012  3:20:01 PM

# -----------------------------------------------------------------------------
# If you don't have the treemap package installed, uncomment the following line:
# install.packages( "treemap" );
library(treemap) 								# treemap package by Martijn Tennekes

# Set the working directory if necessary
# setwd("C:/Users/username/workingdir");

# --------------------------------------------------------------------------
# Here is your data from REVIGO. Scroll down for plot configuration options.

revigo.names <- c("term_ID","description","freqInDbPercent","abslog10pvalue","uniqueness","dispensability","representative");
revigo.data <- rbind(c("GO:0006426","glycyl-tRNA aminoacylation",0.017,2.8539,0.540,0.000,"glycyl-tRNA aminoacylation"),
c("GO:0034641","cellular nitrogen compound metabolic process",25.404,2.0458,0.633,0.630,"glycyl-tRNA aminoacylation"),
c("GO:0090304","nucleic acid metabolic process",19.689,2.7447,0.600,0.455,"glycyl-tRNA aminoacylation"),
c("GO:0009081","branched-chain amino acid metabolic process",0.173,1.3778,0.564,0.643,"glycyl-tRNA aminoacylation"),
c("GO:0006310","DNA recombination",0.656,1.9355,0.683,0.301,"glycyl-tRNA aminoacylation"),
c("GO:0006259","DNA metabolic process",2.603,2.2924,0.666,0.212,"glycyl-tRNA aminoacylation"),
c("GO:0006399","tRNA metabolic process",0.807,1.7258,0.623,0.584,"glycyl-tRNA aminoacylation"),
c("GO:0034033","purine nucleoside bisphosphate biosynthetic process",0.047,1.4522,0.543,0.323,"glycyl-tRNA aminoacylation"),
c("GO:0043038","amino acid activation",0.306,2.3010,0.548,0.603,"glycyl-tRNA aminoacylation"),
c("GO:0006573","valine metabolic process",0.078,2.5850,0.584,0.494,"glycyl-tRNA aminoacylation"),
c("GO:0006515","misfolded or incompletely synthesized protein catabolic process",0.069,1.6402,0.811,0.183,"glycyl-tRNA aminoacylation"),
c("GO:0034660","ncRNA metabolic process",1.813,1.5186,0.671,0.341,"glycyl-tRNA aminoacylation"),
c("GO:0006083","acetate metabolic process",0.009,2.0269,0.683,0.330,"glycyl-tRNA aminoacylation"),
c("GO:0006422","aspartyl-tRNA aminoacylation",0.009,2.5850,0.555,0.642,"glycyl-tRNA aminoacylation"),
c("GO:0006825","copper ion transport",0.069,1.5817,0.949,0.000,"copper ion transport"),
c("GO:0050793","regulation of developmental process",2.577,1.3686,0.801,0.000,"regulation of developmental process"),
c("GO:0000902","cell morphogenesis",1.467,1.3449,0.601,0.683,"regulation of developmental process"),
c("GO:0009653","anatomical structure morphogenesis",3.500,1.3449,0.792,0.514,"regulation of developmental process"),
c("GO:0022603","regulation of anatomical structure morphogenesis",0.522,1.4522,0.764,0.404,"regulation of developmental process"),
c("GO:0048869","cellular developmental process",4.148,1.3298,0.634,0.552,"regulation of developmental process"),
c("GO:0035383","thioester metabolic process",0.151,2.0269,0.692,0.054,"thioester metabolism"),
c("GO:0046483","heterocycle metabolic process",22.969,2.4437,0.760,0.103,"thioester metabolism"),
c("GO:0006725","cellular aromatic compound metabolic process",23.483,2.4318,0.759,0.281,"thioester metabolism"),
c("GO:0035384","thioester biosynthetic process",0.082,2.0269,0.607,0.617,"thioester metabolism"),
c("GO:1901360","organic cyclic compound metabolic process",23.932,2.3768,0.804,0.175,"thioester metabolism"),
c("GO:0009768","photosynthesis, light harvesting in photosystem I",0.095,1.6402,0.843,0.061,"photosynthesis, light harvesting in photosystem I"));

stuff <- data.frame(revigo.data);
names(stuff) <- revigo.names;

stuff$abslog10pvalue <- as.numeric( as.character(stuff$abslog10pvalue) );
stuff$freqInDbPercent <- as.numeric( as.character(stuff$freqInDbPercent) );
stuff$uniqueness <- as.numeric( as.character(stuff$uniqueness) );
stuff$dispensability <- as.numeric( as.character(stuff$dispensability) );

# by default, outputs to a PDF file
pdf( file="revigo_treemap.pdf", width=16, height=9 ) # width and height are in inches

# check the tmPlot command documentation for all possible parameters - there are a lot more
tmPlot(
	stuff,
	index = c("representative","description"),
	vSize = "abslog10pvalue",
	type = "categorical",
	vColor = "representative",
	title = "REVIGO Gene Ontology treemap",
	inflate.labels = FALSE,      # set this to TRUE for space-filling group labels - good for posters
	lowerbound.cex.labels = 0,   # try to draw as many labels as possible (still, some small squares may not get a label)
	bg.labels = "#CCCCCCAA",     # define background color of group labels
												       # "#CCCCCC00" is fully transparent, "#CCCCCCAA" is semi-transparent grey, NA is opaque
	position.legend = "none"
)

dev.off()


######################################################################
# oml4spark_function_run_cross_validation.r
#
# Function to run a k-Fold Cross-Validation using all OML4Spark
# classification algorithms available
#
# Process a Balanced Dataset based on Input
# Dataset and formula.
#
# Input can be HDFS ID, HIVE, IMPALA, Spark DF or R dataframe
#
# Usage: runCrossValidation ( input_xva ,
#                             formula_xval ,
#                             numKFolds = 3 ,
#                             selectedStatistic = 'MathewsCorrCoef' ,
#                             feedback = FALSE ,
#                             legend = ' '
#                           )
#
# Copyright (c) 2020 Oracle Corporation
# The Universal Permissive License (UPL), Version 1.0
#
# https://oss.oracle.com/licenses/upl/
#
#
######################################################################

#######################################
### RUN CROSS-VALIDATION ANALYSIS OF
### MODELS FROM A SPARK DF INPUT
#######################################
# input_xval=balancedData
# formula_xval=formula_class
# numKFolds=3
# selectedStatistic='MathewsCorrCoef'
# feedback = TRUE
# legend=' '

runCrossValidation <- function(input_xval, formula_xval, numKFolds=3, selectedStatistic='MathewsCorrCoef', legend=' ', feedback=FALSE ) {

  # Load functions required
  source ('~/oml4spark_function_confusion_matrix_in_spark.r')
  source ('~/oml4spark_function_build_all_classification_models.r')

  if (grepl(feedback, "FULL", fixed = TRUE))
  {verbose_user <- TRUE
  } else {verbose_user <- FALSE}
  # Create a list of K identical proportions for the number of splits required
  splitProps <- rep(1/numKFolds, times = numKFolds)
  splits <- .jarray(splitProps)
  seed <- .jlong(12345678L)

  # Find the ideal number of Partitions to use when creating the Spark DF
  # To Maximize Spark parallel utilization
  sparkXinst <- as.numeric(spark.property('spark.executor.instances'))
  sparkXcores <- as.numeric(spark.property('spark.executor.cores'))
  ideal_partitions <- sparkXinst*sparkXcores

  # Push the INPUT DATA to Spark (if it's not already)
  # In Case it is a Spark DF already we don't do anything
  if (!((spark.connected()) && (class(input_xval)[1]=="jobjRef"))) {
    # Check if the input if a DFS ID (HDFS)
    if (is.hdfs.id(input_xval)) {
      if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) print('Input is HDFS...processing')
      xval_df <- orch.df.fromCSV(input_xval,
                                 minPartitions = ideal_partitions,
                                 verbose = verbose_user ) # Convert the input HDFS to Spark DF
    } else
      # Check if the input is HIVE and load it into Spark DF
      if ( ore.is.connected(type='HIVE') && (is.ore.frame(input_xval)) ) {
        if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) print('Input is HIVE Table...processing')
        xval_df <- ORCHcore:::.ora.getHiveDF(input_xval@sqlTable)
      } else
        # Check if the input is IMPALA
        if ( ore.is.connected(type='IMPALA') && (is.ore.frame(input_xval)) ) {
          if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) print('Input is IMPALA Table...processing')
          xval_df <- ORCHcore:::.ora.getHiveDF(input_xval@sqlTable)
        } else
          # For R Dataframe it is a two-step process for now
          if (is.data.frame(input_xval)){
            if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) print('Input is R Dataframe...processing')
            xval_hdfs <- hdfs.put(input_xval)
            xval_df <- orch.df.fromCSV(xval_hdfs,
                                       minPartitions = ideal_partitions,
                                       verbose = verbose_user ) # Convert the input HDFS to Spark DF
          }
  } else
    # If it's already a Spark DF then just point to it
  { if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) print('Input is already Spark DF')
    xval_df <- input_xval}

  # Persist the Spark DF for added performance
  orch.df.persist(xval_df, storageLevel = "MEMORY_ONLY", verbose = verbose_user)

  # Split Randomly as a list of K Spark DataFrames
  inputDataSplit <- xval_df$randomSplitAsList( splits , seed)
  # Not super precise....
  if (grepl(feedback, "FULL|TRUE", fixed = TRUE))
    for (i in 1:numKFolds) {print(paste0('Records on K-Fold Slice # ',i,' : ',
                                         inputDataSplit$get(as.integer(i-1))$count()))
    }

  # Cross-Validation Loop will result in a list of Statistics from all Models
  allStats <- list()
  # For each slice of the k-Fold Cross Validation
  for (i in 1:numKFolds) {
    # Take the i-th slice of the Data and use it as Test
    testFold <- inputDataSplit$get(as.integer(i-1))
    # Take the rest of the Splits and apply a UNION on them all to build the Training
    buildFolds <- NULL
    for (j in 1:numKFolds) {
      if (!i==j) {
        if (length(buildFolds) < 1) {
          buildFolds <- inputDataSplit$get(as.integer(j-1))
        } else {buildFolds <- buildFolds$union(inputDataSplit$get(as.integer(j-1))) }
      }
    }
    # Return the counts on the Training and Test datasets
    if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) {
      cat('\nCross-Validation Fold # : ',i)
      cat('\nTraining is : ',buildFolds$count())
      cat('\nTest is : ',testFold$count())
      cat('\nBuilding Models...\n')}
    # Build all Models using the Training and Test
    allClassModels <- list()
    allClassModels <-  buildAllClassificationModels(INPUT_DATA=buildFolds,
                                                    TEST_DATA=testFold,
                                                    formula_class=formula_xval,
                                                    legend=legend,
                                                    feedback=feedback)
    if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) cat('\nComputing Stats...\n')
    # Compute Statistics using the Predictions to create a Confusion Matrix
    allStats[[i]] <- lapply(allClassModels,confusionMatrixInSpark)
  }
  # Available Statistics are
  availableStats <- c('BuildTime','ScoreTime','TP','FP','TN','FN','TPR','FPR','FNR','TNR',
                      'Precision','Accuracy','AUC','PPV',
                      'NPV','DetectionRate','DetectionPrevalence',
                      'BalancedAccuracy','F1Score','Informedness',
                      'MathewsCorrCoef')

  # IDENTIFYING the requested Statistic to use as the best
  ixdStat <- which(availableStats==selectedStatistic)
  # EXTRACT the requested Statistic from All Runs on a Data Frame
  cumStats <- data.frame()
  # Extract the Statistic from each Model into the Data Frame
  # (sapply goes from 1:9 Models without LASSO)
  for (j in 1:numKFolds) {
    cumStats <- rbind(cumStats, as.numeric(sapply(1:length(allStats[[1]]), function(i)
      paste(allStats[[j]][[i]][[3]][1,ixdStat]), simplify = TRUE)))
  }
  # Use the Model names as Column Names
  # (sapply goes from 1:9 Models without LASSO)
  names(cumStats) <- sapply(1:length(allStats[[1]]),
                            function(i) paste(allStats[[1]][[i]][1]), simplify = TRUE)
  # Compute Average of the Selected Statistic across all k-Folds
  finalStatXValidation <- sapply(cumStats,mean)
  # Identify the Best Model Index (maximum Average Statistic)
  idxBestModel <- which.max(finalStatXValidation)
  # Sort Descending of the Selected Statistic Averages
  sortedFinalStatXValidation <-sort(finalStatXValidation, decreasing = TRUE)

  # Capture the Average of all K-Folds for each Model
  # (sapply goes from 1:9 Models without LASSO)
  cumAllStats <- t(sapply(1:length(allStats[[1]]), function(m)
  { allRunsModel <- data.frame()
  allRunsModel <- as.data.frame(t(sapply(1:numKFolds,
                                         function(f) as.numeric(allStats[[f]][[m]][[3]]),
                                         simplify = TRUE)))
  names(allRunsModel) <- availableStats
  return(sapply(allRunsModel, function(l) formatC(mean(l),format='fg', digits=4), simplify = TRUE))
  }, simplify=TRUE) )

  # Add the Model Names
  # (sapply goes from 1:9 Models without LASSO)
  cumAllStats <- cbind(sapply(1:length(allStats[[1]]), function(i) paste(allStats[[1]][[i]][1]),
                              simplify = TRUE),
                       cumAllStats)

  # Sort the entire resulting Dataset using the desired Column
  sortedcumAllStats <-cumAllStats[(sort(cumAllStats[,ixdStat],
                                        decreasing = TRUE,
                                        index.return = TRUE))$ix,]

  return(list(finalStatXValidation,
              idxBestModel,
              sortedFinalStatXValidation,
              sortedcumAllStats))
}

#####################################################
### END CROSS-VALIDATION BEST MODEL IDENTIFICATION
#####################################################


##library(MASS) ## for huber()
##library(limma) ## normexp.signal

#' Normalize microarray quantiles
#'
#' Normalize microarray quantiles using controls extracted (Infinium HumanMethylation450 BeadChip).
#'
#' @param qc.objects A list of outputs from \code{\link{meffil.create.qc.object}()}.
#' @param number.pcs Number of control matrix principal components to adjust for (Default: 2).
#' @param fixed.effects Names of columns in samplesheet that should be included as fixed effects
#' along with control matrix principal components (Default: NULL).
#' @param random.effects Names of columns in samplesheet that should be included as random effects
#' (Default: NULL).
#' @param verbose If \code{TRUE}, then status messages are printed during execution (Default: \code{FALSE}).
#' @return Same list as input with additional elements added for each sample
#' including normalized quantiles needed for normalizing each sample.
#'
#' @export
meffil.normalize.quantiles <- function(qc.objects,
                                       number.pcs=2,
                                       fixed.effects=NULL,
                                       random.effects=NULL,
                                       verbose=F) {

    stopifnot(length(qc.objects) >= 2)
    stopifnot(all(sapply(qc.objects, is.qc.object)))
    stopifnot(number.pcs >= 1)

    ## backwards compatibility
    ## - a previous version of meffil created qc.objects missing basic attributes
    ## fix these objects if they exist
    for (i in 1:length(qc.objects)) {
        if ("origin" %in% names(qc.objects[[i]]))
            qc.objects[[i]]$featureset <- qc.objects[[i]]$chip <- "450k"

        if (any(c("chrX","chrY") %in% names(qc.objects[[i]]$quantiles))) {
            idx <- which(names(qc.objects[[i]]$quantiles) %in% c("chrX","chrY"))
            names(qc.objects[[i]]$quantiles)[idx] <- tolower(names(qc.objects[[i]]$quantiles)[idx])
        }
    }

    if (length(unique(sapply(qc.objects, function(object) object$featureset))) > 1)
        stop(paste("Heterogeneous microarray formats included without a common featureset.",
                   "Need to set the 'featureset' argument when creating QC objects."))

    msg("selecting dye correction reference", verbose=verbose)
    intensity.R <- sapply(qc.objects, function(object) object$intensity.R)
    intensity.G <- sapply(qc.objects, function(object) object$intensity.G)
    valid.idx <- which(intensity.R + intensity.G > 200)
    if (length(valid.idx) == 0) {
        valid.idx <- 1:length(intensity.R)
        warning("All of the microarrays have very low intensity")
    }
    reference.idx <- valid.idx[which.min(abs(intensity.R/intensity.G-1)[valid.idx])]
    dye.intensity <- (intensity.R + intensity.G)[reference.idx]/2

    sex <- sapply(qc.objects, function(obj) obj$predicted.sex)
    sex.summary <- table(sex)
    has.both.sexes <- length(sex.summary) >= 2 & min(sex.summary) > 1

    male.idx <- which(sex == "M")
    female.idx <- which(sex == "F")

    msg("creating control matrix", verbose=verbose)
    design.matrix <- meffil.design.matrix(qc.objects, number.pcs,
                                          fixed.effects=fixed.effects,
                                          random.effects=random.effects)
    if (has.both.sexes) {
        design.male <- meffil.design.matrix(qc.objects[male.idx],
                                            number.pcs=min(number.pcs,
                                                length(male.idx)),
                                            fixed.effects=fixed.effects,
                                            random.effects=random.effects)
        design.female <- meffil.design.matrix(qc.objects[female.idx],
                                              number.pcs=min(number.pcs,
                                                  length(female.idx)),
                                              fixed.effects=fixed.effects,
                                              random.effects=random.effects)
    }

    msg("normalizing quantiles", verbose=verbose)
    subset.names <- names(qc.objects[[1]]$quantiles)
    normalized.quantiles <- sapply(subset.names, function(name) {
        sapply(c("M","U"), function(target) {
            msg(name, target, verbose=verbose)
            original <- sapply(qc.objects, function(object) {
                object$quantiles[[name]][[target]] * dye.intensity/object$dye.intensity
            })

            if (is.sex.specific.subset(name) && has.both.sexes) {
                norm.male <- normalize.quantiles(original[,male.idx,drop=F], design.male)
                norm.female <- normalize.quantiles(original[,female.idx,drop=F], design.female)
                norm <- original
                norm[,male.idx] <- norm.male
                norm[,female.idx] <- norm.female
            }
            else
                norm <- normalize.quantiles(original, design.matrix)
            norm
        }, simplify=F)
    }, simplify=F)

    norm.objects <- lapply(1:length(qc.objects), function(i) {
        object <- qc.objects[[i]]
        object$reference.intensity <- dye.intensity
        subset.names <- applicable.quantile.site.subsets(object$predicted.sex, has.both.sexes)
        object$norm <- sapply(subset.names, function(subset.name) {
            list(M=normalized.quantiles[[subset.name]]$M[,i],
                 U=normalized.quantiles[[subset.name]]$U[,i])
        },simplify=F)

        object
    })
    names(norm.objects) <- sapply(norm.objects, function(object) object$sample.name)
    norm.objects
}

is.normalized.object <- function(object) {
    is.qc.object(object) && "norm" %in% names(object)
}

normalize.quantiles <- function(quantiles, design.matrix) {
    stopifnot(is.matrix(quantiles))

    ## make sure lowest and highest quantiles extreme
    quantiles[1,] <- 0
    safe.increment <- 1000
    quantiles[nrow(quantiles),] <- quantiles[nrow(quantiles)-1,] + safe.increment

    ## adjust mean centered quantiles with fixed and random effects
    mean.quantiles <- rowMeans(quantiles)
    quantiles <- quantiles - mean.quantiles
    norm.quantiles <- meffil:::adjust.columns(t(quantiles),design.matrix$fixed, design.matrix$random)
    norm.quantiles <- mean.quantiles + t(norm.quantiles)

    ## make sure that the quantiles are monotonically increasing, not usually a problem but ...
    for (i in 2:nrow(norm.quantiles))
        norm.quantiles[i,] <- apply(norm.quantiles[(i-1):i,,drop=F], 2, max, na.rm=T)
    norm.quantiles
}


kappa = read.csv("C:\\Users\\gaya\\prog\\workspace\\TutorialRecommender\\tutorials\\annotation\\kappa_scores.txt")

scores = t(cbind(kappa$kappa, kappa$kappa.max))

par(xpd=T, mar=par()$mar+c(0,0,0,13))

barplot(scores, col=heat.colors(2), names.arg=kappa$tutorial, beside = TRUE, cex.names=0.8, ylim = c(0,1))

# Place the legend at (6,30) using heat colors
legend(19, 1, c("kappa", "kappa.max"), cex=0.8, fill=heat.colors(2));

# Restore default clipping rect
par(mar=c(5, 4, 4, 2) + 0.1)


\name{colorRamp2}
\alias{colorRamp2}
\title{
Color interpolation
}
\description{
Color interpolation
}
\usage{
colorRamp2(breaks, colors, transparency = 0, space = "LAB")
}
\arguments{

  \item{breaks}{A vector indicating numeric breaks}
  \item{colors}{A vector of colors which correspond to values in \code{breaks}}
  \item{transparency}{A single value in \code{[0, 1]}. 0 refers to no transparency and 1 refers to full transparency}
  \item{space}{color space in which colors are interpolated. Value should be one of "RGB", "HSV", "HLS", "LAB", "XYZ", "sRGB", "LUV", see \code{\link[colorspace]{color-class}} for detail.}

}
\details{
Colors are linearly interpolated according to break values and corresponding colors through CIE Lab color space (\code{\link[colorspace]{LAB}}) by default.
Values exceeding breaks will be assigned with corresponding maximum or minimum colors.
}
\value{
It returns a function which accepts a vector of numeric values and returns interpolated colors.
}
\seealso{
\code{\link{col2value}} converts back to the original values by providing the color mapping function generated by \code{\link{colorRamp2}}.
}
\references{
Gu, Z. (2014) circlize implements and enhances circular visualization in R. Bioinformatics.

}
\examples{
col_fun = colorRamp2(c(-1, 0, 1), c("green", "white", "red"))
col_fun(c(-2, -1, -0.5, 0, 0.5, 1, 2))
}


#' @title lettersToNumbers
#' @description replaces all letters (lower and upper case) with associated digits (A-Z 1-26) the better way!
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
lettersToNumbers <- function(x) {
  dframe <- data.frame(l=c(letters[],LETTERS[]),num=rep(1:length(letters[]),2))
  return(as.character(dframe[match(x,dframe$l),"num"]))
}


#!/usr/local/bin/Rscript
library(ggplot2)
library(plyr)

default_filename <- 'data/cat_20190205_flower_E6.csv'
out_dir <- 'E6_learning_curves'

# accept a filename as an optional command-line argument
args <- commandArgs(trailingOnly=T)
if (length(args) < 1) {
    args <- c(default_filename)
}

learning_curve <- function(trials, feature=NULL, value=NULL) {
    # subset the data
    fname <- paste(out_dir, 'curve', sep='/')
    if (!is.null(feature)) {
        fname <- paste(fname, '-', feature, sep='')
        trials <- subset(trials, featureLearned==feature)
        if (!is.null(value)) {
            fname <- paste(fname, '-', value, sep='')
            trials <- subset(trials, valueLearned==value)
        }
    }

    nSubj <- length(unique(trials$subject))
    nTrials <- nrow(subset(trials, subject==trials$subject[1]))
    trials$trialNum <- rep(1:nTrials, times=nSubj)

    png(paste(fname, '.png', sep=''), height=500, width=1000)
    print(ggplot(ddply(trials, c("trialNum", "isInstructed"), summarise, N=length(wasCorrect),
                       rate=mean(wasCorrect), sd=sd(wasCorrect), se=(sd/sqrt(N)))) +
          aes(x=trialNum, y=rate, color=isInstructed,group=isInstructed,fill=isInstructed) +
          stat_smooth(method="loess", span=0.1, se=TRUE, alpha=0.3) + theme_classic() +
          xlab('Trial') + ylab('Categorization Accuracy') +
          theme(axis.text=element_text(size=20),
                axis.title.x=element_text(size=36, margin=margin(t=0.5, unit='cm')),
                axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
                legend.title=element_blank(),
                legend.text=element_text(size=20),
                plot.margin=margin(t=1, b=1, unit='cm')))
    dev.off()
}

# analyze data from each file
for (i in 1:length(args)) {
    filename <- args[i]
    writeLines(args[i])

    # import the data
    memData <- subset(read.csv(filename, header=T), task=='test')
    memData$RT <- memData$RT / 1000

    writeLines(sprintf('Total number of subjects: %d', length(unique(memData$subject))))

    ## exclude subjects with or low learning accuracy
    learnData <- subset(read.csv(filename, header=T), task=='learn' & isPracticed==1)
    endAcc <- aggregate(wasCorrect~subject, learnData, function (trials) mean(tail(trials, 20)))
    excluded = endAcc$subject[endAcc$wasCorrect < 0.85]
    memData <- memData[!(memData$subject %in% excluded),]
    learnData <- learnData[!(learnData$subject %in% excluded),]
    writeLines(sprintf('After exclusion: %d', length(unique(memData$subject))))

    learnData$isInstructed <- as.factor(sapply(learnData$isInstructed,
                                               function (i) {
                                                   if (i) ' Instructed'
                                                   else ' Not Instructed'
                                               }))

    learning_curve(learnData)

    for (feature in unique(learnData$featureLearned)) {
        learning_curve(learnData, feature)
        for (value in unique(subset(learnData, featureLearned==feature)$valueLearned))
            learning_curve(learnData, feature, value)
    }

}


#!/usr/bin/Rscript

library(ncdf4)
library(raster)
library(rgdal)
require(zoo)

#############################
### FUNCTIONS
#############################
setwd("/mnt/R")

# Get list of species in the file
get_spec_list=function(input){
  spec=ncvar_get(nc=input,varid="name_fspec")
  nvar = nchar(spec)/4
  stseq=seq(from=1,to=nchar(spec),by=4)
  snpfn = function(st){substr(spec,st,st+3)}
  unlist(lapply(stseq,FUN=snpfn))
}

# Drill down a time series for given species and location
drill_spec=function(input,spec,lat,lon){
  sl = get_spec_list(input)
  vno = which(sl %in% spec)
  if(length(vno)==0){
    stop(paste0("Chemical species ",spec," not found."))
  }
  odat=ncvar_get(nc=input,varid="cavg")
  lons=ncvar_get(input,"lon")
  lats=ncvar_get(input,"lat")
  if(lat < min(lat) | lat > max(lat) | lon < min(lon) | lon > max(lon)){
    stop("Coordinates provided are out of range of grid.")
  }
  tlon=which.min(abs(lons-lon))
  tlat=which.min(abs(lats-lat))
  odat=odat[tlon,tlat,vno,]
  odat
}

# Return a map raster for a given hour and species
rast_spec=function(input,spec,hour){
  sl = get_spec_list(input)
  vno = which(sl %in% spec)
  if(length(vno)==0){
    stop(paste0("Chemical species ",spec," not found."))
  }
  if(hour > 24){
    stop(paste0("Hour must be between 1 and 24"))
  }
  odat=ncvar_get(nc=input,varid="cavg")
  lons=ncvar_get(input,"lon")
  lats=ncvar_get(input,"lat")
  lodiff=mean(diff(lons))
  ladiff=mean(diff(lats))

  odat=odat[,,vno,hour]
  rotm <- function(x) t(apply(x, 2, rev))
  odat=rotm(rotm(rotm(odat)))
  ra=raster(odat,xmn=min(lons)-(lodiff/2),xmx=max(lons)+(lodiff/2),ymn=min(lats)-(ladiff/2),ymx=max(lats)+(ladiff/2))
  proj4string(ra)="+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs "
  ra
}

# Return a 3D matrix for a given hour and species
cube_spec=function(input,spec){
  sl = get_spec_list(input)
  vno = which(sl %in% spec)
  if(length(vno)==0){
    stop(paste0("Chemical species ",spec," not found."))
  }

  odat=ncvar_get(nc=input,varid="cavg",c(1,1,vno,1),c(-1,-1,1,-1))

    odat
}

# Return a 3D matrix for a given hour and species
cube_met=function(input,spec){

  odat=ncvar_get(nc=input,varid=spec,c(1,1,1),c(-1,-1,-1))

  odat
}

cube_layer=function(input,spec,layer){

  odat=ncvar_get(nc=input,varid=spec,c(1,1,layer,1),c(-1,-1,-1,-1))

  odat
}

difun=function(x){rollmean(x,2)}

#########################
####  Examples ##########
#########################

data <- nc_open("aqfx/vtas.nc")

unlink("aqfx_done/vtas_01.nc")
file.rename("aqfx_done/vtas_02.nc","aqfx_done/vtas_01.nc")
file.rename("aqfx_done/vtas_03.nc","aqfx_done/vtas_02.nc")
file.rename("aqfx_done/vtas_04.nc","aqfx_done/vtas_03.nc")
file.rename("aqfx_done/vtas_05.nc","aqfx_done/vtas_04.nc")
file.rename("aqfx_done/vtas_06.nc","aqfx_done/vtas_05.nc")
file.rename("aqfx_done/vtas_07.nc","aqfx_done/vtas_06.nc")

#PM25
datPM25 = cube_met(data,"PM25")[,,1:24]
datOzone = cube_met(data,"Ozone")[,,1:24]
datLevo = cube_met(data,"Levo")[,,1:24]
datAOD = cube_met(data,"AOD")[,,1:24]

times = 0:23
tdate = Sys.Date()
year = as.numeric(format(tdate,"%Y"))
month= as.numeric(format(tdate,"%m"))
day = as.numeric(format(tdate,"%d"))
adate = as.numeric(as.POSIXct(sprintf("%d-%d-%d %d:00:00",year,month,day,times)))

lats = ncvar_get(data,"lat")
lons = ncvar_get(data,"lon")

dimTime <- ncdim_def("time","seconds since 1970-1-1 00:00:00",adate,longname="time",unlim=TRUE)
dimLat <- ncdim_def("lat","degrees_north",lats,longname="latitude")
dimLon <- ncdim_def("lon","degrees_east",lons,longname="longitude")

varPM25<- ncvar_def("PM25","ugm3",list(dimLon,dimLat,dimTime),longname="PM25 Concentration",prec="float")
varOzone<- ncvar_def("Ozone","ppb",list(dimLon,dimLat,dimTime),longname="Ozone Concentration",prec="float")
varLevo<- ncvar_def("Levo","ugm3",list(dimLon,dimLat,dimTime),longname="Levoglucosan Concentration",prec="float")
varAOD<- ncvar_def("AOD","ExC",list(dimLon,dimLat,dimTime),longname="Aerosol Optical Depth",prec="float")

new_file = nc_create("aqfx_done/vtas_07.nc",list(varPM25,varOzone,varLevo, varAOD))

ncatt_put(new_file,0,attname="CDI",attval="Climate Data Interface version 1.7.2 (http://mpimet.mpg.de/cdi")
ncatt_put(new_file,0,attname="CDO",attval="Climate Data Operators version 1.7.2 (http://mpimet.mpg.de/cdo)")
ncatt_put(new_file,0,attname="Conventions",attval="CF-1.4")

ncvar_put(new_file,varPM25,datPM25)
ncvar_put(new_file,varOzone,datOzone)
ncvar_put(new_file,varLevo,datLevo)
ncvar_put(new_file,varAOD,datAOD)

nc_close(new_file)

cmd="cdo -O mergetime aqfx_done/vtas_*.nc aqfx_done/merge_vtas.nc"
system(cmd)

source("../config.r")
system(geopw)


get_AIbiom<-function(species=21740){

  test<-paste("SELECT AI.BIOMASS_INPFC.SURVEY,\n ",
    "AI.BIOMASS_INPFC.YEAR,\n ",
    "AI.BIOMASS_INPFC.SUMMARY_AREA,\n ",
    "AI.BIOMASS_INPFC.SPECIES_CODE,\n ",
    "AI.BIOMASS_INPFC.AREA_BIOMASS,\n ",
    "AI.BIOMASS_INPFC.BIOMASS_VAR,\n ",
    "AI.BIOMASS_INPFC.AREA_POP,\n ",
    "AI.BIOMASS_INPFC.POP_VAR\n ",
    "FROM AI.BIOMASS_INPFC\n ",
   "WHERE AI.BIOMASS_INPFC.SUMMARY_AREA != 799\n ",
   "AND AI.BIOMASS_INPFC.SPECIES_CODE    = ",species,"\n",
   "ORDER BY AI.BIOMASS_INPFC.YEAR,\n ",
   "AI.BIOMASS_INPFC.SUMMARY_AREA ",sep="")

  Biom=sqlQuery(AFSC,test)
  Biom
  }


# Parse arguments
# args:
# in1, in2, in3, ...

args = commandArgs(trailingOnly = TRUE)
print(args)

trace = read.table("trace.txt", header=F, sep="~");
names(trace)=c("inst");

# Find and mark instruction types\
trace$p = with(trace, grepl("PULL .*", inst));
trace$pc = with(trace, grepl("PULL_CP .*", inst));
trace$t = with(trace, grepl("TUCK .*", inst));
trace$tc = with(trace, grepl("TUCK_CP .*", inst));
trace$s = with(trace, grepl("SWAP .*", inst));
trace$d = with(trace, grepl("DROP .*", inst));
trace$o = !(trace$p | trace$pc | trace$t | trace$tc | trace$s | trace$d)

# Count each instruction type
ni = sum(!is.na(trace$inst));
np = sum(trace$p);
npc = sum(trace$pc);
nt = sum(trace$t);
ntc = sum(trace$tc);
ns = sum(trace$s);
nd = sum(trace$d);
no = sum(trace$o);

# Calculate ratios of each instruction type
rp = np/ni;
rpc = npc/ni;
rt = nt/ni;
rtc = ntc/ni;
rs = ns/ni;
rd = nd/ni;
ro = no/ni;

# Create a table of histogram values to plot
benchmarkNames = c("factorial")
hdata = data.frame(benchmarkNames)
names(hdata) = c("trace")
hdata$p=c(rp)
hdata$pc=c(rpc)
hdata$t=c(rt)
hdata$tc=c(rtc)
hdata$s=c(rs)
hdata$d=c(rd)
hdata$o=c(ro)
hdata$trace=NULL

# Expand to the right to make room for the legend
par(xpd=T, mar=par()$mar+c(0,0,0,4))

# Graph autos (transposing the matrix) using heat colors,
# put 10% of the space between each bar, and make labels
# smaller with horizontal y-axis labels
barplot(	t(hdata),
			main="Trace",
			ylab="% of instructions",
			col=heat.colors(7),
			space=0.1,
			cex.axis=0.8,
			las=1,
			names.arg=benchmarkNames,
			cex=0.8)

# Place the legend at (6,30) using heat colors
legend(1.15, 1, c("PULL", "PULL_CP", "TUCK", "TUCK_CP", "SWAP", "DROP", "(non-stack)"), cex=0.8, heat.colors(7))

# Restore default clipping rect
par(mar=c(5, 4, 4, 2) + 0.1)


#' K-means clusterization for survival data
#'
#' Clusterization of survival data using `kml` and `survival`. This function
#' identify clusters of data that behaves similarly with regard to the hazard
#' function.
#'
#' @param n_clusters number of clusters, as defined in `kml::kml`.
#' @inheritParams surv_extract_km
#'
#' @return a data.frame with the resulting groups.
#'
#' @export
#'
surv_cluster <- function(aj, n_clusters) {
  km <- as.data.frame(
    tidyr::pivot_wider(
      dplyr::select(
        surv_extract(aj),
        !surv
      ),
      names_from = "time",
      values_from = "wx"
    )
  )
  names(km) <- c("id", paste("t", 1:(ncol(km) - 1)))
  km_cld <- kml::cld(km)
  option <- kml::parALGO(saveFreq = Inf, distanceName = "canberra")
  # prevent annoying print
  invisible(
    utils::capture.output(
      kml::kml(km_cld, nbRedrawing = 1, nbClusters = n_clusters, parAlgo = option)
    )
  )
  aux_cluster <- paste0("c", n_clusters)
  ret <- data.frame(
    id = km_cld["idFewNA"],
    cluster = km_cld[aux_cluster][[1]]["clusters"]
  )
  names(ret) <- c("id", "idCluster")
  return(ret)
}

#' Add the clusterization results to the full data
#'
#' @param data data.frame with the full data to wich the clusterized column will be added.
#' @param cluster_res export of the `surv_cluster` function, usually with only one covariate.
#' @param id name of the unclusterized column, used in the join.
#' @param name_to name of the clusterized column.
#'
#' @return a data.frame with the same columns as the input, plus the cluster column.
#'
#' @export
#'
add_cluster <- function(data, cluster_res, id, name_to = paste0(id, "Cluster")) {

  by <- c("id")
  names(by) <- id

  full_data <- dplyr::left_join(data,cluster_res,by = by)

  names(full_data)[names(full_data) == "idCluster"] <- name_to

  return(full_data)
}


library(pROC)
library(cowplot)
source(file.path(PROJECT_DIR, "R/functions/get_score.r"))

# load CD38 signature genes
fn.sig = file.path(PROJECT_DIR, "generated_data", "signatures", "IFN26_ge_sig.txt")
gene.sig = fread(fn.sig, header = F) %>% unlist(use.names=F)

# load gene expression data
fn.ge = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_GE_matrix_gene.txt")
dat = fread(fn.ge, data.table = F) %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("gene") %>%
  data.matrix()

fn.si = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_sample_info_2_CD38hi.txt")
info = fread(fn.si, data.table=F)
info = info %>% mutate(Response = factor(Response, levels=c("low","high")))

roc.df = data.frame()
df = data.frame()
df.text = data.frame()

for (tp in c(0,-7,70)) {
  si = with(info, time == tp)# & !is.na(CD38hi))
  sum(si)
  tdat = dat[,si]
  tinfo = info[si,]

  day.pt = case_when(
    tp == 0 ~ "Baseline 1 (day 0)",
    tp == -7 ~ "Baseline 2 (day -7)",
    tp == 70 ~ "Baseline 3 (day 70)"
  )

  gi = toupper(rownames(tdat)) %in% toupper(gene.sig)
  sum(gi)

  ihl = tinfo$Response %in% c("low","high")
  X = get_score(tdat[gi,])[ihl]
  Y = tinfo$Response[ihl]

  r = roc(Y,X, direction="<", quiet = T)
  r.df = data.frame(day.label=day.pt, Specificity = r$specificities, Sensitivity=r$sensitivities) %>%
    arrange(Sensitivity)

  roc.df = rbind(roc.df, r.df)

  w.pv = wilcox.test(X[Y=="low"], X[Y=="high"], exact=F)$p.value

  df.text = rbind(df.text,
                  data.frame(day.label = day.pt, label.auc=sprintf("AUC = %.2f", r$auc),
                             label.w.pv=sprintf("p = %.2g",w.pv)))

  tmp = data.frame(day = paste0("day ", tp), day.label=day.pt, subject=tinfo$subject[ihl], score=X, Response=factor(Y))
  df = rbind(df, tmp)
}

df.text$x = rep(0.25, 3)
df.text$y = rep(0.1, 3)

roc.df = roc.df %>%
  mutate(day = factor(day.label))
df = df %>%
  mutate(day.label = factor(day.label))

# output scores
fn.out = file.path(PROJECT_DIR, "generated_data", "IFN26", "CHI_IFN26_ge_sig_score.txt")
fwrite(df %>% dplyr::select(-day.label), fn.out, sep="\t", quote=T)

# Generate boxplots
p1 = ggplot(df, aes(x=Response, y=score, group=Response)) +
  geom_boxplot(aes(fill=day.label), alpha=1, outlier.colour = NA) +
  geom_dotplot(binaxis = "y", stackdir = "center", aes(fill=Response)) +
  facet_wrap(~day.label, nrow=1) +
  scale_fill_manual(values=c("grey70", "grey90","grey50", "black", "white"), name="Response",
                    breaks=c(0,2), labels=c("low","high")) +
  geom_text(data = df.text, aes(label=label.w.pv), x=1.5, y=Inf,vjust=1.1, hjust=0.5, size=4, inherit.aes = F) +
  xlab("Response") + ylab("Baseline signature score") +
  coord_cartesian(xlim=c(0.8, 2.2)) +
  theme_bw() + theme(legend.position="none") +
  theme(panel.border = element_blank(), strip.background = element_blank(),
        strip.text.x = element_text(size=12),
        panel.spacing = unit(0,"mm"), panel.grid.major.x = element_blank(),
        axis.ticks = element_blank())

p2 = list()
for(tm in levels(df.text$day.label)) {
  p2[[tm]] = ggplot(roc.df %>% dplyr::filter(day.label==tm), aes(x=Specificity, y=Sensitivity)) +
    geom_line(size=1) +
    geom_abline(intercept = 1, slope = 1, lty=2) +
    scale_x_reverse() +
    geom_text(data=df.text %>% dplyr::filter(day.label==tm), aes(x=x,y=y,label=label.auc)) +
    coord_fixed() +
    theme_bw() + theme(panel.grid = element_blank())
}

bottom_row <- do.call("plot_grid", c(p2, align = "h", nrow=1))
plot_grid(p1, bottom_row, ncol=1, rel_heights = c(2, 1))

fn.fig = file.path(PROJECT_DIR, "figure_generation", "IFN26", "CHI_IFN.26gene.sig_vs_response_3time")
ggsave(paste0(fn.fig, ".png"), w=7,h=7)
ggsave(paste0(fn.fig, ".pdf"), w=7,h=7)