library(randtoolbox)
library(dplyr)
library(tidyr)
library(rsm)
library(DiceKriging)
library(DiceOptim)
library(future.apply)

plan(multiprocess, workers = 40)

args = commandArgs(trailingOnly = TRUE)

quiet <- function(x) {
  sink(tempfile())
  on.exit(sink())
  invisible(force(x))
}

iterations <- 1

results <- NULL

# Resnet50
sobol_dim <- 54 * 1

# vgg19
# sobol_dim <- 19 * 2

starting_sobol_n <- (1 * sobol_dim) + 10
sobol_n <- starting_sobol_n

bit_min <- 1
bit_max <- 8
perturbation_range <- 2 * (bit_min / bit_max)

gpr_added_points <- 3
gpr_added_neighbours <- 3
gpr_neighbourhood_factor <- 500

EI_backlog <- NULL
EI_backlog_size <- 200

gpr_total_selected_points <- 1
gpr_iterations <- 245 - starting_sobol_n

gpr_sample_size <- 60 * sobol_dim

total_measurements <- starting_sobol_n + (gpr_iterations * gpr_total_selected_points)

network <- "resnet50"
network_sizes_data <- "network_sizes_data.csv"

preserve_ratio <- 0.1
batch_size <- 128
cuda_device <- as.integer(args[1])
resume_run_id <- as.integer(args[2])
resume_run_path <- args[3]

print(paste("Args:", args))
print(paste("Restoring from chosen path:",
            resume_run_path))

network_sizes <- read.csv(network_sizes_data)
network_specs <- network_sizes %>%
    filter(id == network)

design <- NULL
gpr_model <- NULL
df_design <- NULL
current_results <- NULL
size_df <- NULL
coded_size_df <- NULL
new_sample <- NULL
perturbation <- NULL
gpr_sample <- NULL
search_space <- NULL

# size_ratio: \in [0.0, 1.0], typical \in [0.1, 0.2]
# top1: \in [0.0, 100.0], typical \in [50, 95]
# top5: \in [0.0, 100.0], typical \in [65, 95]

size_weight <- 0.0
top1_weight <- 0.0
top5_weight <- 1.0

min_ratio <- 0.06

weights <- read.csv("resnet50_sizes.csv", header = TRUE)

sobol_partial <- 900000
sobol_neighbourhood_partial <- 500000
perturbed_sample_multiplier <- ceiling(sobol_neighbourhood_partial / gpr_added_points)

size_limits <- c(10.0, 1.0)

timing_info <- NULL

compute_size <- function(n, sample){
    as.numeric(weights[1,]) %*% (trunc(8 * as.numeric(sample[n, ])) + 1)
}

row_compute_size <- function(sample){
    as.numeric(weights[1,]) %*% (trunc(8 * as.numeric(sample)) + 1)
}

generate_filtered_sample <- function(size, sobol_n, limits){
    temp_sobol <- sobol(n = sobol_n,
                        dim = sobol_dim,
                        scrambling = 2,
                        seed = as.integer((99999 - 10000) * runif(1) + 10000),
                        init = TRUE)

    sobol_size <- sobol_n
    samples <- NULL
    filtered_samples = 0

    while(filtered_samples < size){
        print(paste("Current filtered samples:",
                    filtered_samples))
        design <- sobol(n = sobol_size,
                        dim = sobol_dim,
                        scrambling = 2,
                        seed = as.integer((99999 - 10000) * runif(1) + 10000),
                        init = FALSE)

        print("Generated design")

        sobol_size <- sobol_size * 2

        # Sequential apply
        # sizes <- sapply(1:length(design[,1]), compute_size, design)

        sizes <- future_apply(design, 1, row_compute_size)

        print("Applied filter")
        selected <- ((sizes / 8e6) < limits[1] & (sizes / 8e6) > limits[2])

        print("Selected valid samples")

        samples <- data.frame(design[selected, ])
        filtered_samples = length(samples[, 1])
        rm(design)
    }

    return(sample_n(samples, size))
}

perturb_filtered_sample <- function(sample, size, sobol_n, range, limits){
    temp_sobol <- sobol(n = sobol_n,
                        dim = sobol_dim,
                        scrambling = 2,
                        seed = as.integer((99999 - 10000) * runif(1) + 10000),
                        init = TRUE)

    sobol_size <- sobol_n
    samples <- NULL
    filtered_samples <- 0

    while(filtered_samples < size){
        print(paste("Current filtered samples:",
                    filtered_samples))
        perturbation <- sobol(n = sobol_size,
                              dim = sobol_dim,
                              scrambling = 2,
                              seed = as.integer((99999 - 10000) * runif(1) + 10000),
                              init = FALSE)

        print("Generated design")

        sobol_size <- sobol_size * 2

        perturbation <- data.frame(perturbation)
        perturbation <- (2 * range * perturbation) - range
        perturbed <- sample + perturbation

        perturbed[perturbed < 0.0] <- 0.1
        perturbed[perturbed > 1.0] <- 0.9

        sample <- bind_rows(sample, sample)

        # Sequential apply
        # sizes <- sapply(1:length(perturbed[, 1]), compute_size, perturbed)

        sizes <- future_apply(perturbed, 1, row_compute_size)

        print("Applied filter")
        selected <- ((sizes / 8e6) < limits[1] & (sizes / 8e6) > limits[2])

        samples <- data.frame(perturbed[selected, ])
        filtered_samples <- length(samples[, 1])

        rm(perturbed)
        rm(perturbation)
    }

    return(sample_n(samples, size))
}

performance <- function(size_ratio, top1, top5){
    return(((size_weight * (size_ratio - min_ratio) ^ 2) +
            (top1_weight * ((100.0 - top1) / 100.0)) +
            (top5_weight * ((100.0 - top5) / 100.0))) /
           (size_weight + top1_weight + top5_weight))
}

for(i in 1:iterations){
    if(!(is.null(gpr_sample))){
        rm(gpr_sample)
        quiet(gc())
        gpr_sample <- NULL
    }
    if(!(is.null(search_space))){
        rm(search_space)
        quiet(gc())
        search_space <- NULL
    }

    start_time <- as.integer(format(Sys.time(), "%s"))

    temp_sobol <- sobol(n = sobol_n,
                        dim = sobol_dim,
                        scrambling = 2,
                        seed = as.integer((99999 - 10000) * runif(1) + 10000),
                        init = TRUE)

    rm(temp_sobol)
    quiet(gc())

    if(i == 1 && resume_run_id != -1){
        print(paste("Resuming run:", resume_run_id))
        run_id <- resume_run_id
        initial_design_time <- -1
        initial_design_measure_time <- -1
    } else{
        run_id <- round(100000 * runif(1))

        if(!(is.null(design))){
            rm(design)
            quiet(gc())
            design <- NULL
        }

        initial_design_start_time <- proc.time()

        design <- generate_filtered_sample(sobol_n,
                                           sobol_partial,
                                           size_limits)

        initial_design_time <- (proc.time() - initial_design_start_time)[["elapsed"]]

        if(!(is.null(df_design))){
            rm(df_design)
            quiet(gc())
            df_design <- NULL
        }

        df_design <- design

        # names(df_design) <- c(rbind(paste("W",
        #                                   seq(1:(sobol_dim / 2)),
        #                                   sep = ""),
        #                             paste("A",
        #                                   seq(1:(sobol_dim / 2)),
        #                                   sep = "")))

        write.csv(df_design,
                  paste("current_design_",
                        run_id,
                        ".csv",
                        sep = ""),
                  row.names = FALSE)

        initial_design_measure_start_time <- proc.time()

        cmd <- paste("CUDA_VISIBLE_DEVICES=",
                     cuda_device,
                     " python3 -W ignore rl_quantize.py --arch ",
                     network,
                     " --dataset imagenet --dataset_root data",
                     " --suffix ratio010 --preserve_ratio ",
                     preserve_ratio,
                     " --n_worker 120 --warmup -1 --train_episode ",
                     sobol_n,
                     " --finetune_flag",
                     " --no-baseline",
                     " --use_top1",
                     " --run_id ",
                     run_id,
                     " --data_bsize ",
                     batch_size,
                     " --optimizer RS --val_size 10000",
                     " --train_size 20000",
                     sep = "")

        print(cmd)
        system(cmd)

        initial_design_measure_time <- (proc.time() -
                                        initial_design_measure_start_time)[["elapsed"]]

        system("rm -r ../../save")
    }

    if(!(is.null(current_results))){
        rm(current_results)
        quiet(gc())
        current_results <- NULL
    }

    if(!is.na(resume_run_path)){
        print(paste("Resuming run at path:", resume_run_path))
        current_results <- read.csv(resume_run_path,
                                    header = TRUE)
    } else{
        current_results <- read.csv(paste("current_results_",
                                          run_id,
                                          ".csv",
                                          sep = ""),
                                    header = TRUE)
    }

    if(is.null(search_space)){
        search_space <- current_results
    } else{
        search_space <- bind_rows(search_space, current_results) %>%
            distinct()
    }

    write.csv(search_space,
              paste("gpr_",
                    total_measurements,
                    "_samples_",
                    i,
                    "_iteration_id_",
                    run_id,
                    "_search_space.csv",
                    sep = ""),
              row.names = FALSE)

    for(j in 1:gpr_iterations){
        print("Starting reg")

        if(!(is.null(size_df))){
            rm(size_df)
            quiet(gc())
            size_df <- NULL
        }

        print("Search space:")
        print(str(search_space))

        if(!(is.null(gpr_model))){
            rm(gpr_model)
            quiet(gc())
            gpr_model <- NULL
        }

        y <- performance(search_space$SizeRatio, search_space$Top1, search_space$Top5)

        model_fit_start_time <- proc.time()

        gpr_model <- km(formula = ~ .,
                        design = select(search_space, -Top5, -Top1, -Size, -SizeRatio),
                        response = y,
                        nugget = 1e-8 * var(y),
                        control = list(pop.size = 400,
                                       BFGSburnin = 500))

        model_fit_time <- (proc.time() -
                           model_fit_start_time)[["elapsed"]]

        print("Generating Sample")

        ei_design_start_time <- proc.time()

        new_sample <- generate_filtered_sample(gpr_sample_size,
                                               sobol_partial,
                                               size_limits)

        ei_design_time <- (proc.time() -
                           ei_design_start_time)[["elapsed"]]

        gpr_sample <- new_sample %>%
            distinct()

        if(!is.null(EI_backlog)){
            gpr_sample <- bind_rows(gpr_sample,
                                    EI_backlog) %>%
                distinct()
        }

        rm(new_sample)
        quiet(gc())
        new_sample <- NULL

        print("Computing EI")
        print(nrow(gpr_sample))

        ei_compute_start_time <- proc.time()

        # Using the EI function from DiceOptim:
        gpr_sample$expected_improvement <- future_apply(gpr_sample,
                                                        1,
                                                        EI,
                                                        gpr_model)

        ei_compute_time <- (proc.time() -
                            ei_compute_start_time)[["elapsed"]]

        gpr_selected_points <- gpr_sample %>%
            arrange(desc(expected_improvement))

        # Using mean - 2 * sigma:
        # pred <- predict(gpr_model, gpr_sample, "UK")
        # gpr_sample$expected_improvement <- pred$mean - (1.96 * pred$sd)

        # gpr_selected_points <- gpr_sample %>%
        #     arrange(expected_improvement)

        gpr_sample <- select(gpr_sample, -expected_improvement)

        # gpr_selected_points <- select(gpr_selected_points[1:gpr_added_points, ],
        #                               -expected_improvement)

        gpr_selected_points <- select(gpr_selected_points[1:gpr_added_points, ],
                                      -expected_improvement)

        print("Generating perturbation sample")

        if(!(is.null(perturbation))){
            rm(perturbation)
            quiet(gc())
            perturbation <- NULL
        }

        perturbation <- gpr_selected_points %>%
            slice(rep(row_number(),
                      perturbed_sample_multiplier)) %>%
            slice(1:sobol_neighbourhood_partial)

        neighbour_ei_design_start_time <- proc.time()

        perturbation <- perturb_filtered_sample(perturbation,
                                                gpr_added_points * gpr_neighbourhood_factor,
                                                sobol_neighbourhood_partial,
                                                perturbation_range,
                                                size_limits)

        neighbour_ei_design_time <- (proc.time() -
                                     neighbour_ei_design_start_time)[["elapsed"]]

        gpr_selected_neighbourhood <- perturbation

        gpr_selected_points <- bind_rows(gpr_selected_points,
                                         gpr_selected_neighbourhood)

        gpr_selected_points <- gpr_selected_points %>%
            distinct()

        print("Computing perturbed EI")
        print(nrow(gpr_selected_points))

        neighbour_ei_compute_start_time <- proc.time()

        # Using EI from DiceOptim:
        gpr_selected_points$expected_improvement <- future_apply(gpr_selected_points,
                                                                 1,
                                                                 EI,
                                                                 gpr_model)

        neighbour_ei_compute_time <- (proc.time() -
                                      neighbour_ei_compute_start_time)[["elapsed"]]

        gpr_selected_points <- gpr_selected_points %>%
            arrange(desc(expected_improvement))

        # Using mean - 2 * sigma:
        # pred <- predict(gpr_model, gpr_selected_points, "UK")
        # gpr_selected_points$expected_improvement <- pred$mean - (1.96 * pred$sd)

        # gpr_selected_points <- gpr_selected_points %>%
        #     arrange(expected_improvement)

        # gpr_selected_points <- select(gpr_selected_points[1:(gpr_added_points +
        #                                                      gpr_added_neighbours), ],
        #                               -expected_improvement)

        EI_backlog <- select(gpr_selected_points[1:EI_backlog_size, ],
                             -expected_improvement)

        gpr_selected_points <- select(gpr_selected_points[1:gpr_total_selected_points, ],
                                      -expected_improvement)

        df_design <- data.frame(gpr_selected_points)

        write.csv(df_design,
                  paste("current_design_",
                        run_id,
                        ".csv",
                        sep = ""),
                  row.names = FALSE)

        neighbour_design_measure_start_time <- proc.time()

        cmd <- paste("CUDA_VISIBLE_DEVICES=",
                     cuda_device,
                     " python3 -W ignore rl_quantize.py --arch ",
                     network,
                     " --dataset imagenet --dataset_root data",
                     " --suffix ratio010 --preserve_ratio ",
                     preserve_ratio,
                     " --n_worker 120 --warmup -1 --train_episode ",
                     #gpr_added_points + gpr_added_neighbours,
                     gpr_total_selected_points,
                     " --finetune_flag",
                     " --no-baseline",
                     " --use_top1",
                     " --run_id ",
                     run_id,
                     " --data_bsize ",
                     batch_size,
                     " --optimizer RS --val_size 10000",
                     " --train_size 20000",
                     sep = "")

        print(cmd)
        system(cmd)

        neighbour_design_measure_time <- (proc.time() -
                                          neighbour_design_measure_start_time)[["elapsed"]]

        system("rm -r ../../save")

        if(!(is.null(current_results))){
            rm(current_results)
            quiet(gc())
            current_results <- NULL
        }

        current_results <- read.csv(paste("current_results_",
                                          run_id,
                                          ".csv",
                                          sep = ""),
                                    header = TRUE)

        if(is.null(search_space)){
            search_space <- current_results
        } else{
            search_space <- bind_rows(search_space, current_results) %>%
                distinct()
        }

        new_timing_info <- data.frame(initial_design = initial_design_time,
                                      initial_design_measure = initial_design_measure_time,
                                      model_fit = model_fit_time,
                                      ei_design = ei_design_time,
                                      ei_compute = ei_compute_time,
                                      neighbour_ei_design = neighbour_ei_design_time,
                                      neighbour_ei_compute = neighbour_ei_compute_time,
                                      neighbour_design_measure = neighbour_design_measure_time)

        if(is.null(timing_info)){
            timing_info <- new_timing_info
        } else{
            timing_info <- bind_rows(timing_info,
                                     new_timing_info)
        }

        write.csv(timing_info,
                  paste("timing_info_",
                        run_id,
                        ".csv",
                        sep = ""),
                  row.names = FALSE)

        write.csv(search_space,
                  paste("gpr_",
                        total_measurements,
                        "_samples_",
                        i,
                        "_iteration_id_",
                        run_id,
                        "_search_space.csv",
                        sep = ""),
                  row.names = FALSE)

        # if(length(search_space[, 1]) >= total_measurements){
        #     break
        # }
    }

    elapsed_time <- as.integer(format(Sys.time(), "%s")) - start_time

    response_data <- search_space %>%
        mutate(performance_metric = performance(search_space$SizeRatio,
                                                search_space$Top1,
                                                search_space$Top5))

    best_points <- search_space[response_data$performance_metric == min(response_data$performance_metric), ]

    best_points$id <- i
    best_points$elapsed_seconds <- elapsed_time
    best_points$points <- total_measurements

    best_points$gpr_iterations <- gpr_iterations
    best_points$gpr_added_points <- gpr_added_points
    best_points$perturbation_range <- perturbation_range
    best_points$gpr_neighbourhood <- gpr_neighbourhood_factor
    best_points$gpr_sample_size <- gpr_sample_size

    if(is.null(results)){
        results <- best_points
    } else{
        results <- bind_rows(results, best_points)
    }

    write.csv(results,
              paste("gpr_",
                    total_measurements,
                    "_samples_",
                    iterations,
                    "_iterations_id_",
                    run_id,
                    ".csv",
                    sep = ""),
              row.names = FALSE)
}


#regress parameter estimates vs. out of sample R2 for predictable taxa fungi.
rm(list=ls())
source('paths_fall2019.r')
source('paths.r')

#set output path.----
output.path <- effect.size_r2_correlation_data_16S.path

#load fit statistics and model parameters.----
#parameter tables.
pl <- readRDS(prior_delgado_ddirch_16S.path)

#hack together 16S functional groups into a single level.----
drop <- c('phylum','class','order','family','genus')
sub <- pl[!(names(pl) %in% drop)]
sub.spp.par <- list()
lab.list <- list()
for(i in 1:length(sub)){
  par <- sub[[i]]$species_parameter_output
  par <- par[!(names(par) %in% c('other'))]
  lab.list[[i]] <- names(par)
  names(par) <- NULL
  sub.spp.par[[i]] <- data.frame(par)
}
names(sub.spp.par) <- unlist(lab.list)
pl <- pl[names(pl) %in% drop]
pl$functional$species_parameter_output <- sub.spp.par

#load validation data.----
#R2, RMSE statistics tables for in and out of sample fits.
vl <- readRDS(NEON_dmilti.ddirch_analysis_summary_16S.path)
ins.dat <- vl$calibration$cal.stat
oos.dat <- vl$validation$val.stat$site.stat
oos.dat <- oos.dat[order(match(names(oos.dat), names(pl)))]
ins.dat <- ins.dat[order(match(names(ins.dat), names(pl)))]

#organize parameters by taxa/group.----
par.out <- list()
for(i in 1:length(pl)){
  #grab parameters within a level.
  lev  <- pl[[i]]$species_parameter_output
  pars <- list()
  for(k in 1:length(lev)){
    pars[[k]] <- as.numeric(as.character(lev[[k]]$Mean))
  }
  pars <- do.call(rbind, pars)
  rownames(pars) <- names(lev)
  colnames(pars) <- as.character(lev$other$predictor)
  pars <- pars[!(rownames(pars) == 'other'),]
  par.out[[i]] <- pars
}
par.out <- do.call(rbind, par.out)

#Generate rsq from prior fit.----
rsq.pl <- list()
for(i in 1:length(pl)){
  if(names(pl)[i] == 'functional'){next}
  prd <- pl[[i]]$predicted
  obs <- pl[[i]]$observed
  rsq.lev <- list()
  for(k in 1:ncol(prd)){
    m <- lm(obs[,k] ~ prd[,k])
    rsq.lev[[k]] <- summary(m)$r.squared
  }
  rsq.lev <- unlist(rsq.lev)
  rsq.lev <- data.frame(colnames(prd),rsq.lev)
  colnames(rsq.lev) <- c('name','rsq.ins')
  rsq.lev <- rsq.lev[!(rsq.lev$name %in% c('other')),]
  rsq.pl[[i]] <- rsq.lev
}
rsq.pl <- data.frame(do.call(rbind, rsq.pl))

#drop any duplicated entries in par.out. this won't matter eventually.
duped <- rownames(par.out)[duplicated(rownames(par.out))]
par.out <- par.out[!(rownames(par.out) %in% duped),]
#rsq.pl  <- rsq.pl [!(rsq.pl$name %in% duped),]
#par.out <- par.out[rownames(par.out) %in% rsq.pl$name,]
#rsq.pl <- rsq.pl[order(match(rsq.pl$name, rownames(par.out))),]
#pl.check <- cbind(par.out, rsq.pl)

#Get in and out of sample stats tables in same order.-----
ins.dat <- do.call(rbind, ins.dat)
oos.dat <- do.call(rbind, oos.dat)
ins.dat$name <- as.character(ins.dat$name)
oos.dat$name <- as.character(oos.dat$name)
#Not all of the names are in everything else. Drop ones not present in both.
ins.dat <- ins.dat[ins.dat$name %in% rownames(par.out),]
oos.dat <- oos.dat[oos.dat$name %in% rownames(par.out),]
par.out <- par.out[rownames(par.out) %in% ins.dat$name,]
#finally order ins and oos to match par.out.
ins.dat <- ins.dat[order(match(ins.dat$name, rownames(par.out))),]
oos.dat <- oos.dat[order(match(oos.dat$name, rownames(par.out))),]

#rename columns, merge all data together.----
colnames(ins.dat) <- paste0('ins.',colnames(ins.dat))
colnames(oos.dat) <- paste0('oos.',colnames(oos.dat))
all.dat <- cbind(par.out,ins.dat,oos.dat)

#grab R2 values, plot correlations.----
par(mfrow = c(2,3))
rsq.out <- list()
for(i in 1:ncol(par.out)){
  dat <- all.dat
  dat$oos.rsq.1 <- ifelse(dat$oos.rsq.1 < 0, 0, dat$oos.rsq.1) #set negative oos.rsq1 values to zero.
  dat$ins.rsq.1 <- ifelse(dat$ins.rsq.1 < 0, 0, dat$ins.rsq.1) #set negative oos.rsq1 values to zero.
  y <- dat$ins.rsq.1
  x <- abs(dat[,i])
  lab <- colnames(dat)[i]
  m <- lm(y~x)
  m.rsq <- round(summary(m)$r.squared, 2)
  sig <- ifelse(summary(m)$coefficients[2,4] < 0.05, 1, 2)
  plot(y ~ x, bty = 'l', cex = 1, xlab = lab)
  mtext(paste0('R2=',m.rsq), side = 3, line = -1, adj = 0.05)
  abline(m, lwd = 1, lty = sig)
  rsq.out[[i]] <- m.rsq
}
rsq.out <- unlist(rsq.out)
names(rsq.out) <- colnames(par.out)
rsq.out <- rsq.out[!(names(rsq.out) %in% c('intercept'))]

#Wrap up parameter vs. prediction R2 - R2 values, and data.-----
output <- list(rsq.out,dat)
names(output) <- c('rsq','dat')
saveRDS(output, output.path)


# Initialize the speed variable
speed <- 64

# Extend/adapt the while loop

while(speed > 30) {
  print (paste("Your speed is",speed))
  if (speed > 48) {
    print ("Slow down big time!")
    speed<-speed-11
  }
  else {
  print("Slow down!")
  speed <- speed - 7
  }
}


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

rm(list=ls())

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

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

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

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

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

clin <- dbGetQuery(con,q)

log_genes <- log10(sub_genes+1)
log_sub_genes <- log_genes[names(gene_var[1:500]),]

#Annotate matrix and add heatmap annotations
big_annotation_table <- clin[match(colnames(log_genes),clin[,"aliquot_barcode"]),]

#Cluster differences
annotation_table <- big_annotation_table[,c("idh_codel_subtype","sample_type","aliquot_batch")]
annotation_table <- annotation_table %>% mutate(idh_codel_subtype = idh_codel_subtype,
										 		sample_type = recode(sample_type,"TP"="Primary","R1"="Recurrent","R2"="Recurrent","R3"="Recurrent"),
										 		aliquot_batch = aliquot_batch)

#Set colors for sidebars
sidebar_labels <- apply(annotation_table,2,function(x)unique(x[!is.na(x)])[order(unique(x[!is.na(x)]))])
idh_codel_subtype = c("#F8766D","#00BA38","#619CFF"); names(idh_codel_subtype) = sidebar_labels[[1]]
sample_type = c("black","white"); names(sample_type) = sidebar_labels[[2]]
aliquot_batch =  brewer.pal(12,"Set3")[1:11]; names(aliquot_batch) = sidebar_labels[[3]]
annotation_colors = list(idh_codel_subtype=idh_codel_subtype,
					sample_type=sample_type,
					aliquot_batch=aliquot_batch)
ha = HeatmapAnnotation(df = annotation_table,which="column",
	 col=annotation_colors,show_annotation_name=TRUE,show_legend=TRUE,na_col="#FFFFFF")

#Plot heatmap to check for batch effect
pdf("/projects/varnf/GLASS-III/GLASS-III/figures/qc/var_gene_heatmap.pdf",width=7,height=7)
hm = Heatmap(t(scale(t(log_sub_genes))),
		col = colorRamp2(c(-1,0,1),c("royalblue4","white","tomato3"),space="RGB"),
		cluster_rows=TRUE,
		show_row_names=FALSE,
		cluster_columns=TRUE,
		show_column_names=FALSE,
		show_heatmap_legend=FALSE,
		bottom_annotation=ha)
hm
dev.off()

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

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

qn_gene_sums <- apply(qn_genes,1,sum)
sub_qn_genes <- qn_genes[which(qn_gene_sums>0),]
qn_gene_var <- apply(sub_qn_genes,1,var)
qn_gene_var <- qn_gene_var[order(qn_gene_var,decreasing=TRUE)]

log_qn_genes <- log10(sub_qn_genes+1)
log_sub_qn_genes <- log_qn_genes[names(qn_gene_var[1:500]),]

#Plot heatmap to see if quantile normalization diminished batch effect
pdf("/projects/varnf/GLASS-III/GLASS-III/figures/qc/var_gene_heatmap_qn.pdf",width=7,height=7)
hm = Heatmap(t(scale(t(log_sub_qn_genes))),
		col = colorRamp2(c(-1,0,1),c("royalblue4","white","tomato3"),space="RGB"),
		cluster_rows=TRUE,
		show_row_names=FALSE,
		cluster_columns=TRUE,
		show_column_names=FALSE,
		show_heatmap_legend=FALSE,
		bottom_annotation=ha)
hm
dev.off()


library(GEOquery)
library(limma)
library(org.Hs.eg.db)
library(data.table)
library(igraph)
source("https://raw.githubusercontent.com/assaron/r-utils/master/R/exprs.R")

GSE3189_ann <- getGEO("GSE3189", AnnotGPL = TRUE, destdir = "data")
es <- GSE3189_ann$GSE3189_series_matrix.txt.gz
es <- es[nchar(fData(es)$`Gene ID`) != 0]
es <- es[-grep("///", fData(es)$`Gene ID`)]
#es <- es[, pData(es)$characteristics_ch1 != "Normal"]
print ("Dataset read")

filePath <- "../../../temp/trainset.csv"
if (file.exists (filePath)) {
  train <- read.csv(filePath)
  print ("Train set found")
  es <- es[, pData(es)$geo_accession %in% train$geo_access]
}
print ("Dataset filtered for train set");

#collapse similar Gene IDs
es <- collapseBy(es, fData(es)$`Gene ID`, median)

fData(es)$symbol <- mapIds(org.Hs.eg.db, keys = rownames(es), column = "SYMBOL", keytype = "ENTREZID")
# make expressionSet object
es$condition <- as.character (pData(es)$`characteristics_ch1`)
print ("Dataset collapsed");

##### differential expression
es.design <- model.matrix(~0+condition, data=pData(es))

fit <- lmFit(es, es.design)

fit2 <- contrasts.fit(fit, makeContrasts(conditionMelanoma-conditionNevus,
                                         levels=es.design))
fit2 <- eBayes(fit2)
de <- normalizeGeneDE(topTable(fit2, adjust.method="BH", number=Inf))
de <- de[order(pval), ]
print ("Differential expression calculated")

##### network
library(BioNet)
gt <- fread("data/BINARY_PROTEIN_PROTEIN_INTERACTIONS.txt")[, list(from=V1, to=V4)]
g <- graph_from_data_frame(gt, directed=FALSE)
g <- simplify(largestComp(induced.subgraph(g, V(g)$name %in% de$Gene.symbol)))
V(g)$geneSymbol <- V(g)$name
V(g)$pval <- de[match(V(g)$name, Gene.symbol), pval]
xy <- data.frame (id = de[match(V(g)$name, Gene.symbol), ID],gene = V(g)$geneSymbol,
                  pval = V(g)$pval, adjPVal = de[match(V(g)$name, Gene.symbol), `adj.P.Val`])
write.table (xy, file = "pvals.csv", sep = ";", dec = ".",
             quote = FALSE, row.names = FALSE)
print ("Network built")

library (mcmcRanking)
g <- set_likelihood (g, 1e-7)
x <- mcmc_sample(g, subgraph_order = 200, times = 500, niter = 100000)
freq <- get_frequency(x, prob = TRUE)
#write.csv(sort (freq, decreasing = TRUE), file = "freqs.csv")
freq <- sort (freq, decreasing = TRUE)
xy <- data.frame (id = de[match(names (freq), Gene.symbol), ID],
                  gene = names (freq), frequency = freq)
write.table (xy, file = "freqs.csv", sep = ";", dec = ".",
             quote = FALSE, row.names = FALSE)
print ("MCMC done")


## Author: Bill Duncan
## Project: OHD
## Date: April 10, 2015
##
## Summary: Statics on patients

## load plyr library
##library(dplyr)
source("load.r")

patient.age.distribution <- function (limit=0) {
  query.string <- "
select distinct ?patient ?birth_date
where
{
  ?patienti rdf:type dental_patient: .
  ?patienti birth_date: ?birth_date .
  ?patienti rdfs:label ?patient . # assign label

  ## filter out bad data, patient 3057 has birth date of 2035-04-19
  filter(?patient != \"patient 3057\")
}
order by ?birth_date

"

  ## check for limit
  if (limit > 0)
    query.string <- paste(query.string," limit ", limit, " \n", sep="")

  ## get reults and convert to dataframe
  res <- queryc(query.string)
  df <- as.data.frame(res, stringsAsFactors = F)

  ## convert birth date column from string to data and calculate age
  ## note: use 12/31/2011 to calc age of patient
  df$birth_date <- as.Date(df$birth_date)
  data.end.date <- as.Date("2011-12-31")
  df$age <- round(as.numeric(difftime(data.end.date, df$birth_date, units="days")) / 365.25)

  info <-
  hist(df$age,
       xlab="Patient Age",
       ylab="Number of Patients",
       main = "Number of patients by age",
       col="lightblue",
       freq=TRUE,
       right=TRUE,
       breaks = c(0, 10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110))

  #print(info)

  ## build data frame to return
  ## note: b/c the length of the counts and breaks lists are different, I only use the length
  ## of the counts list. the breaks list contains a "110" entry for which there are no patients
  df <- as.data.frame(info$counts, row.names=as.character(info$breaks[1:length(info$counts)]))
}

last.visit.summary <- function(limit=0) {

  ## get results
  df <- query.from.file("sparql/patient-visit-summary.sparql", limit)

  ## convert vist_date to date data type
  df$latest <- as.Date(df$latest)

  ## calculate elapsed time since last visit
  data.end.date <- as.Date("2011-12-31")
  df$elapsed.months <- round(as.numeric(difftime(data.end.date, df$latest, units="days"))/(365.25/12))

  ## calculate the patients last seen in 12, 24, 36, or greater months
  visit12 <- nrow(subset(df, elapsed.months <= 12))
  visit12to24 <- nrow(subset(df, elapsed.months > 12 & elapsed.months <= 24))
  visit24to36 <- nrow(subset(df, elapsed.months > 24 & elapsed.months <= 36))
  visit36plus <- nrow(subset(df, elapsed.months > 36))

  ## datafame of elapsed months
  elapsed <- c(visit12, visit12to24, visit24to36, visit36plus)
  rownames <- c("<= 12 months", "12 to 24 months", "24 to 36 months", "36+ months")
  info <- data.frame(elapsed.months=elapsed, row.names=rownames)

  ## make barplot
  barplot(info$elapsed.months,
          main="Distribution of patient visits",
          xlab="Time period for last patient visit",
          ylab="Number of patients seen",
          col="blue",
          names.arg = row.names(info))
  ## return info dataframe
  info
}

patient.age.at.first.visit <- function(limit=0) {
  ## get results
  df <- query.from.file("sparql/patient-visit-summary.sparql", limit)

  ## convert vist_date to date data type
  df$earliest <- as.Date(df$earliest)

  ## calculate age of patient at first visit by taking the
  ## difference of the patient's birthdate and earliest visit
  df$age <- round(years_difference_from_dates(df$birth_date, df$earliest))

  ## remove records with age less than 0
  df <- subset(df, age > 0)

  ## we want only the patient and age columns
  df <- subset(df, select=c("patient", "age"))

  ## make barplot
  info <- table(df$age)
  barplot(info,
          main="Summary of age of patient at first visit",
          xlab="Age of patient",
          ylab="Number of patients",
          col="blue")

  ## return data frame of summary of patient ages at first visit
  data.frame(patient.age=names(info), count=as.vector(info))
}


#!/usr/bin/env Rscript
library(DESeq2)

args = commandArgs(trailingOnly=TRUE)

#read data
counts.mat <- read.csv(args[1])
coldata <- read.csv(args[2])

#name metadata columns
colnames(coldata) <- c("sample.id", "condition")
#convert datatype to factor
coldata[,-1] <- as.factor(coldata[, -1])
#Match sample ids to sample columns in counts matrix
coldata$sample.id <- sub("-", ".", coldata$sample.id)

#init dds object
dds <- DESeqDataSetFromMatrix(countData=counts.mat,
                              colData=coldata,
                              design= ~condition,
                              tidy = TRUE)

dds <- estimateSizeFactors(dds)
#Filter lowly expressed genes
idx <- rowSums(counts(dds, normalized=TRUE) >= 5) >= 3
dds <- dds[idx,]

dds <- DESeq(dds) #run deseq
res <- results(dds) #get results
#Show results
print(summary(res))
print(head(res))

write.csv(res, args[3]) #save results


library(dplyr, warn = FALSE)

# Must manually set
multiplier = 5

stat_file = file.path("..", "hetnets", "permuted", "stats.tsv")
stat_df = readr::read_tsv(stat_file) %>%
  dplyr::mutate(complete = round(complete * multiplier, 2))
head(stat_df, 4)

unchanged_df = stat_df %>%
  # Average over permutations
  dplyr::group_by(abbrev, complete) %>%
  dplyr::summarize(unchanged = mean(unchanged)) %>%
  dplyr::ungroup() %>%
  dplyr::bind_rows(dplyr::data_frame(abbrev=unique(stat_df$abbrev), complete = 0, unchanged = 1))

abbrevs = unchanged_df %>%
  dplyr::filter(complete == multiplier) %>%
  dplyr::arrange(desc(unchanged)) %>%
  .[['abbrev']]

unchanged_df %>%
  ggplot2::ggplot(ggplot2::aes(x = complete, y = 100 * unchanged, color = abbrev)) +
  ggplot2::geom_line() +
  ggplot2::theme_bw() +
  ggplot2::scale_colour_discrete(breaks = abbrevs, name='Metaedge') +
  ggplot2::xlab('Attempt multiplier') +
  ggplot2::ylab('Percent of Edges Unchanged')

bar_df = stat_df %>%
  tidyr::gather(key = 'measure', value = 'percent', duplicate:excluded, same_edge:undirected_duplicate) %>%
  dplyr::group_by(abbrev, measure) %>%
  dplyr::summarize(
    percent = 100 * weighted.mean(percent, attempts)
  ) %>%
  dplyr::filter(measure != 'excluded')

bar_df$abbrev = factor(bar_df$abbrev, levels=abbrevs)

bar_df %>%
  dplyr::filter(measure %in% c('duplicate')) %>%
  ggplot2::ggplot(ggplot2::aes(x = abbrev, y = percent, fill = measure)) +
  ggplot2::geom_bar(stat = "identity", position = "dodge") +
  ggplot2::coord_flip()

bar_df %>%
  dplyr::filter(!(measure %in% c('duplicate', 'unchanged'))) %>%
  ggplot2::ggplot(ggplot2::aes(x = abbrev, y = percent, fill=measure)) +
  ggplot2::geom_bar(stat = "identity", position = "dodge") +
  ggplot2::coord_flip()


#WORK IN PROGRESS
#Had to learn ggplot to multipanel this. ugh.
rm(list=ls())
source('paths_fall2019.r')
source('paths.r')
library(vegan)
library(ggbiplot)
library(RColorBrewer)
library(gridExtra)

#set output path.----
output.path <- 'figures/Supp._Fig._3._parameter_PCA.jpg'

#load raw data and predictors.----
pl.ITS <- readRDS(ted_ITS_prior_all.groups_JAGSfits.path)
names(pl.ITS)[6] <- 'functional'
pl.16S <- readRDS(prior_delgado_ddirch_16S.path)

#data for plotting relationships between effect sizes and R2 in sample.
sum.ITS <- readRDS(effect.size_r2_correlation_data.path)
sum.16S <- readRDS(effect.size_r2_correlation_data_16S.path)

#change names for downstream labels.
names(sum.ITS$rsq) <- c('%C','C:N','pH','NPP','MAP','MAT','forest','conifer','relEM')

#hack together 16S functional groups into a single level.----
drop <- c('phylum','class','order','family','genus')
sub <- pl.16S[!(names(pl.16S) %in% drop)]
sub.spp.par <- list()
lab.list <- list()
sub.pred <- list()
sub.obs  <- list()
for(i in 1:length(sub)){
  pred <- sub[[i]]$predicted
   obs <- sub[[i]]$observed
  par <- sub[[i]]$species_parameter_output
  par <- par[!(names(par) %in% c('other'))]
  lab.list[[i]] <- names(par)
  names(par) <- NULL
  sub.spp.par[[i]] <- data.frame(par)
  sub.pred   [[i]] <- pred
  sub.obs    [[i]] <- obs
}
names(sub.spp.par) <- unlist(lab.list)
pl.16S <- pl.16S[names(pl.16S) %in% drop]
pl.16S$functional$species_parameter_output <- sub.spp.par

#colors.----
cols <- brewer.pal(length(pl.ITS) - 1,'Spectral')
cols <- c(cols,'green')

#ITS: get together parameters as a matrix and R2 values.----
       d.ITS <- list()
col.plot.ITS <- list()
 rsq.out.ITS <- list()
 pca.sub.ITS <- list()
for(i in 1:length(pl.ITS)){
  lev <- pl.ITS[[i]]$species_parameter_output
  pars <- list()
  rsq.lev <- list()
  for(k in 1:length(lev)){
    pars[[k]] <- as.numeric(as.character(lev[[k]]$Mean))
    mod <- lm(pl.ITS[[i]]$observed[,k] ~ pl.ITS[[i]]$predicted[,k])
    rsq.lev[[k]] <- summary(mod)$r.squared
  }
  pars <- do.call(cbind, pars)
  rsq.lev <- unlist(rsq.lev)
  names(rsq.lev) <- names(lev)
  colnames(pars) <- names(lev)
  rownames(pars) <- as.character(lev$other$predictor)
  pars <- pars[,!(colnames(pars) == 'other')]
         d.ITS[[i]] <- pars
   rsq.out.ITS[[i]] <- rsq.lev
  col.plot.ITS[[i]] <- rep(names(pl.ITS)[i],ncol(pars))
   pca.sub.ITS[[i]] <- prcomp(t(pars), center = T, scale. = T)
}
       d.ITS <- do.call(cbind, d.ITS)
       d.ITS <- d.ITS[,!(colnames(d.ITS) == 'other')]
col.plot.ITS <- unlist(col.plot.ITS)
 rsq.out.ITS <- unlist(rsq.out.ITS)
     rsq.ITS <- rsq.out.ITS[!(names(rsq.out.ITS) %in% 'other')]
     rsq.ITS <- round(rsq.ITS, 2)
names(pca.sub.ITS) <- names(pl.ITS)

#16S: get together parameters as a matrix and R2 values.----
       d.16S <- list()
col.plot.16S <- list()
 rsq.out.16S <- list()
 pca.sub.16S <- list()
for(i in 1:length(pl.16S)){
  lev <- pl.16S[[i]]$species_parameter_output
  pars <- list()
  rsq.lev <- list()
  for(k in 1:length(lev)){
    pars[[k]] <- as.numeric(as.character(lev[[k]]$Mean))
  #  mod <- lm(pl.16S[[i]]$observed[,k] ~ pl.16S[[i]]$predicted[,k])
  #  rsq.lev[[k]] <- summary(mod)$r.squared
  }
  pars <- do.call(cbind, pars)
  #rsq.lev <- unlist(rsq.lev)
  #names(rsq.lev) <- names(lev)
  colnames(pars) <- names(lev)
  rownames(pars) <- as.character(lev$other$predictor)
  pars <- pars[,!(colnames(pars) == 'other')]
  d.16S[[i]] <- pars
  #rsq.out.16S[[i]] <- rsq.lev
  col.plot.16S[[i]] <- rep(names(pl.16S)[i],ncol(pars))
  pca.sub.16S[[i]] <- prcomp(t(pars), center = T, scale. = T)
}
d.16S <- do.call(cbind, d.16S)
d.16S <- d.16S[,!(colnames(d.16S) == 'other')]
col.plot.16S <- unlist(col.plot.16S)
#rsq.out.16S <- unlist(rsq.out.16S)
#rsq.16S <- rsq.out.16S[!(names(rsq.out.16S) %in% 'other')]
#rsq.16S <- round(rsq.16S, 2)
names(pca.sub.16S) <- names(pl.16S)

#change factor levels of col.plot so they plot in order.----
col.plot.ITS <- factor(col.plot.ITS, levels = c("functional", "phylum", "class","order","family","genus"))
col.plot.16S <- factor(col.plot.16S, levels = c("functional", "phylum", "class","order","family","genus"))

#Do PCA ordination.----
par.pca.ITS <- prcomp(t(d.ITS), center = TRUE,scale. = TRUE)
par.pca.16S <- prcomp(t(d.16S), center = TRUE,scale. = TRUE)

#png save line.----
jpeg(filename=output.path,width=11,height=8,units='in',res=300)

#plot code ITS.----
#PCA plot.
lab <- colnames(d.ITS)
rownames(par.pca.ITS$rotation) <- c('intercept','%C','C:N','pH','NPP','MAP','MAT','forest','conifer','relEM')
unit.scale = 0.5
PCA.plot.ITS <- ggbiplot(par.pca.ITS, labels = lab, groups = col.plot.ITS) +  xlim(-2.25, 2.5) +
  theme(legend.position="top") +   guides(color = guide_legend(nrow = 1)) +
  theme(plot.margin = unit(c(0,2*unit.scale,unit.scale,unit.scale), 'cm')) +
  labs(tag = "A") + ggtitle('Fungi')

#Plot of best fitting predictor to RSQ values.
x.var <- sum.ITS$rsq[order(sum.ITS$rsq)][length(sum.ITS$rsq)]
x <- abs(sum.ITS$dat[,names(x.var)])
y <- sum.ITS$dat$ins.rsq.1
y <- ifelse(y < 0, 0, y)
mod <- lm(y~x)
rsq <- round(summary(mod)$r.squared, 2)
lab.x <- paste0(names(x.var),' effect size')
scatter.dat <- data.frame(x,y)
unit.scale <- 0.5 #proportional scaling of subplot.
scatter.plot.ITS <- ggplot(scatter.dat, aes(x=x, y=y), size = 3) +
            geom_point() +
            theme_bw()  + #drop gray background.
  theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) +   #drop gridlines
  xlab(lab.x) +  #x axis label.
  ylab(expression(paste("calibration ", R^2))) + #y axis label.
  theme(axis.line = element_line(colour = "black"), panel.border = element_blank()) + #add x-y axes, drop bounding box.
  scale_y_continuous(expand = expand_scale(mult = c(.01, .02))) + #change where y-axis cuts off.
  scale_x_continuous(expand = expand_scale(mult = c(.01, .01)))  + #change where x-axis cuts off.
  theme(axis.text.x=element_text(size=rel(0.5))) +                  #reduce x-axis text size.
  geom_abline(slope = coef(mod)[2], intercept = coef(mod)[1], size = 1) + #add regression line.
  theme(plot.margin = unit(c(unit.scale,2*unit.scale,2*unit.scale,unit.scale), 'cm')) +
  geom_text(x=0.50, y = 0.05, label=expression(paste(R^2,'= 0.41'))) +
  labs(tag = "B")

#Ranked barplot of explanatory power
x <- sum.ITS$rsq
x <- x[order(x, decreasing = T)]
y <- names(x)
bar.y.max <- max(x) #set common y limit for bar plot across fungi/bacteria.
bar.dat <- data.frame(x,y)
bar.plot.ITS <-ggplot(data=bar.dat, aes(x=y, y=x)) +
  geom_bar(stat="identity") +
  scale_x_discrete(limits= names(x)) +
  theme_bw()  + #drop gray background.
  theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) +#drop gridlines
  theme(axis.line = element_line(colour = "black"), panel.border = element_blank()) + #add x-y axes, drop bounding box.
  scale_y_continuous(expand = expand_scale(mult = c(.01, .01)))  + #change where y-axis cuts off.
  xlab('') + ylab('Predictive Capacity') +
  theme(axis.text.x = element_text(angle = 45, hjust = 1, size =12)) +
  theme(plot.margin = unit(c(unit.scale,2*unit.scale,0,unit.scale), 'cm')) +
  coord_cartesian(ylim = c(0, bar.y.max)) +
  labs(tag = "C")

#plot code 16S.----
lab <- colnames(d.16S)
rownames(par.pca.16S$rotation) <- c('intercept','pH','MAP','MAT','NPP','relEM')
unit.scale = 0.5
PCA.plot.16S <- ggbiplot(par.pca.16S, labels = lab, groups = col.plot.16S) +  xlim(-2.25, 2.5) +
  theme(legend.position="top") +   guides(color = guide_legend(nrow = 1)) +
  theme(plot.margin = unit(c(0,2*unit.scale,unit.scale,unit.scale), 'cm')) +
  labs(tag = "D") + ggtitle('Bacteria')

#Plot of best fitting predictor to RSQ values.
x.var <- sum.16S$rsq[order(sum.16S$rsq)][length(sum.16S$rsq)]
x.var <- sum.16S$rsq['pH'] #select pH since relEM is a negative correlation.
x <- abs(sum.16S$dat[,names(x.var)])
y <- sum.16S$dat$ins.rsq.1
y <- ifelse(y < 0, 0, y)
mod <- lm(y~x)
rsq <- round(summary(mod)$r.squared, 2)
lab.x <- paste0(names(x.var),' effect size')
scatter.dat <- data.frame(x,y)
unit.scale <- 0.5 #proportional scaling of subplot.
scatter.plot.16S <- ggplot(scatter.dat, aes(x=x, y=y), size = 3) +
  geom_point() +
  theme_bw()  + #drop gray background.
  theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) +   #drop gridlines
  xlab(lab.x) +  #x axis label.
  ylab(expression(paste("calibration ", R^2))) + #y axis label.
  theme(axis.line = element_line(colour = "black"), panel.border = element_blank()) + #add x-y axes, drop bounding box.
  scale_y_continuous(expand = expand_scale(mult = c(.01, .02))) + #change where y-axis cuts off.
  scale_x_continuous(expand = expand_scale(mult = c(.01, .01)))  + #change where x-axis cuts off.
  geom_abline(slope = coef(mod)[2], intercept = coef(mod)[1], size = 1) + #add regression line.
  theme(plot.margin = unit(c(unit.scale,2*unit.scale,2*unit.scale,unit.scale), 'cm')) +
  #CHANGE R2 BY "HAND" HERE.
  geom_text(x=0.40, y = 0.75, label=expression(paste(R^2,'= 0.05'))) +
  labs(tag = "E")

#Ranked barplot of explanatory power
x <- sum.16S$rsq
x <- x[order(x, decreasing = T)]
y <- names(x)
bar.dat <- data.frame(x,y)
bar.plot.16S <-ggplot(data=bar.dat, aes(x=y, y=x)) +
  geom_bar(stat="identity") +
  scale_x_discrete(limits= names(x)) +
  theme_bw()  + #drop gray background.
  theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) +#drop gridlines
  theme(axis.line = element_line(colour = "black"), panel.border = element_blank()) + #add x-y axes, drop bounding box.
  scale_y_continuous(expand = expand_scale(mult = c(.01, .01)))  + #change where y-axis cuts off.
  xlab('') + ylab('Predictive Capacity') +
  theme(axis.text.x = element_text(angle = 45, hjust = 1, size =12)) +
  theme(plot.margin = unit(c(unit.scale,2*unit.scale,0,unit.scale), 'cm')) +
  coord_cartesian(ylim = c(0, bar.y.max)) +
  labs(tag = "F")

#grab legend.----
g_legend<-function(a.gplot){
  tmp <- ggplot_gtable(ggplot_build(a.gplot))
  leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
  legend <- tmp$grobs[[leg]]
  return(legend)}

mylegend<-g_legend(PCA.plot.ITS)

#panel plots together.----
#Just ITS.
#grid.arrange(PCA.plot.ITS, scatter.plot.ITS, bar.plot.ITS,
#             widths = c(2, 2),
#             heights = c(4,2),
#             layout_matrix = rbind(c(1,1),
#                                   c(2,3))
#)

#ITS and 16S
#grid.arrange(PCA.plot.ITS, scatter.plot.ITS, bar.plot.ITS,
#             PCA.plot.16S, scatter.plot.16S, bar.plot.16S,
#  widths = c(2, 2, 2, 2),
#  heights = c(4,2),
#  layout_matrix = rbind(c(1,1,4,4),
#                        c(2,3,5,6))
#)

#ITS and 16S common legend.
grid.arrange(mylegend,
             (PCA.plot.ITS + theme(legend.position = 'none')), scatter.plot.ITS, bar.plot.ITS,
             (PCA.plot.16S + theme(legend.position = 'none')), scatter.plot.16S, bar.plot.16S,
             widths = c(2, 2, 2, 2),
             heights = c(0.5,4,2),
             layout_matrix = rbind(c(1,1,1,1),
                                   c(2,2,5,5),
                                   c(3,4,6,7))
)

#end plot.----
dev.off()


plot.width = {img_width}
plot.height = {img_height}
plot.range = {date_range}
plot.locationid = {locationid}
plot.title = '{plot_title}'
plot.path = '{plot_path}'

ExtractorID = 40519
InjectorID  = 40520
PLEX_ID     = 29668
MPCT_ID     = 34133
ResculptID  = 34132
typeID_list <- c(29668,34133,34132,40519,40520,44992)
plot.typeids.str <- paste(typeID_list, collapse=',')

PLEX_AUR <- 3500
RMT_AUR  <- 4035 #$20 USD rate
Extractor_AUR <- 800
SP_HR <- 2700
SP_PLEX <- SP_HR * 30 * 24

date.min <- Sys.Date() - plot.range

## Event List ##
event.query <- paste0(
    'SELECT datetime, eventName ',
    'FROM event_list ',
    'WHERE eventGroup in (\'patch\') ',
    'AND datetime > \'', date.min, '\' '
)
event <- sqlQuery(emd, event.query)
event$datetime <- as.POSIXlt(event$datetime, tz='GMT')
do_lines <- TRUE
if(nrow(event)==0){{do_lines <- FALSE}}

## Get Data ##
ec.query <- paste0(
    'SELECT price_date AS `date`, price_time AS `hour`, locationid, typeid, ',
    'SUM(IF(buy_sell=1, price_best, NULL)) AS `SellOrder`, ',
    'SUM(IF(buy_sell=0, price_best, NULL)) AS `BuyOrder` ',
    'FROM snapshot_evecentral ',
    'WHERE locationid=', plot.locationid, ' ',
    'AND typeid IN (', plot.typeids.str, ') ',
    'AND price_date > \'', date.min, '\' ',
    'GROUP BY price_date, price_time, typeid'
)
ec <- sqlQuery(emd, ec.query)
odbcClose(emd)
ec$date <- as.Date(ec$date)
ec$typeid <- as.factor(ec$typeid)
ec <- subset(ec, SellOrder > 0)
ec$datetime <- paste(ec$date, ec$hour, sep=' ')
ec$datetime <- as.POSIXlt(ec$datetime, tz='GMT')
## PLEX SPLIT ##
ec$SellOrder[ec$typeid==44992] = ec$SellOrder[ec$typeid==44992] * 500
ec$BuyOrder[ec$typeid==44992] = ec$BuyOrder[ec$typeid==44992] * 500
ec$typeid[ec$typeid==44992] = 29668

## CREST Lookups ##
CREST_BASE = 'https://crest-tq.eveonline.com/'
solarsystem.addr <- paste0(CREST_BASE, 'solarsystems/', plot.locationid, '/')
solarsystem.json <- fromJSON(readLines(solarsystem.addr))
solarsystem.name <- solarsystem.json$name

ec$locationName <- solarsystem.name

type_list <- unique(ec$typeid)
ec$typeName <- NA
for(type.index in 1:length(type_list)){{
    type.name <- ''
    type.id <- type_list[type.index]
    type.addr <- paste0(CREST_BASE, 'inventory/types/', type.id, '/')
    type.json <- fromJSON(readLines(type.addr))
    type.name <- type.json$name
    ec$typeName[ec$typeid==type.id] <- type.name
}}

## Plot Theme ##
theme_dark <- function( ... ) {{
  theme(
    text = element_text(color="gray90"),
    title = element_text(size=rel(2),hjust=0.05,vjust=3.5),
    axis.title.x = element_text(size=rel(1),hjust=0.5, vjust=0),
    axis.title.y = element_text(size=rel(1),hjust=0.5, vjust=1.5),
    plot.margin = unit(c(2,1,1,1), "cm"),
    plot.background=element_rect(fill="gray8",color="gray8"),
    panel.background=element_rect(fill="gray10",color="gray10"),
    panel.grid.major = element_line(colour="gray17"),
    panel.grid.minor = element_line(colour="gray12"),
    axis.line = element_line(color = "gray50"),
    plot.title = element_text(color="gray80"),
    axis.title = element_text(color="gray70"),
    axis.text = element_text(color="gray50",size=rel(1.1)),
    legend.key = element_rect(fill="gray8",color="gray8"),
    legend.background = element_rect(fill="gray8"),
    legend.title = element_text(size=rel(0.6)),
    legend.text = element_text(size=rel(1.1)),
    strip.background = element_rect(fill="gray1"),
    strip.text = element_text(size=rel(1.2))
  ) + theme(...)
}}

## Mung Data ##
skill.inj <- subset(ec, typeid==InjectorID)
skill.inj$injector.buy <- skill.inj$BuyOrder
skill.inj$injector.sell<- skill.inj$SellOrder
skill.ext <- subset(ec, typeid==ExtractorID)
skill.ext$extractor.buy <- skill.ext$BuyOrder
skill.ext$extractor.sell<- skill.ext$SellOrder
skill.PLX <- subset(ec, typeid==PLEX_ID)
skill.PLX$PLEX.buy <- skill.PLX$BuyOrder
skill.PLX$PLEX.sell<- skill.PLX$SellOrder

skill <- merge(
    skill.inj, skill.ext,
    by=c(
        'locationid',
        'datetime')
)
skill <- merge(
    skill, skill.PLX,
    by=c(
    'locationid',
    'datetime')
)
skill$isk_SP_full.buy <- skill$PLEX.buy / SP_PLEX
skill$isk_SP_full.sell<- skill$PLEX.sell/ SP_PLEX
skill$isk_SP_market.buy <- (skill$injector.buy - skill$extractor.sell) / 500000
skill$isk_SP_market.sell<- (skill$injector.sell- skill$extractor.sell) / 500000

skill.max <- max(c(
    max(skill$isk_SP_market.sell, na.rm=TRUE),
    max(skill$isk_SP_full.sell, na.rm=TRUE)),
    na.rm=TRUE
)
skill.min <- min(c(
    min(skill$isk_SP_market.buy, na.rm=TRUE),
    min(skill$isk_SP_full.buy, na.rm=TRUE)),
    na.rm=TRUE
)
skill.max.date <- max(skill$datetime, na.rm=TRUE)

## Build Plot ##
alpha_group <- c(0.3, 0.3, 1, 0.3)
tics.min <- round_any(
    skill.min,
    100,
    f=floor
)
tics.max <- round_any(
    skill.max,
    100,
    f=ceiling
)
tics <- seq(
    from=tics.min,
    to=tics.max,
    by=50
)
label <- data.frame(
    x=skill.max.date,
    y=skill$isk_SP_full.sell[skill$datetime==skill.max.date],
    label='PLEX-SP PARITY'
)

plot <- ggplot(
    skill,
    aes(
        x=datetime,
        ymin=isk_SP_market.buy,
        ymax=isk_SP_market.sell)
)
plot <- plot + geom_ribbon(fill='#0066ff')
plot <- plot + theme_dark()
plot <- plot + scale_y_continuous(
    breaks=tics,
    position='right'
)
plot <- plot + labs(
    title=plot.title,
    fill='System',
    x='Date',
    y='ISK/SP'
)
plot <- plot + geom_line(
    aes(
        x=datetime,
        y=isk_SP_full.sell),
    color='white',
    linetype=2,
    size=1.5,
    data=skill,
    inherit.aes=FALSE
)
plot <- plot + geom_text(
    aes(
        x=x,
        y=y,
        label=label),
    data=label,
    color='white',
    vjust=-1.25,
    size=5,
    inherit.aes=FALSE)
if(do_lines){{
    plot <- plot + geom_vline(
        xintercept=as.numeric(event$datetime),
        linetype=2,
        color='white'
    )
    plot <- plot + geom_text(
        aes(
            x=datetime,
            y=Inf,
            label=eventName),
        color='white',
        angle=-90,
        vjust=1.2,
        hjust=0,
        data=event,
        size=5,
        inherit.aes=FALSE
    )
}}

## Print Plot To File ##
png(
    plot.path,
    width=plot.width,
    height=plot.height
)
print(plot)
dev.off()


#setwd('~/Msc/Sem 1/DBMS/DBMS-Codes')
source('closure.r')

check_extraneous <- function(attr,row,data,side = "right"){
  value = FALSE
  if(side == "left"){
    cof <- remove_char(attr,data[row,'V1'])
    closure <- find_closure(cof,data)
    if(search_attr(data[row,'V2'],closure)){
      value = TRUE
    }
  }else{
    cof <- data[row,'V1']
    check <- data[row,'V2']
    new_fd <- c(data[row,'V1'],remove_char(attr,data[row,'V2']))
    data <- data[-row,]
    data <- rbind(data,new_fd)
    closure <- find_closure(cof,data)
    if(search_attr(check,closure)){
      value = TRUE
    }
  }
  return(value)
}

#Minimal Cover
minimal_cover <- function(data){
  data <- combine_fd(data) #In function.r
  nofd <- nrow(data)

  #Checking For LHS
  loop_condition <- TRUE
  i <- 1
  while(loop_condition){

    #Checking Extraneous on Left-Hand Side
    nocl <- nchar(data[i,'V1'])
    j <- 1
    while(nocl != 1){
      attr <- substr(data[i,'V1'],j,j)
      if(check_extraneous(attr,i,data,"left")){
        data[i,'V1'] <- remove_char(attr,data[i,'V1'])
        nocl <- nocl - 1
      }
      j <- j + 1
    }

    #Checking Extraneous on Right-Hand Side
    nocr <- nchar(data[i,'V2'])
    j <- 1
    while(nocr != 1){
      attr <- substr(data[i,'V2'],j,j)
      if(check_extraneous(attr,i,data)){
        data[i,'V2'] <- remove_char(attr,data[i,'V2'])
        nocr <- nocr - 1
      }
      j <- j + 1
    }
    data <- unique(data)
    nofd <- nrow(data)
    i <- i + 1
    if(i > nofd)
      loop_condition <- FALSE
  }
  return(data)
}


#' Extract a complete subcatchment from the watershed
#'
#' This function returns a complete subset watershed object, including all triburaties upstream
#' from a specified point. PixelIDs and reachIDs will be renumbered.
#' @param ws A [Watershed()].
#' @param x The point to make the new outlet for the extracted watershed.
#' @return A watershed.
#' @export
subcatchment = function(ws, x) {
	newSet = sort(connect(ws, downstream = x, upstream = Inf))
	newNums = 1:length(newSet)
	dat = ws$data[newSet,]
	dat$id = newNums

	adj = ws$adjacency[newSet, newSet]
	rownames(adj) = colnames(adj) = newNums
	wsobj = list(data = dat, adjacency = adj)
	class(wsobj) = class(ws)

	.rebuild_reach_topology(wsobj)
}


#' Tall Matrices
#'
#' Many data science problems reduce to operations on very tall,
#' skinny matrices.  However, sometimes these matrices can be so tall that they
#' are difficult to work with, or do not even fit into main memory.  One
#' strategy to deal with such objects is to distribute their rows across
#' several processors.  To this end, we offer an 'S4' class for tall, skinny,
#' distributed matrices, called the 'shaq'.  We also provide many useful
#' numerical methods and statistics operations for operating on these
#' distributed objects.  The naming is a bit "tongue-in-cheek", with the class
#' a play on the fact that 'Shaquille' 'ONeal' ('Shaq') is very tall, and he
#' starred in the film 'Kazaam'.
#'
#' @importFrom pbdMPI isend irecv send recv allreduce bcast comm.size comm.rank
#'    comm.stop comm.all comm.max get.jid
#' @import methods
#' @importFrom stats prcomp optim
#'
#' @useDynLib kazaam R_trinv
#'
#' @name kazaam-package
#' @docType package
#' @author Drew Schmidt \email{wrathematics@gmail.com}, Wei-Chen Chen, Mike Matheson, and George Ostrouchov.
#' @references Programming with Big Data in R Website: \url{http://r-pbd.org/}
#' @keywords Package
NULL


library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(dplyr)
library(tidyr)
library(EnvStats) # For gammaAlt functions
# library(optparse)

## Code addapted to handle Western Pacific countries for WHO Regional
## Office (WPRO). Additional comments added to translate methods from
## Imperial report:
## * Seth Flaxman, Swapnil Mishra, Axel Gandy et al. Estimating the number
## of infections and the impact of nonpharmaceutical interventions on
## COVID-19 in 11
## European countries. Imperial College London (30-03-2020)
## doi: https://doi.org/10.25561/77731.

rm(list = ls()) # Don't like doing this but just in case # Restart R

source('utils/read-data.r')
source('utils/process-covariates.r')

# User Options ------------------------------------------------------------
options <- list("include_ncd" = TRUE,
  "npi_on" = TRUE,
  "fullRun" = TRUE,
  "debug" = FALSE,
  "model" = "base_wpro",
  "useJHU" = TRUE,
  "EndDate" = NULL) # EndDated default = NULL

DEBUG <- options$debug

FULL <- options$fullRun

if(DEBUG && FULL) {
  stop("Setting both debug and full run modes at once is invalid")
}

StanModel <- options$model
print(sprintf("Running %s",StanModel))
if(DEBUG) {
  print("Running in DEBUG mode")
} else if (FULL) {
  print("Running in FULL mode")
}

## Reading all data -------------------------------------------------------
# Read which countires to use
countries <- read.csv('data/regions.csv', stringsAsFactors = FALSE)
# Read deaths data for regions
d <- read_obs_data(countries)
if (options$useJHU) {
  d_jhu <- readRDS('data/COVID-19-up-to-date_JHU.rds') %>%
    select(DateRep, Cases, Deaths, Country) %>%
    filter(Country %in% countries$Regions, DateRep >= "2020-01-23") %>%
    mutate(Country = as.character(Country))

  d <- filter(d, DateRep <= "2020-01-22") %>%
    bind_rows(d_jhu) %>%
    arrange(Country, DateRep)
  d$Deaths[d$Deaths < 0] <- 0

}

if (!is.null(options$EndDate[1])) {
  d <- filter(d, DateRep <= options$EndDate)
}

# Read ifr
ifr.by.country <- read_ifr_data()

# Read interventions
interventions <- read_interventions(countries)

## Ensure that output directories exist
dateResults <- max(as.Date(d$DateRep,format='%d/%m/%Y'))
resultsDir <- paste0("results/DateRep-",dateResults, "/")
figuresDir <- paste0("figures/DateRep-",dateResults, "/")
dir.create(resultsDir, showWarnings = FALSE, recursive = TRUE)
dir.create(figuresDir, showWarnings = FALSE, recursive = TRUE)

forecast <- 7 # increase to get correct number of days to simulate
# Maximum number of days to simulate
N2 <- (max(d$DateRep) - min(d$DateRep) + 1 + forecast)[[1]]

# Initialize inputs ------------------------------------------------------
processed_data <- process_covariates(countries = countries,
  interventions = interventions, d = d , ifr.by.country = ifr.by.country,
  N2 = N2)
stan_data = processed_data$stan_data
dates = processed_data$dates
deaths_by_country = processed_data$deaths_by_country
reported_cases = processed_data$reported_cases

# Set-up and run sampling -------------------------------------------------
# stan_data$y = t(stan_data$y)
options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)
m = stan_model(paste0('stan-models/',StanModel,'.stan'))

if(DEBUG) {
  fit = sampling(m,data=stan_data,iter=40,warmup=20,chains=2)
} else if (FULL) {
  fit = sampling(m,data=stan_data,iter=1800,warmup=1000,chains=5,thin=1,
    control = list(adapt_delta = 0.95, max_treedepth = 15))
} else {
  fit = sampling(m,data=stan_data,iter=1000,warmup=500,chains=4,thin=1,
    control = list(adapt_delta = 0.95, max_treedepth = 10))
}

# Extract outputs and save results ----------------------------------------
out = rstan::extract(fit)
prediction = out$prediction
estimated.deaths = out$E_deaths
estimated.deaths.cf = out$E_deaths0

JOBID = Sys.getenv("PBS_JOBID")
if(JOBID == "")
  JOBID = as.character(abs(round(rnorm(1) * 1000000)))
print(sprintf("Jobid = %s",JOBID))

countries <- countries$Regions
save.image(paste0(resultsDir, StanModel,'-',JOBID,'.Rdata')) # don't like this
save(fit,out,prediction,dates,reported_cases,deaths_by_country,countries,
  estimated.deaths,estimated.deaths.cf,out,options,stan_data,
  file=paste0(resultsDir, StanModel,'-',JOBID,'-stanfit.Rdata'))

# Visualize results -------------------------------------------------------
print("To visualize results run code in wrpo-results.r script")


MGRAST_suggest_test <<- function (data_file, groups_file, data_type=c("raw", "normalized"), paired = FALSE, file_out)
  {

    ### SUB TO WRITE OUTPUT
    write_out = function (sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes){
      #print("got here")
      write(sig_test, file = file_out)
      write(paste("data-type         =", data_type,   sep = "\t"), file = file_out, append = TRUE)
      write(paste("paired            =", paired,      sep = "\t"), file = file_out, append = TRUE)
      write(paste("num-samples       =", num_samples, sep = "\t"), file = file_out, append = TRUE)
      write(paste("num-groups        =", num_groups,  sep = "\t"), file = file_out, append = TRUE)
      write(paste("test_notes        =", test_notes,  sep = "\t"), file = file_out, append = TRUE)
    }

    my_data = data.matrix(read.table(data_file, row.names=1, header=TRUE, sep="\t", comment.char="", quote=""))
    my_groups <<- data.matrix(scan(file = groups_file, what = "character", sep = "\t", quiet=TRUE))
    num_groups = nlevels(as.factor(my_groups))
    num_samples = dim(my_data)[2]

    sig_test = NA
    test_notes = "none"

    ### CHECK DATA FOR MINIMUM STATISTICAL REQUIREMENTS
    if(num_groups==1|num_samples<=2|num_samples!=dim(my_data)[1]){
      write("Minimum analysis requirements not met - no test could be selected:\n", file = file_out)
      write(paste("data_type   =", data_type, sep = "\t"  ), file = file_out, append = TRUE)
      write(paste("paired      =", paired, sep = "\t"     ), file = file_out, append = TRUE)
      write(paste("num_samples =", num_samples, sep = "\t"), file = file_out, append = TRUE)
      write(paste("num_groups  =", num_groups, sep = "\t" ), file = file_out, append = TRUE)
      write(paste("test_notes  =", test_notes,  sep = "\t"), file = file_out, append = TRUE)
      write(("\nSingle sample analyses are not supported.
The minimum analysis requirements are:
     (1) at least two groups of samples(metagenomes)
     (2) at least one group with two or more samples."
             ),                               file = file_out, append = TRUE)
    }

    special_case <<- 0
    group_1_size <<- 0
    group_2_size <<- 0
    ### HANDLE SPECIAL CASE - two groups, one of which has just a single measure
    test_two_groups<<-function(my_groups){
      #if(num_groups==2){
      group_names <<- levels(as.factor(my_groups))
      group_1 <<- group_names[1]
      group_2 <<- group_names[2]
      group_1_size <<- 0
      group_2_size <<- 0
      for (i in my_groups){
        #print(paste("i: ", i))
        #print(paste("my groups i: ", my_groups[i]))
        #if(identical(as.character(my_groups[i]), as.character(group_1))){
        if(identical(as.character(i), as.character(group_1))){
          group_1_size <<- group_1_size + 1
          #print(paste("group_1_size", group_1_size))
        }
        #if(identical(as.character(my_groups[i]), as.character(group_2))){
        if(identical(as.character(i), as.character(group_2))){
          group_2_size <<- group_2_size + 1
          #print(paste("group_2_size", group_2_size))
          #print(paste("group_2_size", group_2_size))
        }
      }
      if(group_1_size==1|group_2_size==1){
        special_case <<- 1
        #print(paste("special_case", special_case))
      }
      #}
      #return(list(group_1_size, group_2_size, special_case))
    }

    #print(paste("num_groups", num_groups))
    #print(paste("group_1_size", group_1_size))
    #print(paste("group_2_size", group_1_size))
    #print(paste("special_case", special_case))

    ### CHOOSE MOST APPROPRIATE TEST
    if (data_type=="normalized"){
      if(num_groups==2){
        #(group_1_size, group_2_size) <<- test_two_groups(my_groups)
        test_two_groups(my_groups)
        if(paired==TRUE){
          if(special_case==0){
            sig_test = "t-test-paired" # t_test
            # test_notes
            write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
          }else{
            sig_test = "ANOVA_repeat_measures (not yet supported: you could try ANOVA-one-way, note that it assumes independent measures)"
            test_notes = "One of the two groups has just a single measure.  t-test cannot be used because it requires at least 2 measures per group.  The suggested ANOVA \"can\" be used, but statistical power is likely to be very low."
            write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
          }
        }else{
          if(special_case==0){
            sig_test = "t-test-un-paired" # t_test
            # test_notes
            write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
          }else{
            sig_test = "ANOVA-one-way"
            test_notes = "One of the two groups has just a single measure.  t-test cannot be used because it requires at least 2 measures per group.  The suggested ANOVA \"can\" be used, but statistical power is likely to be very low."
            write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
          }
        }
      }else if (num_groups>2){
        if(paired==TRUE){
          sig_test = "ANOVA-repeat-measures" # ANOVA
          test_notes = "not currently supported - you may be able to try ANOVA-one-way, note that it assumes independent measures"
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
        }else{
          sig_test = "ANOVA-one-way" # ANOVA
          # test_notes
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
        }
      }
    }else if (data_type=="raw"){
      if (num_groups==2){
        test_two_groups(my_groups)
        if(paired==TRUE){
          if(special_case==0){
            sig_test = "Wilcoxon-paired" # wilcoxon
            # test_notes =
            write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
          }else{
            sig_test = "Wilcoxon-paired" # wilcoxon
            test_notes = "one of the two groups has just a single sample; statistical power is likley to be very low"
            write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
          }

        }else{
          if(special_case==0){
            sig_test = "Mann-Whitney_un-paired_Wilcoxon" # wilcoxon
            test_notes = "this test is also known as the Mann-Whitney U test, the Mann-Whitney_Wilcoxon test, or the Wilcoxon rank-sum test"
            write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
          }else{
            sig_test = "Mann-Whitney_un-paired_Wilcoxon" # wilcoxon
            test_notes = "one of the two groups has just a single sample; statistical power is likley to be very low"
            write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
          }
        }

      }else if (num_groups>2){
        if(paired==TRUE){
          sig_test = "Friedman-test" # kruskal_wallis
          test_notes = "not-yet-supported: you could try an ANOVA-one-way on the normalized data, note that ANOVA-one-way assumes independent measures"
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
        }else{
          sig_test = "Kruskal-Wallis" # kruskal_wallis
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out, test_notes)
        }
      }
    }else{
      sig_test = "NONE"
      test_notes = "no test could be found for the selected data - please try again"
      write_out(data_type, num_samples, num_groups, sig_test, file_out, test_notes)
      # stop("No test could be selected")
    }
  }


# helperfunctions.R
# -------------------------------------------------------------------------
# Functions to help visualize data for Assignment 3

# Source: https://github.com/info-201a-wi22/a2-starter-smoham2/blob/main/a2-functions.R

library("tidyverse")
library("RcppRoll")

# Data loading functions -----

# Get the most recent national incarceration data from the Vera Project
load_incarceration_trends <- function() {
  filename <- "https://raw.githubusercontent.com/vera-institute/incarceration-trends/master/incarceration_trends.csv"
  df <- read.csv(filename, header = TRUE, stringsAsFactors = FALSE)
  return(df)
}

# Get the most recent jail jurisdiction trends for the united states
load_incarceration_trends_jail_jurisdiction <- function() {
  filename <- "https://raw.githubusercontent.com/vera-institute/incarceration-trends/master/incarceration_trends_jail_jurisdiction.csv"
  df <- read.csv(filename, header = TRUE, stringsAsFactors = FALSE)
  return(df)
}

# Data wrangling functions -----
# This function computes rolling averages for the prison population counts. A rolling average has a window size.
#
# NOTE: Yearly counts must have been computed before calling
#       this function
moving_avg_counts <- function(national_data, window_size = 7) {

  # Check that daily counts have been computed and added to national
  if ("new_black_jail_pop" %in% colnames(national_data) == FALSE ||
      "new_white_jail_pop" %in% colnames(national_data) == FALSE) {
    message("Error: new_black_jail_pop and new_white_jail_pop columns unassiged in national data frame.")
    stop()
  }

  # If the window size is less than one, set it to 1. This is an
  # odd case because there is no average at all!
  if (window_size < 1) {
    warning("Setting window_size to 1.")
    window_size <- 1
  }

  # If the window size is larger than the data frame, set it
  # to the size of the data, which means we will compute
  # the average of the all rows - this is also an odd case!
  # (Later we will learn how "throw an error message" and stop.)
  if (window_size > nrow(national_data)) {
    warning("Setting window_size to size of data frame.")
    window_size <- nrow(national_data)
  }

  # new_black_jail_pop - Uses the function `roll_mean()` to compute the rolling
  # averages.  The rolling averages are put into a vector called
  # `avg_black_jail_pop `.
  avg_black_jail_pop <- round(
    roll_mean(
      national_data$new_black_jail_pop,
      n = window_size,
      na.rm = TRUE
    ),
    1
  )

  # Do the same for new white jail population
  avg_white_jail_pop <- round(
    roll_mean(
      national_data$new_white_jail_pop,
      n = window_size,
      na.rm = TRUE
    ),
    1
  )

  pad_vector <- rep(0, window_size - 1)
  avg_black_padded <- append(pad_vector, avg_black_jail_pop)
  avg_white_padded <- append(pad_vector, avg_white_jail_pop)

  # Now, assign the rolling averages to the `national_data` data frame
  national_data$rolling_avg_black_pop <- avg_black_padded
  national_data$rolling_avg_white_pop <- avg_white_padded
  return(national_data)
}

# Plotting charts ----

plot_moving_avg_jail_pop_by_race <- function(national_data, window_size, race, column) {

  # We initialize the labels of the chart. Each of these labels
  # will be placed on the chart in standard positions
  plot_x_axis <- "Year"
  plot_y_axis <- "Jail Population Growth"
  plot_title <- paste0("United States ", race, " Jail Population Growth")
  plot_subtitle <- paste0(window_size, "- Year Running Average ", race, " Jail Population Counts (1970-2018)")
  plot_alt <- "Incarceration Trends from 1970-2018 Data from The Vera Project."
  plot_caption <- paste0(
    "UW INFO 201 Assignment 3 .\n Data from:",
    "The Vera Project. (2022). ",
    "Incarceration Trends\n",
    "Data in the United States. Retrieved [Febuary, 2022],\n",
    "https://github.com/vera-institute/incarceration-trends#documentation."
  )

  # This is the code for plotting the chart
  p <- ggplot(

    # This is the data frame, containing data that we want to plot
    national_data,

    # This is how we map columns in the `national` data frame to coordinates on the plot
    # Notes:
    #   (1) We need to turn the `date` string into a `date` data type
    #   (2) Note that x is the date dimension and y the counts

    aes(x = as.Date(ISOdate(year, 1, 1)), y = column)
  ) +

    # This is how to draw the curve. Size is the thickness of the line.
    # For standard names of colors, see: http://sape.inf.usi.ch/quick-reference/ggplot2/colour
    geom_line(
      color = "black",
      size = 0.75
    ) +

    # This is how to fill in under the curve
    geom_area(fill = "grey") +

    # %B, \n, and %Y are special characters for formatting dates
    # They refer to Month, newline (aka line break or
), and Year respectively
    scale_x_date(date_labels = "%Y") +

    # Show the y-scale with commas - e.g., 200,000 (instade of 2-E06)
    scale_y_continuous(labels = scales::comma) +

    # The strings for the chart are initialized above. We draw them on the plot
    # as follows.
    labs(
      x = plot_x_axis,
      y = plot_y_axis,
      title = plot_title,
      subtitle = plot_subtitle,
      caption = plot_caption,
      alt = plot_alt
    )
}

# This function creates a chart of the rolling averages of
# black and white jail populations
plot_moving_avg_jail_pop <- function(national_data, window_size) {

  # We initialize the labels of the chart. Each of these labels
  # will be placed on the chart in standard positions
  plot_x_axis <- "Year"
  plot_y_axis <- "Jail Population Growth"
  plot_title <- "United States Black and White Jail Population Growth"
  plot_subtitle <- paste0(window_size, "- Year Running Average of Black and White Jail Population Counts (1970-2018)")
  plot_alt <- "Incarceration Trends from 1970-2018 Data from The Vera Project."
  plot_caption <- paste0(
    "UW INFO 201 Assignment 3 .\n Data from:",
    "The Vera Project. (2022). ",
    "Incarceration Trends\n",
    "Data in the United States. Retrieved [Febuary, 2022],\n",
    "https://github.com/vera-institute/incarceration-trends#documentation."
  )

  # This is the code for plotting the chart
  p <- ggplot(

    # This is the data frame, containing data that we want to plot
    national_data,

    # This is how we map columns in the `national` data frame to coordinates on the plot
    # Notes:
    #   (1) We need to turn the `date` string into a `date` data type
    #   (2) Note that x is the date dimension and y the counts

    aes(x = as.Date(ISOdate(year, 1, 1)))
  ) +

    # This is how to draw the curve. Size is the thickness of the line.
    # For standard names of colors, see: http://sape.inf.usi.ch/quick-reference/ggplot2/colour
    geom_line(aes(y = rolling_avg_black_pop, color = "Black", size = 0.75), size = 0.75) +
    scale_color_discrete(name = "Race") +
    geom_line(aes(y = rolling_avg_white_pop, color = "White", size = 0.75), size = 0.75) +

    # %B, \n, and %Y are special characters for formatting dates
    # They refer to Month, newline (aka line break or
), and Year respectively
    scale_x_date(date_labels = "%Y") +

    # Show the y-scale with commas - e.g., 200,000
    scale_y_continuous(labels = scales::comma) +

    # The strings for the chart are initialized above. We draw them on the plot
    # as follows.
    labs(
      x = plot_x_axis,
      y = plot_y_axis,
      title = plot_title,
      subtitle = plot_subtitle,
      caption = plot_caption,
      alt = plot_alt
    )
}


#Rienje Veenhof and Frank Fluit
#Project for the course Geoscripting at Wageningen University
#28-1-2021
#This script has two functions. The first function will download the GADM file of
#a specified country code and region (default = only the outline). We first wanted
#to use this for all countries in Asia, but the files were too big, so we created the
#second function which downloads country outline from the wrld_simpl database. This
#function takes a vector of country codes and selects those out the whole wrld_simple dataset.
#We now only use the first function for Nepal.

#install needed libraries
if(!"raster" %in% rownames(installed.packages())){install.packages("raster")}
library(raster)
if(!"sf" %in% rownames(installed.packages())){install.packages("sf")}
library(sf)
if(!"maptools" %in% rownames(installed.packages())){install.packages("maptools")}
library(maptools)

#first function
get_adm_areas <- function(country_code, region=FALSE){
  if (region) {
    adm_area <- getData(name="GADM", country=country_code, level=2, path = 'data')
  } else {
    adm_area <- getData(name='GADM', country=country_code, level = 0, path='data')
  }
  adm_area <- sf::st_as_sf(adm_area)
  return(adm_area)
}

#second function
get_many_adm_areas <- function(countries) {
  data(wrld_simpl)
  world <- st_as_sf(wrld_simpl)
  adm_areas <- world[world$ISO3 %in% countries,]
  return(adm_areas)
}

#End


#! /usr/bin/Rscript --vanilla

library("rjson")

args = commandArgs(TRUE)

values = fromJSON(args[2])

print(shapiro.test(values))


policy2res <- function(policycur,hinitial=1,Mhobs.cur=Mhobs.combo,MODEL=F,save_curworld=F,nparams=NULL,eps=.1,...){

#depends on: mutruemat

ytotaldist <- rep(0,nworlds)
ptotaldist <- rep(0,nworlds)

wstardist <- array(0, dim=c(nrow(d),hend,nworlds) )
pstardist <- array(0, dim=c(nrow(d),hend,nworlds) )

#save CI for each parameter at each time
paramstardist <- NULL
if (MODEL) paramstardist <- array(0, dim=c(2*nparams,hend,nworlds) )

start0 <- Sys.time()
for ( i in 1:nworlds){
#starti <- Sys.time()
#print(starti)

wstar <- matrix(0, nrow(d), hend)
  wstar[,1:hinitial] <- 1/K
mhstar <- matrix(0, nrow(d), hend)
yhstar <- matrix(0, nrow(d), hend)
mtstar <- matrix(0, nrow(d), hend)
ytstar <- matrix(0, nrow(d), hend)
if (MODEL) paramstar <- matrix(0, 2*nparams, hend) #save CI for each parameter at each time

for (hh in 1:hinitial){
  mhstar[,hh] <- round(Mhobs.cur[ ,hh]*wstar[,hh])
  yhstar[,hh] <- rbinom( nrow(d), mhstar[,hh], mutruemat[,hh])
}
  mtstar[,1:hinitial] <- t( apply( as.matrix(mhstar[,1:hinitial]), 1, cumsum) )
  ytstar[,1:hinitial] <- t( apply( as.matrix(yhstar[,1:hinitial]), 1, cumsum) )
  outcur <- policycur(m=mtstar[,hinitial],y=ytstar[,hinitial],eps=eps)
  #save( outcur, file=paste(path,"RPM.Logit.Heter.Res.OneWorld.t",hh,".RData",sep="") )
  wstar[,hinitial+1] <- outcur$w
  if (MODEL) paramstar[,hinitial+1] <- c( apply(outcur$paramvec,2,quantile,c(.025,.975))  ) #save CI for each parameter at each time
  #
for (hh in (hinitial+1):(hend-1)){
  #print(paste("start period",hh))
  mhstar[,hh] <- round(Mhobs.cur[ ,hh]*wstar[,hh])
  yhstar[,hh] <- rbinom( nrow(d), mhstar[,hh], mutruemat[,hh])
  mtstar[,hh] <- apply(mhstar[,1:hh],1,sum)
  ytstar[,hh] <- apply(yhstar[,1:hh],1,sum)
  outcur <- policycur(m=mtstar[,hh],y=ytstar[,hh],eps=eps)  ###***** TIME CONSUMING ****
  #save( outcur, file=paste(path,"RPM.Logit.Heter.Res.OneWorld.t",hh,".RData",sep="") )
  wstar[,hh+1] <- outcur$w
  if (MODEL) paramstar[,hh+1] <- c( apply(outcur$paramvec,2,quantile,c(.025,.975))  ) #save CI for each parameter at each time
}
hh <- hend
  mhstar[,hh] <- round(Mhobs.cur[ ,hh]*wstar[,hh])
  yhstar[,hh] <- rbinom( nrow(d), mhstar[,hh], mutruemat[,hh])
  mtstar[,hh] <- apply(mhstar[,1:hh],1,sum)
  ytstar[,hh] <- apply(yhstar[,1:hh],1,sum)

mstartotal <- sum(mhstar)
ystartotal <- sum(yhstar)
pstar <- apply(ytstar,1,cumsum)/apply(mtstar,1,cumsum)
pstartotal <- sum(yhstar)/sum(mhstar)

ytotaldist[i] <- ystartotal
ptotaldist[i] <- pstartotal

wstardist[,,i] <- wstar
pstardist[,,i] <- pstar

if (MODEL) paramstardist[,,i] <- paramstar

if (save_curworld){
  reslist_curworld <-
    list(
      ytotaldist=ytotaldist[i],
      ptotaldist=ptotaldist[i],
      wstardist=wstardist[,,i],
      pstardist=pstardist[,,i],
      paramstardist=paramstardist[,,i]
    )
  #save(reslist_curworld , file=paste(path,"Reslist_cur.RPM.Logit.Heter.World.",1000+i,".RData",sep="") )
} # save_curworld

endi_time <- Sys.time()
peri_time <- (endi_time - start0)/i
remain_time <- peri_time*( nworlds - i )

if ((i%%10)==0) print(paste("Finished", i, "out of", nworlds, "at", endi_time ))

if (i==1) print(paste("First iter started at", start0, "finished at", endi_time))
#endi <- Sys.time()
#print(endi - starti)

}

reslist <-
  list(
    ytotaldist=ytotaldist,
    ptotaldist=ptotaldist,
    wstardist=wstardist,
    pstardist=pstardist,
    paramstardist=paramstardist
    )
return(reslist)
} ## END FUNCTION policy2res


myTestRule {
#Workflow operation to loop until condition is false
#Input parameter is
#  Logical expression which evaluates to TRUE or FALSE
#  Workflow that is executed, defined within brackets
#Output from running the example is:
#  abcd
    *A = list("a","b","c","d");
    *B = "";
    *I=0;
    while(*I < 4) {
        *B = *B ++ elem(*A, *I);
        *I = *I + 1;
    }
    writeLine("stdout", *B);
}
INPUT null
OUTPUT ruleExecOut


library(dplyr)
library(tidyr)
library(mclust)
library(ggplot2)
load("voting_results.rda")

a <- voting_results %>%
    filter( Race %in% c("UNITED STATES SENATOR", "GOVERNOR/LT GOVERNOR", "US REPRESENTATIVE")) %>%
    filter(! Value %in% "Registered Voters") %>%
    group_by(DISTRICT, Race) %>%
    mutate(Result = n/sum(n)) %>%
    filter(Value == "Sullivan, Dan" | Value == "Walker/Mallott" | Value == "Young, Don") %>%
    select(DISTRICT, Race, Result) %>%
    unique() %>%
    as.data.frame() %>%
    spread(Race, Result)

b <- voting_results %>%
    filter( Race %in% c("MOA Proposition #1", "Ballot Measure 2 - 13PSUM", "Ballot Measure 3 - 13MINW", "Ballot Measure 4 - 12BBAY")) %>%
    filter(! Value %in% "Registered Voters") %>%
    group_by(DISTRICT, Race) %>%
    mutate(Result = n/sum(n)) %>%
    filter(Value == "YES") %>%
    select(DISTRICT, Race, Result) %>%
    unique() %>%
    as.data.frame() %>%
    spread(Race, Result)

Prop_Results <- cbind(a,b[,2:5])
rownames(Prop_Results) <- Prop_Results$DISTRICT
Prop_Results<- select(Prop_Results, -DISTRICT)  %>%
    as.matrix()

input <- list(clusters = 3, races = "MOA Proposition #1", bindwidth = 0.4, model = "EEV", checkGroup = c(1,2,3,4))
shinyServer(function(input, output, session) {

ggobjFUNCTION <- reactive({

#Prop_Results <- Prop_Results[,input$checkGroup]

princomp_obj <- princomp(Prop_Results)
pca <- princomp_obj$scores

fit <- Mclust(pca, G= input$clusters, modelNames = input$model)
#plot3d(pca[,1:3], col = fit$classification, size = 10)

ggobj <- data.frame(District = rownames(pca), pca, classification = fit$classification) %>%
    as.data.frame()
rownames(ggobj) <- NULL
ggobj$District <- substr(ggobj$District, 8, 50)

p1 <- ggplot(data = ggobj, aes(x = Comp.1, y = Comp.2, color = factor(classification))) +
     geom_text(aes(label = District, vjust = -.30, size = 1.5)) + geom_point() + theme(legend.position="none")

p2 <- ggplot(data = ggobj, aes(x = Comp.1, fill = factor(classification))) + geom_histogram(stat = "bin", binwidth = input$bin_width) +
    theme(legend.position="none")

list(p1 = p1, p2 = p2, princomp1 = princomp_obj)
})

output$textscatter <- renderPlot({
    print(ggobjFUNCTION()$p1)
    })

output$histogram <- renderPlot({
  print(ggobjFUNCTION()$p2)
})
#biplot(princomp_obj)
# p <- ggpairs(data = ggobj[,2:5])

#mega_ggobj <- makePairs(ggobj[,2:5])
#mega_ggobj <- data.frame(mega_ggobj$all,
#                         District = rep(ggobj$District, length = nrow(mega_ggobj$all)),
#                         classification = rep(fit$classification, length = nrow(mega_ggobj$all)))

#ggplot(data = mega_ggobj, aes_string(x = "x", y = "y")) +
#    facet_grid(xvar ~ yvar, scales = "free") + #geom_point(aes(color = factor(classification))) +
#    geom_text(data = mega_ggobj, aes(label = mega_ggobj$District, color = factor(classification), size = 2))
})


library(randomForest)
library(ROCR)
library(MLmetrics)
library(caret)
# read data
finalData <- read.csv(file = "./FinalData.csv", sep = ",", header = TRUE, stringsAsFactors = FALSE)
finalData$target_id <- as.character(finalData$target_id)
# drop possible all NA columns
finalData <- finalData[, !apply(is.na(finalData), 2, all)]
# keep way from training data with class = NA
classNaData <- finalData[which(is.na(finalData$DE)),]
# clear data - keep only ones with meaningful classes
finalData <- finalData[which(!is.na(finalData$DE)),]
# replace NAs with 0
finalData[is.na(finalData)] <- 0
# convert character columns to factors
finalData[sapply(finalData, is.character)] <- lapply(finalData[sapply(finalData, is.character)],as.factor)
# remove factors with many levels
finalData <- finalData[, which(lapply(X = finalData, FUN = nlevels) < 50)]
# convert boolean DE column to factor
finalData$DE <- as.factor(finalData$DE)
# set seed
set.seed(123)
# shuffle data
finalData <- finalData[sample(nrow(finalData)),]
# split to training and testing datasets
rndsplt <- sample(x = 2, size = nrow(finalData), replace = TRUE, prob = c(0.99,0.01))
trainingData <- finalData[rndsplt == 1, ]
testingData <- finalData[rndsplt == 2, ]
numModels <- 20 # increase
time.taken <- data.frame(n = numeric(), time.t = numeric())
n <- nrow(trainingData)
# search grid
rfGrid <- expand.grid(ntreeArg = (1:5)*500,
                      replaceAge = c(TRUE, FALSE),
                      mtryArg = (round(sqrt(length(finalData))) + (-2:2)),
                      nodesize = c(1, 3, 5, 7)
)
colnames(rfGrid) <- c("ntree", "replace", "mtry", "nodesize")
currParams <- rfGrid[sample(nrow(rfGrid), size = 1),] #sample random combination and train the forest
# measure time while decreasing training
for (i in 1:numModels){
  print(paste0("building model", i))
  # indx <- sample(n, floor((1/i)*n))
  trainData <- trainingData[c(1:n),]
  sampsizeArg  = c(nrow(trainData), round(nrow(trainData)*.9), round(nrow(trainData)*.8), round(nrow(trainData)*.75))
  samp <- sampsizeArg[sample(length(sampsizeArg), 1)]
  start.t <- Sys.time()
  # Train Model
  rfModel <- randomForest(x = trainData[,-ncol(trainData)], y = trainData$DE,
                          ntree = currParams$ntree,
                          replace = currParams$replace,
                          mtry = currParams$mtry,
                          sampsize = samp,
                          nodesize = currParams$nodesize)
  end.t <- Sys.time()
  time.taken[i,1] <- nrow(trainData)
  time.taken[i,2] <- end.t - start.t
  # Predict
  pred <- predict(object = rfModel, testingData[,-ncol(testingData)], type = 'response')
  predprob <- predict(object = rfModel, testingData[,-ncol(testingData)], type = 'prob')
  # Evaluate model
  # Confusion Matrix
  # confusionMatrix(data = pred, reference = testingData$DE, positive = 'TRUE')
  # Accuracy
  acc <- Accuracy(y_pred = pred, y_true = testingData[,ncol(testingData)])
  pred_obj = prediction(predprob[,2], testingData[,ncol(testingData)], label.ordering = c("FALSE", "TRUE"))
  # AUC
  areauc <- performance(prediction.obj = pred_obj, measure = "auc")@y.values
  # F1 score
  f1 <- F1_Score(y_true = testingData$DE, y_pred = pred, positive = 'TRUE')
  n <- n - 150
}
saveRDS(object = time.taken, file = "./test/rfDecTrainData.rds")


\name{summary.PA_result}
\alias{summary.PA_result}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
 Summary of the estimated attachment function
}
\description{
  This function outputs summary information of the estimated attachment function from the corrected Newman's method or the Jeong's method.
}
\usage{
  \method{summary}{PA_result}(object,
                           ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{object}{
    An object of class \code{PA_result}, containing the estimated attachment function and the estimated attachment exponenet from either \code{\link{Newman}} or \code{\link{Jeong}} functions.
  }
  \item{\dots}{
    Additional parameters to pass onto the \code{plot} function.
  }
}
\value{
  Summary information of the estimated attachment function.
}
\author{
  Thong Pham \email{thongphamthe@gmail.com}
}
\examples{
  library("PAFit")
  net        <- generate_net(N = 1000 , m = 1 , mode = 1 , alpha = 1 , s = 0)
  net_stats  <- get_statistics(net)
  result     <- Newman(net, net_stats)
  summary(result)
}


library(sf)
library(tidyverse)

raw_data = readRDS("data/river_queries/raw_data.RDS")

set.seed(2832)
regression_data = sample_n(raw_data, 10000)

regression_data = regression_data %>%
  select(text, clean_tweet, WBID) %>%
  mutate(
    senti_nrc = sentiment(
      # NRC sentiment from Mohammad & Turney (2010)
      regression_data$clean_tweet,
      polarity_dt = lexicon::hash_sentiment_nrc,
      hyphen = " "
    ),
    senti_nrc = senti_nrc$sentiment
  ) %>%
  mutate(
    senti_sentiword = sentiment(
      #  Baccianella, Esuli and Sebastiani's (2010)
      regression_data$clean_tweet,
      polarity_dt = lexicon::hash_sentiment_sentiword,
      hyphen = " "
    ),
    senti_sentiword = senti_sentiword$sentiment
  ) %>%
  mutate(
    senti_jockers_rinkers = sentiment(
      # Jockers (2017) & Rinker's augmented Hu & Liu (2004)
      regression_data$clean_tweet,
      polarity_dt = lexicon::hash_sentiment_jockers_rinker,
      hyphen = " "
    ),
    senti_jockers_rinkers = senti_jockers_rinkers$sentiment===
  ) %>%
  mutate(
    senti_cnet = sentiment(
      # Cambria, Poria, Bajpai,& Schuller's (2016)
      regression_data$clean_tweet,
      polarity_dt = lexicon::hash_sentiment_senticnet,
      hyphen = " "
    ),
    senti_cnet = senti_cnet$sentiment
  ) %>%
  mutate(
    senti_google = sentiment(
      # Taboada, Brooke, Tofiloski, Voll, & Stede's (2011)
      regression_data$clean_tweet,
      polarity_dt = lexicon::hash_sentiment_socal_google,
      hyphen = " "
    ),
    senti_google = senti_google$sentiment
  )

scaleit = function(x) {
  (x - min(x)) / (max(x) - min(x))
}

for (i in 1:nrow(regression_data)) {
  regression_data$log_senti[i] = mean(regression_data$senti_nrc[i] + regression_data$senti_sentiword[i] + regression_data$senti_jockers_rinkers[i] + regression_data$senti_cnet[i] + regression_data$senti_google[i])
}

WB = as.data.frame(aggregate(scale_senti ~ WBID, regression_data, mean))

waterbody = read_sf("data/web/wb_cat_class.geojson") %>%
  st_drop_geometry() %>%
  select(WBID,
         status,
         senticent_polarity) %>%
  na.omit(status) %>%
  mutate(status = factor(status, levels = c('Bad', 'Poor', 'Moderate', 'Good', 'NA')))

reg_test = inner_join(WB,waterbody)

ggplot2::ggplot(reg_test, aes(x = status, y = scale_senti, group = status)) +
  ggplot2::geom_boxplot(aes(fill = status)) +
  theme_tinyhand()

summary(lm(scale_senti ~ status, data = reg_test))


library(lattice)

plotFunction <- function(func, start, end) {
  x <- seq(from = start, to = end, by = 1)
  # <Probe />
  y <- lapply(x, (function(n) func(n)))
  svg()
  print(xyplot(y ~ x, type="p", cex=2, pch=16))
  grDevices:::svg.off()
}


#!/usr/bin/env Rscript
library(readr)
require(MESS)
require(Bolstad2)
# con <- file("energyPlot.txt")
# sink(con, append=TRUE)
# sink(con, append=TRUE, type="message")

# source("integrateEnergy.r", echo=TRUE, max.deparse.length=10000)

# sink(type="message")

# cat(readLines("energyPlot.txt"), sep="\n")
# testRstudioAUC <- read_delim('1.txt', " ", escape_double = FALSE, col_names = FALSE, trim_ws = TRUE)
# x <- (testRstudioAUC$X1)
# y <- (testRstudioAUC$X2)
# data <- sintegral(x,y)$int
# data <- auc(x, y, type='spline')
# write.table(data,quote=FALSE,append=TRUE,row.names=FALSE,col.names=FALSE,sep=" ", "energyPlot.txt")
for(j in c(32, 64, 128)){
    for(i in c(2048, 4096, 8192, 12288)){
        infile <- paste("./", i, "/", j, "/16.txt", sep="")
        # infile <- paste(infile, "/32/16.txt")
        # infile <- paste("/32/","16.txt",sep="")
        outfile <- paste("energyTiles", j, "Plot.txt", sep="")
        testRstudioAUC <- read_delim(infile, " ", escape_double = FALSE, col_names = FALSE, trim_ws = TRUE)
        x <- (testRstudioAUC$X1)
        y <- (testRstudioAUC$X2)
        data <- paste(" ", sintegral(x,y)$int, sep="")
        # data <- auc(x, y, type='spline')
        # data <- read.table(infile,header=TRUE,sep=",",row.names=NULL)
        # colnames(data)[1] = "time"
        write.table(data,quote=FALSE,append=TRUE,row.names=FALSE,col.names=FALSE,sep=" ", outfile)
        # sink()
    }
}


require(lubridate)
require(tidyverse)
theme_set(theme_bw())

# Datos de Casos de Gobierno Nacional
#
csv_fname <- "Data/covid_19_casos.csv"
cor_nac <- read_csv2(csv_fname)

# Detectar asintomaticos usando la fecha de inicio de sintomas
#
#cor_asi <- filter(cor_nac,is.na(fis),clasificacion_resumen=="Confirmado",grepl("CONTACTO",antecedente_epidemiologico),provincia)

# Datos de Casos de Gobierno Nacional
#
corConf <- cor_nac %>% filter(clasificacion_resumen!="Descartado")  %>% mutate(nue_clasif=ifelse(clasificacion_resumen=="Confirmado",clasificacion_resumen,clasificacion)) %>% group_by(provincia_residencia,nue_clasif) %>% summarise(n=n()) %>% mutate(porcent= n/sum(n)) # %>% filter(grepl("muestra",clasificacion,ignore.case = TRUE))

ggplot(corConf, aes(x=provincia_residencia,y=porcent,fill=nue_clasif)) + geom_bar(stat="identity") +
  theme_minimal() + scale_fill_viridis_d(name="Clasificación") + theme(axis.text.x = element_text( angle=90,hjust=1)) + ggtitle("Casos Confirmados/Sospechosos % Covid-19 al 19/05 by @larysar") + coord_flip()

```


options(echo=TRUE) # if you want see commands in output file
args <- commandArgs(trailingOnly = TRUE)
# print(args)
# print(args[[1]])

# q()

library("missMDA")
d <- read.table(args[[1]], sep="\t", header=TRUE, na.strings="NA", colClass=c('factor'))
res.impute <- imputeMCA(d, threshold=0.015, maxiter=9000)
write.table(res.impute$completeObs, file=args[[2]], sep="\t", quote=FALSE)


#
char <- function(x) as.character(x)
num <- function(x) as.numeric(x)

simpleCap <- function(x) {
  s <- strsplit(x, " ")[[1]]
  paste(toupper(substring(s, 1,1)), substring(s, 2),
        sep="", collapse=" ")
}

recode_partynames <- function(x, longnames = FALSE) {
  require(stringr)
  x_recoded <- x %>% str_replace("cdu", "Union") %>%
    str_replace("fdp", "FDP") %>%
    str_replace("spd", "SPD") %>%
    str_replace("gru", "Grüne") %>%
    str_replace("lin", "Die Linke") %>%
    str_replace("afd", "AfD") %>%
    str_replace("oth", "Andere")
  if(longnames == TRUE) {
    x_recoded <- x_recoded %>% str_replace("Grüne", "B'90/Die Grünen") %>% str_replace("Union", "CDU/CSU") %>% str_replace("Linke", "Die Linke")
  }
  x_recoded
}

recode_years <- function(x) {
  x_recoded <- x %>% str_replace("19|20", "'")
  x_recoded
}

# function to get quantities of interest from JAGS MCMC matrix
jags_summary <- function(x) {
  dat <- data.frame(var = colnames(x),
                    mean = apply(x, 2, mean),
                    sd = apply(x, 2, sd),
                    q95lo = apply(x, 2, quantile, probs = 0.025),
                    q95hi = apply(x, 2, quantile, probs = 0.975),
                    q90lo = apply(x, 2, quantile, probs = 0.05),
                    q90hi = apply(x, 2, quantile, probs = 0.95),
                    q80lo = apply(x, 2, quantile, probs = 0.10),
                    q80hi = apply(x, 2, quantile, probs = 0.90),
                    stringsAsFactors = FALSE
  )
  dat
}

### Transform Mean and Variance from Normal Prior to Beta

estBetaParams <- function(mu, var) {
  alpha <- ((1 - mu) / var - 1 / mu) * mu ^ 2
  beta <- alpha * (1 / mu - 1)
  return(params = c(alpha,beta))
}

### GGplot Functtions

# Create a laballer function

party_labeller <- function(variable,value){

  party_names <- list(
    'cdu'="CDU/CSU",
    'fdp'="FDP",
    'gru'="B90/Die Grünen",
    'lin'="Die Linke",
    'spd'="SPD",
    "afd"="AfD"
  )

  return(party_names[as.character(value)])
}

party_labeller_eng <- function(variable,value){

  party_names <- list(
    'cdu'="CDU/CSU",
    'fdp'="FDP",
    'gru'="A90/The Greens",
    'lin'="The Left",
    'spd'="SPD",
    "afd"="AfD"
  )

  return(party_names[as.character(value)])
}