#       __  ___
#      /  |/  /___ _______________
#     / /|_/ / __ `/ ___/ ___/ __ \
#    / /  / / /_/ / /  / /__/ /_/ /
#   /_/  /_/\__,_/_/   \___/\____/
#  _       ___      __  __    ___
#  | |     / (_)____/ /_/ /_  / (_)___
#  | | /| / / / ___/ __/ __ \/ / / __ \
#  | |/ |/ / / /  / /_/ / / / / / / / /
#  |__/|__/_/_/   \__/_/ /_/_/_/_/ /_/-------------------------------------------------------------------------

#S2876507

# Running instructions: Press Ctrl+A, then Ctrl+Enter. "plyr" package must be installed.
# If you zoom in on the graph, drag the window a bit to the right, until the plots are roughly of quadratic shape (nicer that way).

#sets working directory to source file location (RSTUDIO ONLY! comment out if not rstudio.)
library("rstudioapi")
library("plyr")
setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
source("actr_functions.r")
source("plotting_functions.r")

# exp_dict according to Taatgen, van Rijn and Anderson (2004)
exp_dict <- list(
    tick_increment = 1.1, # (default: 1.1)
    b = sample(0.0125:0.0126, 1, replace = TRUE), # (default 0.015)
    tick_base = 11, # (default: 11)
    decay = -1.5, #decay parameter, (default: 0.5)
    amount_subjects = 5, # subjects per interval
    amount_trials = 50, # amount of trials per subject and per interval (default: 50)
    amount_training = 5,
    subject_data = data.frame(matrix(ncol = 7, nrow = 0)), #tmp data storage
    parm_t = 60, # (default: 1)
    point_gain = 5, # (default: 5)
    no_penalty = 0,
    low_penalty = -5, # (default: -5)
    high_penalty = -30, # (default: -30)
    yellowDot_time = sample(1000:2000, 1, replace = TRUE),
    base_interval = 700, # (default: 750)   sample(725:775, 1, replace = TRUE)
    leeway = 0.15, #percentage of space around base interval that counts as correct (default: 0.15)
    # adaption_rate = 50,
    condition_order = c(1, 2, 3, 1)
)

experiment_setup <- function(current_subject) #I want setup the experiment parameters for each subject, once
{
    list(real_time = 0, #this is the subjects objective time in ms. this will stay with the subject for the duration of the experiment
         subject_nr = current_subject,
         points = 0,
         recalled_interval = 0,
         trialnr = 0,
         DecMem = matrix(NA, 100, 500),
         cond = 0
    )
}

trial <- function(current_condition, subject_setup)
{
    subject_setup$cond <- subject_setup$cond + 1
    if(current_condition == 1){
        penalty <- exp_dict$no_penalty} else if(current_condition == 2){
            penalty <- exp_dict$low_penalty} else if(current_condition == 3){
                penalty <- exp_dict$high_penalty}

    for (.. in seq(1, exp_dict$amount_trials)) #amount_trials (default: 50)
    {
        subject_setup$trialnr <- subject_setup$trialnr + 1
        ts <- exp_dict$base_interval
        subject_setup$real_time <- subject_setup$real_time + exp_dict$yellowDot_time #time yellow dot flashes
        sample_int_pulse <- msecs_to_pulses(ts) # the sample interval gets converted into pulses
        subject_setup <- encounter_add(subject_setup, sample_int_pulse)
        blended_response <- blending(subject_setup)
        rt <- pulse_to_msces(blended_response)

        if (rt > (1 - exp_dict$leeway)*exp_dict$base_interval & rt < (1 + exp_dict$leeway)*exp_dict$base_interval) {
            correct <- 1
            points_increment <- exp_dict$point_gain
            subject_setup <- encounter_add(subject_setup, (25))

        } else {
            correct <- 0
            points_increment <- exp_dict$point_gain + penalty

            subject_setup <- encounter_add(subject_setup, (13 - penalty*1.5))
        }

        subject_setup$points <- subject_setup$points + points_increment

        subject_setup$subject_data <- rbind(subject_setup$subject_data,
        c(subject_setup$subject_nr,
          subject_setup$trialnr,
          subject_setup$cond,
          correct,
          subject_setup$points,
          points_increment,
          rt))
    }

    subject_setup
}

# training <- function(subject_setup)
# {
#     subject_setup$recalled_interval <- 750
#     for (.. in seq(1, exp_dict$amount_training)) #training was 5 times exposition to 750 ms interval
#     {
#         train_pulses <- msecs_to_pulses(subject_setup$recalled_interval)
#         subject_setup <- encounter_add(subject_setup, train_pulses)
#         blended_training <- blending(subject_setup)
#         subject_setup$recalled_interval <- pulse_to_msces(blended_training)
#     }
#     subject_setup
# }

# adaption <- function(subject_setup, penalty)
# {
#     adaption_pulses <- msecs_to_pulses(subject_setup$recalled_interval)
#
#     subject_setup$recalled_interval <- pulse_to_msces(subject_setup$recalled_interval + adaption)
#
#     subject_setup
# }

main <- function()
{
    simulated_data <- data.frame(matrix(ncol = 7, nrow = 0)) #main data storage

    for (.. in seq(1, exp_dict$amount_subjects)) #loop for subjects
    {
        current_subject <- ..
        subject_setup <- experiment_setup(current_subject) #initializing current subject

        for (.. in exp_dict$condition_order) # loop containing all conditions
        {
            current_condition <- ..
            # subject_setup <- training(current_condition)
            subject_setup <- trial(current_condition, subject_setup) #here the trials happen (another loop inside)

        }

        simulated_data <- rbind(simulated_data, subject_setup$subject_data)
    }

    colnames(simulated_data) <- c("Subject_Nr ", "Trial_Nr", "Cond", "Correct", "Points", "Points_Increment", "Rt")

    simulated_data

    plotdat <- ddply(simulated_data, c("Trial_Nr", "Cond"), summarise,
                     mRT = mean(Rt),
                     sdRT = sd(Rt),
                     mScore = mean(Points),
                     mCurPoints = mean(Points_Increment),
                     mCorrect = mean(Correct))

    plotdat

    print("Run successfull!")
    #
    rt_plot <- plot_rt(plotdat)
    #sd_plot <- plot_sd(plotdat)
    # mScore_plot <- plot_mScore(plotdat)
    # mCurPoints_plot <- plot_mCurPoints(plotdat)
    #mCorrect_plot <- plot_mCorrect(plotdat)

}

main()


library(tidyverse)
library(DT)
library(data.table)
library(yaml)
library(rstudioapi)

#file <- selectFile(caption = "Select File", label = "Select",
#           path = getActiveProject(), filter = "All YAML Files (*.yml)",
#           existing = TRUE)

#config <- read_yaml(file)
config <- read_yaml("config.yml")

# User generation ----
user_ids <- 1:config$n_users
# initialize interest_resource with 3 time the amount of topics. So users have haed_room to increase their interest
interest_ressource <- rep(config$n_topics * 3, config$n_users)
# setup a data.frame for all users
topic_interests <- data.frame(user_ids)

# Generate interests for the users by topic
for (i in 1:config$n_topics) {
  # randomly assign interest to topics using the uniform distribution
  topic_interest_level <- data.frame(runif(config$n_users))
  # assign sensible column names
  names(topic_interest_level) <- paste0("topic_", i)
  # bind all topic interest to the user
  topic_interests <- topic_interests %>% bind_cols(topic_interest_level)
}

# create the actual user data frame
user <- data.frame(topic_interests, interest_ressource)

# posts generation  ----

# create ids
news_ids <- 1:config$n_newsposts
topic_relevances <- data.frame(news_ids)

# create news posts with certain topics
for (i in 1:config$n_topics) {
  # assign topic relevante by uniform distribution
  topic_relevance <- data.frame(runif(config$n_newsposts))
  names(topic_relevance) <- paste0("topic_", i)
  topic_relevances <- topic_relevances %>% bind_cols(topic_relevance)
}

news_posts <- data.frame(topic_relevances)
# calculate the sum of topic interests, to measure the "likeability"(?) of post
news_posts %>% select(starts_with("topic")) %>% mutate(sumtopics = rowSums(.)) %>% select(sumtopics) -> sumcol
news_posts %>% bind_cols(sumcol) -> news_posts

# Define a random likebility score for all news posts (uniform distribution, between 0 and topic-limit)
news_scores <- runif(config$n_newsposts, min = 1, max = config$topic_limit)
# get all topic values into a matrix for normalization
news_posts %>% select(starts_with("topic")) -> matrix_of_initial_values
# normalize all topic-value by the rowwise sum (generated above) - now sums should be 1
updated_topics <- (matrix_of_initial_values / t(sumcol))

# update the news_posts
news_posts <- bind_cols(data.frame(news_ids), updated_topics, data.frame(news_scores))

# initilize recommender
user %>% select(starts_with("topic")) -> mat_user
news_posts %>% select(starts_with("topic")) -> mat_posts
cosine_matrix <- matrix(c(0), nrow = config$n_users, ncol = config$n_newsposts)
for(i in 1:config$n_users) {
  for(j in 1:config$n_newsposts) {
    cosine_matrix[i,j] <- lsa::cosine(unlist(mat_user[i,]), unlist(mat_posts[j,]))
  }
}

#scosine_matrix

#' Generate recommendation for a user_id from a cosine similariy matrix
#'
#' @param user_id the user id (i.e. the row number in the cosine matrix)
#' @param cosine_matrix a cosine similarity matrix where rownumber is the number of users, and colnumer is the number of items
#' @param n how many recommendations to generate
#'
#' @return The ordered recommendations
#'
generate_topn_rec <- function(user_id, cosine_matrix, n = 1) {
  df <- as_tibble(data.frame(t(cosine_matrix)))
  df <- df %>% mutate(id = 1:dim(df)[1]) %>% select(id, user_id)
  suppressMessages(
    res <- top_n(df, n)
  )
  names(res) <- c("id", "match")
  res %>% arrange(desc(match))
}

# generate an empty exposre matrix with rownumbers = posts , colnumbers = simulationsteps
exposure <- matrix(c(0), nrow = config$n_newsposts, ncol = config$n_steps)

# run all simulation steps
pb <- txtProgressBar(min = 0, max = config$n_steps, initial = 0, char = "=",
               width = NA, title="Simulation Run", label, style = 3, file = "")
for (steps in 1:config$n_steps) {
  # for all users
  for(user_id in 1:config$n_users){
    # generate top 10 recommendations
    recs <- generate_topn_rec(user_id, cosine_matrix = cosine_matrix, 10)

    # update user interests ----
    # draw one random sample from recommendations to consume
    i <- sample(1:dim(recs)[1], 1)
      # get position of newspost in news post data frame
      position <- unlist(recs[i,1] )

      # get scores from posts
      news_posts[position,] %>% select(starts_with("topic")) -> post_scores
      # get user interests
      user[user_id, ] %>% select(starts_with("topic")) -> user_interest
      # update user_interest from posts
      user_interest <- user_interest + post_scores

      #noramlize if interest_ressource is maxed out
      if(sum(user_interest) > user[user_id,]$interest_ressource){
        user_interest <- user_interest / sum(user_interest) * user[user_id,]$interest_ressource
      }

      # Update only top topics?

      # update user interest
      user[user_id,]  <- c(user_ids = user_id, user_interest, user[user_id,]$interest_ressource)

    # update exposure counts in each step for all recommendations
      position <- unlist(recs[i,1] )
      exposure[position, steps] + 1 -> temp
      exposure[position, steps] <- temp

  }
  if(steps > 1){
    exposure[,steps] <- exposure[, steps] + exposure[, steps -1]
  }
  setTxtProgressBar(pb, steps)
}
close(pb)

#View(exposure)

# save results
results_data <- list(user = user, news_posts = news_posts, exposure = exposure)
rds_filename <- config$outputfilename
write_rds(results_data, rds_filename)


Sys.setlocale("LC_TIME","en_US.utf8")
svg("phenotypes_vs_userphenotypes.svg")
pheno <- read.table("phenotypes.txt", sep="\t")
usersp <- read.table("./user_phenotypes.txt", sep="\t")
par(mar=c(5, 4, 4, 6))
plot(sort(strptime(pheno[,2], "%d.%m.%Y %H:%M")), pheno[,1],type="l", xlab="Time", ylab="Amount of unique phenotypes",xaxt="n")
dmin <- min(strptime(pheno[,2], format="%d.%m.%Y %H:%M"))
dminjan <-  as.POSIXct(format(dmin, "%Y-1-1"))

seqYear <- seq(dminjan, by = "1 month", to = max(strptime(pheno[,2], format="%d.%m.%Y %H:%M")) + (86400 * 365))
axis(1, at = seqYear, labels = format(seqYear, "%b-%y"), las = 1)
par(new=T)
plot(sort(strptime(usersp[,2], "%d.%m.%Y %H:%M")), usersp[,1],type="l",xlab="", yaxt="n",col="red",xaxt="n",ylab="")
axis(4,col.axis="red")
mtext("Amount of entered phenotypes", side=4,line=3,col="red")
dev.off()


# Predict using c-means classification

library(GSIF)
library(Hmisc)
library(foreach)
library(doParallel)
library(tools)
library(raster)
source("utils/set-temp-path.r")
source("utils/load-data.r")

OutputDir = "../../userdata/predictions/"

# Needs a SpatialPixelsDataFrame out of the rasters
Rasters = LoadTrainingRasters(exclude = c("is.water", "amplitude1", "blue", "amplitude2", "tpi", "red",
    "lswi", "aspect", "swir"))
#TrainingPixels = LoadTrainingPixels(exclude = "is.water")
alldata = LoadClassificationData()

GetClassMeans = function(samples = 1:nrow(alldata), validation.idx = 1:9, training.idx = 13:28)
{
    combos = expand.grid(validation=validation.idx, training=training.idx)
    ClassMeans = function(x)
    {
        wtd.mean(alldata@data[samples,x["training"]], alldata@data[samples,x["validation"]])
    }
    cm = apply(combos, 1, ClassMeans)
    c.means = matrix(cm, nrow=length(validation.idx),
        dimnames=list(names(alldata)[validation.idx], names(alldata)[training.idx]))
    return(c.means)
}

GetClassSDs = function(samples = 1:nrow(alldata), validation.idx = 1:9, training.idx = 13:28)
{
    combos = expand.grid(validation=validation.idx, training=training.idx)
    ClassSDs = function(x)
    {
        sqrt(wtd.var(alldata@data[samples,x["training"]], alldata@data[samples,x["validation"]],
            normwt = TRUE))
    }
    csd = apply(combos, 1, ClassSDs)
    c.sds = matrix(csd, nrow=length(validation.idx),
        dimnames=list(names(alldata)[validation.idx], names(alldata)[training.idx]))
    return(c.sds)
}

TestFormula = formula("dominant~nir + osavi + height + slope + mean.ndvi + phase1 + phase2")

Threads = 2
registerDoParallel(cores = Threads)
outputs = foreach(i=0:24, .combine = rbind, .inorder = FALSE, .packages = c("raster", "GSIF"),
    .verbose=TRUE) %dopar%
{
    psnice(value = min(Threads - 1, 19))

    # Crop rasters to one fifth, 2 by 2 degree tiles, 25 total, 2 threads max

    RasterExtent = extent(Rasters)
    x = i %% 5 * 2
    y = i %/% 5 * 2
    RasterExtent@xmin = RasterExtent@xmin+x
    RasterExtent@ymin = RasterExtent@ymin+y
    RasterExtent@xmax = RasterExtent@xmin+2
    RasterExtent@ymax = RasterExtent@ymin+2
    CroppedRaster = crop(Rasters, RasterExtent)

    ValidationPixels = as(CroppedRaster, "SpatialPixelsDataFrame") # This will eat a lot of memory

    timer = system.time(cmeans <- spfkm(TestFormula, alldata, ValidationPixels,
        class.c = GetClassMeans(), class.sd = GetClassSDs(), fuzzy.e=1.5))

    output = brick(cmeans@mu)
    output = output * 100
    writeRaster(output, filename = paste0(OutputDir, "cmeans", i ,".tif"),
        datatype="INT1U", progress="text", overwrite=TRUE)
    timer
}
print(outputs)
#output = writeRaster(output, filename = paste0(OutputDir, "cmeans1.tif"), datatype="INT1U")#,
#    options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4"))
#names(output) = names(cmeans@mu)


xts.create <- function(datevec, value=1, names='xts.created') {
    ## given: datevec = vector of dates (can be character strings or dates)
    ##        value   = single number, vector, or matrix
    ##        names   = single character string if a single number or vector is supplied for value
    ##                  option is not used if a matrix is supplied
    if (class(value) != 'matrix') {
        mat <- matrix(value,
                      nrow=length(datevec),
                      ncol=length(names))
        colnames(mat) <- names
    }
    zoo <- zoo::as.zoo(mat, as.Date(datevec))
    xts <- xts::as.xts(zoo)
    return(xts)
}
## dates  <- c('2021-11-01', '2021-11-02', '2021-11-03')
## xtsobj <- xts.create(dates, 1)
## class(xtsobj)

## xts.create(dates, c(1,2,3))
## xts.create(dates, c(1,2,3), names='fred')

## a <- c(1,2,3)
## b <- c(4,5,6)
## mat <- cbind(a,b)
## xts.create(dates, mat)


#' Plot the contact matrix
#'
#' @param contacts a symmetrical matrix of contact rates by age
#' @return a heatmap of that contact matrix.
#'
#' @import ggplot2
#' @importFrom magrittr %>%
#' @importFrom tidyr gather
#' @importFrom tibble rowid_to_column
#' @importFrom dplyr mutate
#' @examples
#' plot_contacts(contacts)
#'
#' @export

plot_contacts <- function(dat){
  if(missing(dat)==TRUE) warning("missing data to plot")

  dat <- dat %>%
    as_tibble() %>%
    rowid_to_column(var="X") %>%
    gather(key="Y", value="Z", -1) %>%

    # Change Y to numeric
    mutate(Y=as.numeric(gsub("V","",Y)))

  names(dat) <- c("age_i", "age_j", "contacts")

  # Viz
  ggplot(dat, aes(age_i, age_j, fill= contacts)) +
    geom_tile() + xlab("Age") + ylab("Age") +
    scale_fill_gradient2(low="blue", mid = "white", high="red", midpoint = 1) +
    theme_light(base_size = 16) +
    theme(legend.position="right",
          panel.grid.minor = element_blank())
}


####
## Title: 	Precipitable Water Model
## Author: 	Spencer Riley / Vicki Kelsey
## Documentation Page: https://git.io/fjVHo
## To get a list of arguments run [Rscript model.r --help]
####

## Necessary Libraries for the script to run, for installation run install.sh
library(argparse); library(crayon); library(RColorBrewer); library(plotrix)
suppressPackageStartupMessages(library(Metrics))
suppressPackageStartupMessages(library(Hmisc))
suppressPackageStartupMessages(library(pracma))

## Imports data from master_data.csv
fname       <- read.table(file= "appendixB.csv", sep=",", header=TRUE, strip.white=TRUE)

daynum <- as.numeric(unlist(fname[1]))
suomi <- as.numeric(unlist(fname[2]))
aeronet <- as.numeric(unlist(fname[3]))
abq_pwv <- as.numeric(unlist(fname[4]))
epz_pwv <- as.numeric(unlist(fname[5]))
wt_mean <- as.numeric(unlist(fname[6]))

pdf("compare_r_a_s.pdf")
plot(daynum, suomi, pch=16, col="red", ylim=c(0, 4), xlim=c(0, 365),xaxt='n', yaxt='n',yaxs="i",xaxs="i", xlab="Day Number (2020)", ylab="PWV (cm)", main="PWV Comparison 2020")
points(daynum, aeronet, pch=16, col="orange")
points(daynum, abq_pwv, pch=16, col="green4")
points(daynum, epz_pwv, pch=16, col="steelblue3")
lines(daynum, wt_mean, lty="solid", col="black")
minor.tick(nx=5, ny=10, tick.ratio=0.5, x.args = list(), y.args = list())
x_ticks.at <- seq(0, 365, by = 50)
x_mj_ticks <- x_ticks.at[seq(1, length(x_ticks.at), length.out=8)]
axis(1, at=x_mj_ticks, labels=x_mj_ticks, tck=-0.02)

y_ticks.at <- seq(0.0, 4.0, by = 0.5)
y_mj_ticks <- y_ticks.at[seq(1, length(y_ticks.at), length.out=9)]
axis(2, at=y_mj_ticks, labels=sprintf("%3.1f", y_mj_ticks), tck=-0.02)

legend("topleft", col=c("red", "orange", "green4", "steelblue3", "black"), lty=c(0,0,0,0,1), pch=c(16,16,16,16,NA), legend=c("SuomiNet", "AERONET", "ABQ Sonde", "EPZ Sonde", "Sonde Mean"))


#LOAD PACKAGES####
library(Hmisc)
library(excel.link)
library(tidyverse)
library(ggplot2)

#define folder to be read from
setwd("S:/Page_IRB00252774/intervention_evaluation_study") #setting a default path
datafolder = './raw_data'
resultfolder = './R_scripts'
filename = 'Covid19ResponseForTh_DATA_2021-05-03_1128.csv'

#read linked datasets and remove missing rows by first dataset MRN column
df = read.csv(paste0(datafolder, '/', filename))

new_df = df %>% drop_na(mrn)

for (i in c('mrn', 'zip')){
  cond = new_df[i] != ''
  new_df = new_df[cond,]
}

#census tract conversion (input)
#in order to convert physical address into census tract number on census website,
#dataframe is clean to meet the format required by the API
#https://geocoding.geo.census.gov/geocoder/geographies/addressbatch?form
#index | address | city | state | zip code
col = c('address', 'city', 'zip') #note that state information is missing
CT_df = new_df[,col] %>% add_column(state = '', .after='city')
write.table(CT_df, paste0(resultfolder, '/', 'census_input.csv'), sep=',', col.names=FALSE)

#clean census tract import
#reading converted csv file
fname = paste0(resultfolder, '/', 'GeocodeResults.csv')
ct_import = read.csv(fname, header=FALSE)# %>% order('V1')
ct_sorted = ct_import[order(ct_import$V1),]

#get tie (there are several matching states [match, tie, no_match])
#while enough address information is provided for entries marked as tie
#the conversion has not happened, thus the dataframe with only the
#tied results are submitted again for re-evaluation (work in progress)
tie_idx = ct_sorted[ct_sorted$V3 == 'Tie',]$V1
ct_tie = CT_df[match(tie_idx, rownames(CT_df)),]
write.table(ct_tie, paste0(resultfolder, '/', 'census_tiebreaker.csv'), sep=',', col.names=FALSE)

#select match (V11: census tract number, V12: census block number)
#removes unsuccessful match by V12 column
ct_select = ct_sorted[ct_sorted$V12 != '',] %>% drop_na()
df_ct_select = new_df[match(ct_select$V1, rownames(new_df)),] #rownames(new_df)

#evaluate positivity rate by date
cols = c('lab_date', 'lab_result','age')
df_result = df_ct_select[,cols]
df_result$census = ct_select$V11

result_table = df_result %>% group_by(lab_date) %>%
                            summarise(age = mean(age),
                                      pos_rate = sum(lab_result) / length(lab_result),
                                      total_pos = sum(lab_result),
                                      total_num = length(lab_result))

result_table = result_table[order(as.Date(result_table$lab_date, format='%m/%d/%Y')),]
# result_table$lab_date = factor(result_table$lab_date, levels=result_table$lab_date)

write.csv(result_table, paste0(resultfolder, '/', 'positivity_bytime.csv'))

#generate figure for positivity rate over time
ggplot(data=result_table, aes(x=lab_date, y=pos_rate, group=1)) +
  geom_line() + geom_point() + labs(y='Positivity Rate (positive cases over total number)',title='Positivity Rate over time') +
  theme(axis.text.x = element_text(angle = 45,size=8, hjust = 1),
        axis.title.x = element_blank(), axis.title.y=element_text(size=10),
        plot.title = element_text(hjust=0.5))

ggsave(paste0(resultfolder, '/', 'pos_time.png'), device=png(), width=10, height=4)

#evaluate positivity rate by census tract number
result_table = df_result %>% group_by(census) %>%
  summarise(age = mean(age),
            pos_rate = sum(lab_result) / length(lab_result),
            total_pos = sum(lab_result),
            total_num = length(lab_result))

result_table = result_table[order(as.character(result_table$census)),]

write.csv(result_table, paste0(resultfolder, '/', 'positivity_bycensus.csv'))

#generate figure for positivity rate by census number
ggplot(data=result_table, aes(x=census, y=pos_rate, group=1)) +
  geom_point() + labs(x='Census Block Number', y='Positivity Rate (positive cases over total number)', title='Positivity Rate by Census Block Number') +
  theme(axis.text.x = element_blank(),
        axis.title.x = element_text(size=9), axis.title.y=element_text(size=9),
        plot.title = element_text(hjust=0.5))

ggsave(paste0(resultfolder, '/', 'pos_census.png'), device=png(), width=10, height=4)


setwd("P:/2019 0970 151 000/User Data/Faraz-Export IDAVE folders/Models2.5")
library(tidyverse)
library(h2o)
library(inspectdf)
tabna <- function(x){table(x, useNA = "ifany")}
##adding cihi vars
dfx <- readRDS("./dfx_v2.5.rds")

h2o.init()
dfx %>% inspect_na() %>% print(n=10)
dfx <- drop_na(dfx)

features <- read.csv("mutualInfo_features.csv")
features$X <- levels(features$X)[features$X]
names(features)[1:2] <- c("predictor", "mutInf")
features[grep("^flag", features$predictor), "is_ed"] <- FALSE
features[grep("^patserv", features$predictor), "is_ed"] <- FALSE
features[
which(features$predictor %in% c("acutelos", "scu", "prior_hosp_90d",
"prior_hosp_365d", "readm_90d")), "is_ed"] <- FALSE
features[is.na(features$is_ed), "is_ed"] <- TRUE

# sum(features$is_ed)
# [1] 37
# sum(features$is_ed[1:40])
# [1] 21

sel_feat_ed_small <- features[1:40,] %>% filter(is_ed) %>% .$predictor
sel_feat_ed_big <- features %>% filter(is_ed) %>% .$predictor
sel_feat <- features[1:40,] %>% .$predictor

df.hex  <- as.h2o(dfx)
# Now that we have our tuned model and parameters, we train the models on the train sample and test
# on the hold-out test sample
df.split <- h2o.splitFrame(df.hex, ratios = c(0.8), seed = 1234)
train <- df.split[[1]]
test <- df.split[[2]]

##Loading top 5 GBM models
gbm_models <- c()
path <- "./hypeTune_results/top5_gbm_models_cv"
model_names <- grep("^GBM_model", list.files(path), value=T)
for(model in model_names){
	gbm_models <- c(gbm_models, h2o.loadModel(paste(path, model, sep = "/")))
}
#Now we have 5 models that we can use their "hyperTuned" parameters
gbm_models[[1]]@parameters

# $model_id
# [1] "GBM_model_R_1623451639824_53840"

# $nfolds
# [1] 5

# $score_tree_interval
# [1] 10

# $fold_assignment
# [1] "Stratified"

# $balance_classes
# [1] TRUE

# $ntrees
# [1] 356

# $max_depth
# [1] 12

# $min_rows
# [1] 256

# $nbins_cats
# [1] 16

# $stopping_metric
# [1] "AUCPR"

# $stopping_tolerance
# [1] 1e-04

# $seed
# [1] 1234

# $learn_rate
# [1] 0.05

# $learn_rate_annealing
# [1] 0.99

# $distribution
# [1] "bernoulli"

# $sample_rate_per_class
# [1] 0.0948 0.7900

# $col_sample_rate
# [1] 0.99

# $col_sample_rate_change_per_level
# [1] 1.09

# $col_sample_rate_per_tree
# [1] 0.7

# $min_split_improvement
# [1] 0

# $histogram_type
# [1] "RoundRobin"

# $categorical_encoding
# [1] "Enum"

# $x
 # [1] "rural"              "female_flag"        "age_grp"            "triage"
 # [5] "admambul"           "cacsit1_grp3"       "cacsitcnt1"         "cacsitcnt"
 # [9] "prv_grp"            "prv_orthop"         "frail_grp"          "all_Cachx_3L"
# [13] "acutelos"           "readm_90d"          "flag_cardiovers"    "flag_feeding_tb"
# [17] "flag_mvent_ge96"    "flag_pa_nutrit"     "flag_radiother"     "flag_tracheost"
# [21] "flag_vasc_accdv"    "scu"                "dementia_comorb"    "dementia_main"
# [25] "paralysis"          "weightloss"         "psychoses"          "main_PhysInj_1L"
# [29] "main_MentBehav_1L"  "main_Zfactors_1L"   "main_MusclSkelt_1L" "patserv_34"
# [33] "patserv_72"         "patserv_38"         "patserv_17"         "patserv_64"
# [37] "patserv_39"         "patserv_12"         "patserv_15"         "patserv_36"

# $y
# [1] "alc_status"

res <- new_resultFrame()

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

gbm <- gbm_models[[i]]
newGBM <- do.call(h2o.gbm,
	#update parameters models, original models were cross validated, no need for that now, also change predictors in here
	{
		p <- gbm@parameters
		p$model_id = paste0("GBM_ed_small_", i)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$ntrees = 1000
		p$x = sel_feat_ed_small
		p$stopping_rounds = 5
		p$stopping_tolerance = 1e-4
		p$score_tree_interval = 10
		p$sample_rate = NULL
		p
	})
res <- add_results(newGBM, res)
}

###Bigger just ed features
for (i in c(1:5)){

gbm <- gbm_models[[i]]
newGBM <- do.call(h2o.gbm,
	#update parameters models, original models were cross validated, no need for that now, also change predictors in here
	{
		p <- gbm@parameters
		p$model_id = paste0("GBM_ed_big_", i)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$ntrees = 1000
		p$x = sel_feat_ed_big
		p$stopping_rounds = 5
		p$stopping_tolerance = 1e-4
		p$score_tree_interval = 10
		p$sample_rate = NULL
		p
	})
res <- add_results(newGBM, res)
}

###Now top mixed cihi and ED features
for (i in c(1:5)){

gbm <- gbm_models[[i]]
newGBM <- do.call(h2o.gbm,
	#update parameters models, original models were cross validated, no need for that now, also change predictors in here
	{
		p <- gbm@parameters
		p$model_id = paste0("GBM_ed_plusCIHI_", i)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$ntrees = 1000
		p$x = sel_feat
		p$stopping_rounds = 5
		p$stopping_tolerance = 1e-4
		p$score_tree_interval = 10
		p$sample_rate = NULL
		p
	})
res <- add_results(newGBM, res)
}

write.csv(res, "./Final Results/gbm_plusMinusCihi.csv", row.names=F)

######
# Now for the Random Forest models

rf_models <- c()
path <- "./hypeTune_results/top5_RF_models_cv"
model_names <- grep("^DRF_model", list.files(path), value=T)
for(model in model_names){
	rf_models <- c(rf_models, h2o.loadModel(paste(path, model, sep = "/")))
}
#Now we have 5 models that we can use their "hyperTuned" parameters

newRF <- c()

for (i in c(2:5)){

rf_model <- rf_models[[i]]
newRF<- c( newRF, do.call(h2o.randomForest,
	#update parameters models, original models were cross validated, no need for that now, also change predictors in here
	{
		p <- rf_model@parameters
		p$model_id = paste0("RF_ed_small_", i)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$ntrees = 1000
		p$x = sel_feat_ed_small
		p$stopping_rounds = 5
		p$stopping_tolerance = 1e-4
		p$score_tree_interval = 10
		p$sample_rate = NULL
		p$mtries <- as.integer(p$mtries / 40 * length(p$x)) #as the features sizes is changing, using mtries as a percentage
		p
	}))
res <- add_results(newRF[[i]], res)
}

###
for (i in c(1:5)){

rf_model <- rf_models[[i]]
newRF<- c( newRF, do.call(h2o.randomForest,
	#update parameters models, original models were cross validated, no need for that now, also change predictors in here
	{
		p <- rf_model@parameters
		p$model_id = paste0("RF_ed_big_", i)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$ntrees = 1000
		p$x = sel_feat_ed_big
		p$stopping_rounds = 5
		p$stopping_tolerance = 1e-4
		p$score_tree_interval = 10
		p$sample_rate = NULL
		p$mtries <- as.integer(p$mtries / 40 * length(p$x)) #as the features sizes is changing, using mtries as a percentage
		p
	}))
res <- add_results(newRF[[i+10]], res)
}

for (i in c(6:10)){
	res <- add_results(newRF[[i]], res)

}

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

rf_model <- rf_models[[i]]
newRF<- c( newRF, do.call(h2o.randomForest,
	#update parameters models, original models were cross validated, no need for that now, also change predictors in here
	{
		p <- rf_model@parameters
		p$model_id = paste0("RF_ed_plusCIHI_", i)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$ntrees = 1000
		p$x = sel_feat
		p$stopping_rounds = 5
		p$stopping_tolerance = 1e-4
		p$score_tree_interval = 10
		p$sample_rate = NULL
		p$mtries <- as.integer(p$mtries / 40 * length(p$x)) #as the features sizes is changing, using mtries as a percentage
		p
	}))
res <- add_results(newRF[[i]], res)
}

write.csv(res, "./Final Results/gbmANDrf_plusMinusCihi.csv", row.names=F)


source("common.r")

#############################################################
## Export batch size distributions for each configuration. ##
#############################################################

# Note: run 001_preproc_service_time_data.r prior to this.

clockDuration <- 1 / 3393e6

configs <-
    allData %>%
    group_by(exptype, pktsize, maxfs, qsize) %>%
    summarise(n = n()) %>%
    mutate(maxfs = as.numeric(as.character(maxfs)))

progbar <- txtProgressBar(style = 3)

for (ii in 1:nrow(configs)) {

    setTxtProgressBar(progbar, ii / nrow(configs))

    curSlice <-
        allData %>%
        filter(
            exptype == configs[ii, ]$exptype,
            pktsize == configs[ii, ]$pktsize,
            maxfs == configs[ii, ]$maxfs,
            qsize == configs[ii, ]$qsize) %>%
        mutate(clocks = as.double(pt1))

    # Construct pdfs.
    allCombinations <-
        expand.grid(
            vecsize = 0:configs[ii, ]$maxfs,
            rate = sort(unique(curSlice$rate)))

    nObservationsPerRateAndVecsize <-
        curSlice %>%
        group_by(rate, vecsize) %>%
        summarise(nVecMbps = n())

    nObservationsPerRateAndVecsize <-
        left_join(allCombinations, nObservationsPerRateAndVecsize) %>%
        replace_na(list(nVecMbps = 0))

    nObservationsPerRate <-
        curSlice %>%
        group_by(rate) %>%
        summarise(nMbps = n())

    probabilities <- left_join(nObservationsPerRateAndVecsize, nObservationsPerRate)
    probabilities$p <- probabilities$nVecMbps / probabilities$nMbps

    for (jj in 1:20) {
        fwrite(
            probabilities %>%
                filter(rate == jj * 500) %>%
                select(vecsize, p),
            file = sprintf("stats/vecsize__%s_pktsize_%d_beta_%d_L_%d_%05d_mbps.csv",
                           configs[ii, ]$exptype,
                           configs[ii, ]$pktsize,
                           configs[ii, ]$maxfs,
                           configs[ii, ]$qsize,
                           jj * 500),
            col.names = F)
    }

}

meanBatchSizes <-
    allData %>%
    group_by(exptype, pktsize, maxfs, qsize, rate) %>%
    summarise(meanbs = mean(vecsize))


#!/usr/bin/env Rscript
#
# Copyright (c) 2018      Los Alamos National Security, LLC.  All rights
#                         reserved.
# $COPYRIGHT$
#
# Additional copyrights may follow
#
# $HEADER$
#

library(stringr)

options(max.print=100000)

processdirectory <- function(dirname) {
    threaddata = list.files (dirname, pattern = "^threads_[[:digit:]]+-1$")
    print(paste("Processing data directory:", dirname, ", Number of different thread runs:", length(threaddata)))

    for (i in 1:length(threaddata)) {
        threadcount = gsub("threads_([[:digit:]]+)-1", "\\1", threaddata[i])
        print (paste("Processing data for thread count:", threadcount))
        datafiles = list.files(dirname, pattern = paste("^threads_", threadcount, "-", sep=""), full.names = TRUE)
        file_count = length(datafiles)

        masterdf <- data.frame()
        data = read.csv (datafiles[1], comment.char = '#')
        rows = length(data[,1])
        masterdf <- rbind(masterdf, data);

        # There are two columns we do not want to average (BpT, BxT). Everything else is fair game
        variable_count = ncol(masterdf) - 2
        tmp=array(dim=c(variable_count, rows, file_count))
        for (k in 1:variable_count) {
            tmp[k,,1] = data[[colnames(data)[k + 2]]]
            masterdf[[paste(colnames(data)[k + 2], "_stddev", sep="")]] = 1:rows
            masterdf[[paste(colnames(data)[k + 2], "_stderr", sep="")]] = 1:rows
        }

        for (j in 2:file_count) {
            data = read.csv (datafiles[j], skip = 11)
            for (k in 1:variable_count) {
                tmp[k,,j] = data[[colnames(data)[k + 2]]]
            }
        }

        for (k in 1:variable_count) {
            for (j in 1:rows) {
                tmp_mean = mean(tmp[k,j,])
                tmp_sd = sd(tmp[k,j,])
                tmp_err = tmp_sd / sqrt (file_count)
                masterdf[j,k+2] = tmp_mean
                masterdf[j,paste(colnames(data)[k + 2], "_stddev", sep="")] = tmp_sd
                masterdf[j,paste(colnames(data)[k + 2], "_stderr", sep="")] = tmp_err
            }
        }

        write.csv(masterdf, file=paste(dirname, "/threads", threadcount, ".csv", sep=""), fileEncoding="utf8")
    }
}

args = commandArgs(trailingOnly=TRUE)

if (length(args) == 0) {
    stop("Need to provide the path to the base data directory")
}

datadirectory = args[1]

files=list.files (datadirectory, pattern = "rmamt_", recursive = TRUE, include.dirs = TRUE, no.. = TRUE, all.files = FALSE, full.names = TRUE)

if (length(files) == 0) {
    stop("Could not find any RMA-MT benchmark data")
}

for (i in 1:length(files)) {
    processdirectory(files[i])
}


source("./ETL/country_data.r")
source("./Graphing/ggplot/common_graphs.r")
source("./Data/Graphics/spain_region_colors.r")
library(ggplot2)
library(gridExtra)

# Draw lines for women's march and lockdown
AppendVerticalLines <- function() {
    abline(v=as.Date("03/08/2020", format="%m/%d/%Y"), col="pink") # Women's March
    abline(v=as.Date("03/22/2020", format="%m/%d/%Y"), col="pink") # Women's March + 2 weeks
    abline(v=as.Date("03/13/2020", format="%m/%d/%Y"), col="black") # Lockdown
    abline(v=as.Date("03/27/2020", format="%m/%d/%Y"), col="black") # Lockdown + 2 weeks
}

####### Read Spain Data  ########
# Prep community data
spain_community_data <- ReadDataForCountry("Spain")

# Prep Spain data
spain <- ConvertCommunityToNational(spain_community_data)

####### Do some output #########

str(SPAIN_COLOR_CODES)

# cases, hospitalized, icu, deaths, recovered
#GraphDimensionForCountry(spain_community_data, spain, "deaths", "Spain", SPAIN_COLOR_CODES)

# Output latest Madrid data
madrid_data <- subset(spain_community_data, region_code=="MD")
madrid_data <- subset(madrid_data, total_cases > 100)
#madrid_data$ID <- sequence(rle(as.character(madrid_data$region_code))$lengths)

str(tail(madrid_data, 1))
print(ggplot(madrid_data, aes(x=date, y=total_hospitalized)) + geom_line() + xlim(as.Date("03/01/2020", format = "%m/%d/%Y"), as.Date("06/01/2020", format = "%m/%d/%Y")) + stat_smooth(method="gam", fullrange=TRUE))


# This code creates the fig:combined_surveillance_figure
# chart for COVID-19 pandemic in Saint Petersburg, Russia
# paper
library(data.table)
library(stringi)
library(stringr)
library(lubridate)
library(scales)
library(ggthemes)
library(ggsci)
library(ggpubr)
library(dplyr)
library(tidyr)
library(readxl)
library(grid)
library(gridExtra)
library(ggplot2)
library(lattice)
library(zoo)

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

# Define start and end dates for all charts
start_date <- ymd("2020-03-01")
end_date <- ymd("2021-05-31")
start_end_range <- c(start_date, end_date)

#######
# Read in the data

# Monthly excess mortality from https://doi.org/10.1111/1740-9713.01486
excess_deaths <- fread("https://raw.githubusercontent.com/dkobak/excess-mortality/main/russia_excess_deaths.csv", encoding = "UTF-8")[ V1 == "Санкт-Петербург"]
excess_deaths <- melt(excess_deaths, id.vars = "V1", variable.name = "DATE", value.name = "deaths", variable.factor = F)
excess_deaths[, V1 := NULL]
excess_deaths[, DATE := gsub("Январь ", "25.01.", DATE)]
excess_deaths[, DATE := gsub("Февраль ", "25.02.", DATE)]
excess_deaths[, DATE := gsub("Март ", "25.03.", DATE)]
excess_deaths[, DATE := gsub("Апрель ", "25.04.", DATE)]
excess_deaths[, DATE := gsub("Май ", "25.05.", DATE)]
excess_deaths[, DATE := gsub("Июнь ", "25.06.", DATE)]
excess_deaths[, DATE := gsub("Июль ", "25.07.", DATE)]
excess_deaths[, DATE := gsub("Август ", "25.08.", DATE)]
excess_deaths[, DATE := gsub("Сентябрь ", "25.09.", DATE)]
excess_deaths[, DATE := gsub("Октябрь ", "25.10.", DATE)]
excess_deaths[, DATE := gsub("Ноябрь ", "25.11.", DATE)]
excess_deaths[, DATE := gsub("Декабрь ", "25.12.", DATE)]
excess_deaths[, DATE := dmy(DATE)]

# Manually add May, 2021 data as missing
excess_deaths <- rbind(excess_deaths, data.table(DATE = ymd("2021-05-01")), fill = T)
setorderv(excess_deaths, "DATE")
excess_deaths <- excess_deaths[ DATE >= start_date & DATE <= end_date ]

# Interpolate monthly deaths to week
zoo.mo <- zoo(excess_deaths$deaths/4.345, excess_deaths$DATE)

zoo.da <- merge(zoo.mo, zoo(, seq(start(zoo.mo), end(zoo.mo)+15, by="day")))
zoo.da <- na.approx(zoo.da)
zoo.we <- rollapply(zoo.da, 7, mean, by=7)

edeaths <- fortify.zoo(zoo.we) %>%
	rename(DATE=Index,count=zoo.we) %>%
	mutate(source="Excess deaths (interpolated)") %>% select(DATE, source, count)

# Search trends
search_trends <- fread("https://raw.githubusercontent.com/alexei-kouprianov/COVID-19.SPb/main/data/primary/covid.SPb.yandex.weekly.txt", encoding = "UTF-8")
search_trends <- search_trends[, c("START.DATE.LOSS.01", "COUNT.LOSS.01")]
setnames(search_trends, c("START.DATE.LOSS.01", "COUNT.LOSS.01"), c("DATE", "weekly_count"))
search_trends[, DATE := dmy(DATE)]

search_trends<-search_trends %>%
	mutate(source="Search trends") %>%
	rename(count=weekly_count) %>%
	select(DATE, source, count)

# SARS-Cov-2 Variants
variants3 <- read_excel("data/variants/variants_count_by_months.xlsx") %>%
	pivot_longer(-month, names_to = "variant", values_to = "n") %>%
	group_by(month) %>%
	mutate(n0 = sum(n)) %>%
	mutate(proportion = round ((n / n0), 2)) %>%
	ungroup() %>%
	select(month,variant,proportion)

# Seroprevalence by cross-section
# Load and prepare the estimated prevalence across waves
# (see the estimation code in analysis/wave*/estimate_prevalence_by_{model,variable}.r)
waves <- c(1, 1.5, 2, 3)

# Init an object to store the results
# of prevalence computations
perwave_prevalence_by_model_list <- list()

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

	load(paste0("estimates/wave", w, "/prevalence_by_model.rdata"))

	perwave_prevalence_by_model_list[[ as.character(w) ]] <- prevalence_by_model

	rm(prevalence_by_model)

}

# Aggregate the results
perwave_prevalence_by_model <- rbindlist(perwave_prevalence_by_model_list, idcol = "wave")

# Define a variable for test adjustment
perwave_prevalence_by_model[ sensitivity == 1 & specificity == 1, test_adjustment := "unadjusted" ]
perwave_prevalence_by_model[ sensitivity != 1 & specificity == 1, test_adjustment := "adjusted" ]

# Perwave prevalence data from the univariate model
perwave_prevalence <- perwave_prevalence_by_model[ scenario == "basic" & test_adjustment == "adjusted" & serotest == "IgA_or_G_or_M_testC" & prevalence_type == "univariate" & surveyweight == "no", c("wave", "lowerbound", "pointest", "upperbound") ]

# Repeat the rows a set amount of times
perwave_prevalence <- rbind(perwave_prevalence[1][rep(1:.N, 5), ],
							perwave_prevalence[2][rep(1:.N, 4), ],
							perwave_prevalence[3][rep(1:.N, 8), ],
							perwave_prevalence[4][rep(1:.N, 8), ]
							)
perwave_prevalence[, DATE := c("2020-05-31", "2020-06-07", "2020-06-14", "2020-06-21", "2020-06-28",
			"2020-07-26", "2020-08-02", "2020-08-09", "2020-08-16",
			"2020-10-18", "2020-10-25", "2020-11-01","2020-11-08", "2020-11-15", "2020-11-22", "2020-11-29", "2020-12-06",
			"2021-02-14", "2021-02-21", "2021-02-28", "2021-03-07", "2021-03-14", "2021-03-21", "2021-03-28", "2021-04-04")]
perwave_prevalence[, DATE := ymd(DATE)]
perwave_prevalence[, source := "Vaccination uptake and serosurvey prevalence"]
perwave_prevalence[, count := pointest/100]
perwave_prevalence[, lab := NA_character_ ]
perwave_prevalence[DATE == ymd("2020-05-31"), lab := "9.7 (7.7-11.7)" ]
perwave_prevalence[DATE == ymd("2020-07-26"), lab := "13.3 (9.9-16.6)" ]
perwave_prevalence[DATE == ymd("2020-11-01"), lab := "22.9 (20.3-25.5)" ]
perwave_prevalence[DATE == ymd("2021-02-28"), lab := "43.9 (39.7-48.0)" ]

perwave_prevalence$source <- factor(perwave_prevalence$source,levels =c("Officially registered cases",
												"Tests performed",
												"Hospitalized cases",
												"COVID-19 deaths",
												"Excess deaths (interpolated)",
												"Search trends",
												"Urban activity",
												"Vaccination uptake and serosurvey prevalence"))

# Weekly data
weekly <- fread("https://raw.githubusercontent.com/alexei-kouprianov/COVID-19.SPb/main/data/derived/spb.combined.weekly.txt",
				encoding = "UTF-8") %>%
	select(TIME, HOSPITALIZED.today, CONFIRMED, DEATHS, PCR.tested, Yandex.ACTIVITY.points, v1.CS) %>%
	mutate(v1.CS=round((v1.CS/5398064),3)) %>%
	rename("Hospitalized cases"=HOSPITALIZED.today,
			"Officially registered cases"= CONFIRMED,
			"Tests performed"=PCR.tested,
			"COVID-19 deaths"=DEATHS,
			"Urban activity"= Yandex.ACTIVITY.points,
			"Vaccination uptake and serosurvey prevalence"=v1.CS) %>%
	pivot_longer(-TIME,names_to="source",values_to = "count") %>%
	mutate(TIME=as.Date(TIME)) %>%
	rename(DATE=TIME) %>%
	filter(DATE >= start_date & DATE <= end_date) %>%
	rbind(edeaths) %>%
	rbind(search_trends)

weekly$source <- factor(weekly$source,levels =c("Officially registered cases",
								"Tests performed",
								"Hospitalized cases",
								"COVID-19 deaths",
								"Excess deaths (interpolated)",
								"Search trends",
								"Urban activity",
								"Vaccination uptake and serosurvey prevalence"))

# Plot witn main pandemic data
plot_main <- ggplot(data = weekly, aes(x = DATE, y = count, fill=source, color=source)) +
											geom_col(position = "dodge",width=7) +
											scale_y_continuous(labels=comma_format())+
	geom_col(data=perwave_prevalence, position = "dodge",width=6.7,fill="blue",color=NA,alpha=0.2) +
	geom_text(data=perwave_prevalence, aes(label=lab),size=2.4,fontface="bold", color="black",hjust=0.3, vjust=0.8) +
	scale_x_date(	name = "",
					breaks = date_breaks("2 months"),
					#date_labels = "%m-\n%Y",
					date_labels= c("Mar\n2020", "May",
									"Jul", "Sep",
									"Nov", "Jan\n2021",
									"Mar", "May"),
					expand = c(0, 0),
					limits = start_end_range) +
	theme_minimal() +
	facet_wrap(~source, ncol=1,scales="free_y")+
	scale_fill_lancet() +
	scale_color_lancet() +
	theme(panel.grid.minor = element_blank(),
			legend.position = "none")+
	ylab("")+
	ggtitle('A')

# Plot witn SARS-CoV-2 variants
plot_var <- ggplot(data = variants3, aes(x = month, y = proportion)) +
	geom_col(position = "dodge",color=NA,fill="gray") +
	scale_y_continuous(labels = scales::percent_format())+
	scale_x_discrete(name = "",
					breaks = c("01april","03jun","05aug","07oct","09dec",
								"11feb","13april2","15jun2"),
					labels = c("Apr\n2020","Jun",
								"Aug","Oct",
								"Dec", "Feb\n2021",
								"Apr","Jun")) +
	theme_minimal() +
	facet_wrap(~variant,ncol=1)+
	scale_fill_lancet()+
	scale_color_lancet()+
	theme(panel.grid.minor = element_blank(),
		legend.position = "none")+
	ylab("")+
	ggtitle('B')

# Combine the two charts under one figure
#pdf("pandemic_course_paper/media/combined_surveillance_figure.pdf", width = 14, height = 12)
#grid.arrange(plot_main, plot_var, ncol = 2, widths = c(2,1))
#dev.off()


source("install_required_packages.r")
source("synth_validation_benchmark.r")

library(tictoc)

tic("total")
for(i in 1:15){
  tic(paste("random_generated_data_",i,sep = ""))
  benchmark(NULL,100,150,FALSE,TRUE)
  toc()
}
toc()


#' @export
evaluate <- function(x, interpreter) UseMethod("evaluate")

#' @export
evaluate.lox_expr_literal <- function(x, interpreter) {
  x$value
}

#' @export
evaluate.lox_expr_logical <- function(x, interpreter) {
  left <- evaluate(x$left, interpreter)

  if (is_type(x$operator, token_type$OR)) {
    # short circuit OR
    if (is_truthy(left)) return(left)
  } else {
    # short circuit AND
    if (!is_truthy(left)) return(left)
  }

  evaluate(x$right, interpreter)
}

#' @export
evaluate.lox_expr_grouping <- function(x, interpreter) {
  evaluate(x$expression, interpreter)
}

#' @export
evaluate.lox_expr_unary <- function(x, interpreter) {
  right <- evaluate(x$right, interpreter)

  type <- x$operator$type
  if (type == token_type$BANG) {
    !is_truthy(right)
  } else if (type == token_type$MINUS) {
    check_number_operand(x$operator, right)
    -as.double(right)
  } else {
    lox_runtime_error(
      sprintf("Cannot evaluate unary expression \n%s", format(x)),
      x$operator
    )
  }
}

#' @export
evaluate.lox_expr_binary <- function(x, interpreter) {
  left <- evaluate(x$left, interpreter)
  right <- evaluate(x$right, interpreter)

  type <- x$operator$type

  if (type == token_type$BANG_EQUAL) {
    !is_equal(left, right)
  } else if (type == token_type$EQUAL_EQUAL) {
    is_equal(left, right)
  } else if (type == token_type$GREATER) {
    check_number_operands(x$operator, left, right)
    as.double(left) > as.double(right)
  } else if (type == token_type$GREATER_EQUAL) {
    check_number_operands(x$operator, left, right)
    as.double(left) >= as.double(right)
  } else if (type == token_type$LESS) {
    check_number_operands(x$operator, left, right)
    as.double(left) < as.double(right)
  } else if (type == token_type$LESS_EQUAL) {
    check_number_operands(x$operator, left, right)
    as.double(left) <= as.double(right)
  } else if (type == token_type$MINUS) {
    check_number_operands(x$operator, left, right)
    as.double(left) - as.double(right)
  } else if (type == token_type$SLASH) {
    check_number_operands(x$operator, left, right)
    as.double(left) / as.double(right)
  } else if (type == token_type$STAR) {
    check_number_operands(x$operator, left, right)
    as.double(left) * as.double(right)
  } else if (type == token_type$PLUS){
    if (is.numeric(left) && is.numeric(right)) {
      as.double(left) + as.double(right)
    } else if (is.character(left) && is.character(right)) {
      paste0(left, right, collapse = " ")
    } else {
      lox_runtime_error(
        sprintf("Operands must be two numbers or two strings: %s %s %s",
                left, x$operator$lexeme, right),
        x$operator
      )
    }
  } else {
    lox_runtime_error(
      sprintf("Cannot evaluate binary expression \n%s", format(x)),
      x$operator
    )
  }
}

#' @export
evaluate.lox_expr_variable <- function(x, interpreter) {
  #env_get(interpreter$env_cur, x$name)
  lookup_variable(x$name, x, interpreter)
}

#' Look-up variable in locals table
#' @param x expression
#' @param name token
#' @param interpreter interpreter
lookup_variable <- function(name, x, interpreter) {
  id <- attr(x, "id")
  if (interpreter$locals$has(id)) {
    depth <- interpreter$locals$get(id)
    env_get_at(interpreter$env_cur, name, depth)
  } else {
    env_get(interpreter$env_global, name, inherits = FALSE)
  }
}

#' @export
evaluate.lox_expr_assignment <- function(x, interpreter) {
  # evaluate expression
  val <- evaluate(x$value, interpreter)

  # assign value to name
  #env_assign(env, x$name, val)
  assign_variable(x$name, val, x, interpreter)
}

#' Assign variable in locals table
#' @param x expression
#' @param name token
#' @param value value to assign
#' @param interpreter interpreter
assign_variable <- function(name, value, x, interpreter) {
  id <- attr(x, "id")
  if (interpreter$locals$has(id)) {
    depth <- interpreter$locals$get(id)
    env_assign_at(interpreter$env_cur, name, value, depth)
  } else {
    env_assign(interpreter$env_global, name, value)
  }
  value
}

#' @export
evaluate.lox_expr_call <- function(x, interpreter) {
  callee <- evaluate(x$callee, interpreter)
  arguments <- lapply(x$arguments, evaluate, interpreter = interpreter)

  if (!inherits(callee, "lox_callable")) {
    lox_runtime_error("Can only call functions and classes", x$paren)
  }

  if (length(arguments) != arity(callee)) {
    lox_runtime_error(
      sprintf("Expected %i arguments but got %i.", arity(callee), length(arguments)),
      x$paren
      )
  }

  # call function
  lox_call(callee, arguments, interpreter)
}


dice <- 1
while (dice <= 6) {
  if (dice < 6) {
    print("No Yahtzee")
  } else {
    print("Yahtzee!")
  }
  dice <- dice + 1
}


#RandomTables.r
#                   RBLandau 20171113

fnPrintTableRandom <- function(dfdat, sOutputFilename, sTitle, sSubtitle){

# Tabulate columns by copies and sector lifetime.
tbl.auditrandom <- data.frame(with(dfdat,
            tapply(mdmlosspct, list(copies, lifem), FUN=identity)))

# Re-form the data into a table for printing.
foo<-(with(dfdat,
       tapply(mdmlosspct, list(copies, lifem), FUN=identity)))
foo2<-cbind(as.numeric(levels(factor(dfdat$copies))), foo)
tbl2<-data.frame(foo2)
colnames(tbl2)<-c("copies",as.numeric(colnames(foo2[,2:ncol(foo2)])))

# Pretty-print this to a file with explanatory headings.
sink(sOutputFilename)
cat("MIT Preservation Simulation Project", "\n\n")
cat(sOutputFilename, format(Sys.time(),"%Y%m%d_%H%M%S%Z"), "\n\n")
cat(sTitle, "\n\n")
cat(sSubtitle, "\n\n")
cat("\n")
print(tbl2)
sink()

return(tbl2)

}


library(tradepolicy)

# data ----

ch1_application3 <- agtpa_applications %>%
  filter(year %in% seq(1986, 2006, 4)) %>%
  mutate(
    exp_year = paste0(exporter, year),
    imp_year = paste0(importer, year),
    year = paste0("intl_border_", year),
    log_trade = log(trade),
    log_dist = log(dist),
    intl_brdr = ifelse(exporter == importer, pair_id, "inter"),
    intl_brdr_2 = ifelse(exporter == importer, 0, 1),
    pair_id_2 = ifelse(exporter == importer, "0-intra", pair_id)
  ) %>%
  spread(year, intl_brdr_2, fill = 0)

ch1_application3 <- ch1_application3 %>%
  group_by(pair_id) %>%
  mutate(sum_trade = sum(trade)) %>%
  ungroup()

# ols ----

ch1_app3_ols <- tp_summary_app3(
  formula = "log_trade ~ 0 + log_dist + cntg + lang + clny +
    rta + exp_year + imp_year",
  data = filter(ch1_application3, trade > 0, importer != exporter),
  method = "lm"
)

# ppml ----

ch1_app3_ppml <- tp_summary_app3(
  formula = "trade ~ 0 + log_dist + cntg + lang + clny +
    rta + exp_year + imp_year",
  data = filter(ch1_application3, importer != exporter),
  method = "glm"
)

# trade diversion ----

ch1_app3_intra <- tp_summary_app3(
  formula = "trade ~ 0 + log_dist + cntg + lang + clny +
    rta + exp_year + imp_year + intl_brdr",
  data = ch1_application3,
  method = "glm"
)

# endogeneity ----

ch1_app3_endg <- tp_summary_app3(
  formula = "trade ~ 0 + rta + exp_year + imp_year + pair_id_2",
  data = filter(ch1_application3, sum_trade > 0),
  method = "glm"
)

# reverse causality ----

ch1_app3_lead <- tp_summary_app3(
  formula = "trade ~ 0 + rta + rta_lead4 + exp_year + imp_year + pair_id_2",
  data = filter(ch1_application3, sum_trade > 0),
  method = "glm"
)

# non-linear/phasing effects ----

ch1_app3_phsng <- tp_summary_app3(
  formula = "trade ~ 0 + rta + rta_lag4 + rta_lag8 + rta_lag12 +
    exp_year + imp_year + pair_id_2",
  data = filter(ch1_application3, sum_trade > 0),
  method = "glm"
)

# globalization ----

ch1_app3_glbzn <- tp_summary_app3(
  formula = "trade ~ 0 + rta + rta_lag4 + rta_lag8 + rta_lag12 +
    intl_border_1986 + intl_border_1990 + intl_border_1994 +
    intl_border_1998 + intl_border_2002 +
    exp_year + imp_year + pair_id_2",
  data = filter(ch1_application3, sum_trade > 0),
  method = "glm"
)

save.image("all-models-and-data/03-chapter1-regional-trade-agreements.RData", compress = "xz")


#' @title matrix.multiply
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export

  matrix.multiply = function (x, y, nfac=2){
    ndat = dim(x)[1]
    z = matrix(0, nrow=ndat, ncol = nfac)
    for (j in 1:nfac) {
      for (i in 1:ndat) {
        z[i,j] = sum ( x[i,] * t(y[,j]), na.rm=T )
      }
    }
    return (z)
  }


score <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.1) - (input[1])) ^ (2.0)) + (((3.3) - (input[2])) ^ (2.0))) + (((1.7) - (input[3])) ^ (2.0))) + (((0.5) - (input[4])) ^ (2.0))))
    var1 <- exp((-0.06389634699048878) * ((((((5.7) - (input[1])) ^ (2.0)) + (((2.6) - (input[2])) ^ (2.0))) + (((3.5) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))))
    return(c((subroutine0(input)) + ((var0) * (0.8898986041811555)), (subroutine1(input)) + ((var0) * (0.37953658977037247)), (subroutine2(input)) + ((var1) * (0.0))))
}
subroutine0 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.1) - (input[1])) ^ (2.0)) + (((3.8) - (input[2])) ^ (2.0))) + (((1.9) - (input[3])) ^ (2.0))) + (((0.4) - (input[4])) ^ (2.0))))
    return((subroutine3(input)) + ((var0) * (0.8898986041811555)))
}
subroutine1 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.1) - (input[1])) ^ (2.0)) + (((3.8) - (input[2])) ^ (2.0))) + (((1.9) - (input[3])) ^ (2.0))) + (((0.4) - (input[4])) ^ (2.0))))
    return((subroutine4(input)) + ((var0) * (0.37953658977037247)))
}
subroutine2 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.9) - (input[1])) ^ (2.0)) + (((3.2) - (input[2])) ^ (2.0))) + (((4.8) - (input[3])) ^ (2.0))) + (((1.8) - (input[4])) ^ (2.0))))
    return((subroutine5(input)) + ((var0) * (110.34516826676301)))
}
subroutine3 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.7) - (input[1])) ^ (2.0)) + (((4.4) - (input[2])) ^ (2.0))) + (((1.5) - (input[3])) ^ (2.0))) + (((0.4) - (input[4])) ^ (2.0))))
    return((subroutine6(input)) + ((var0) * (0.0)))
}
subroutine4 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.7) - (input[1])) ^ (2.0)) + (((4.4) - (input[2])) ^ (2.0))) + (((1.5) - (input[3])) ^ (2.0))) + (((0.4) - (input[4])) ^ (2.0))))
    return((subroutine7(input)) + ((var0) * (0.05610417372785803)))
}
subroutine5 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.0) - (input[1])) ^ (2.0)) + (((2.7) - (input[2])) ^ (2.0))) + (((5.1) - (input[3])) ^ (2.0))) + (((1.6) - (input[4])) ^ (2.0))))
    return((subroutine8(input)) + ((var0) * (110.34516826676301)))
}
subroutine6 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((4.5) - (input[1])) ^ (2.0)) + (((2.3) - (input[2])) ^ (2.0))) + (((1.3) - (input[3])) ^ (2.0))) + (((0.3) - (input[4])) ^ (2.0))))
    return((subroutine9(input)) + ((var0) * (0.8898986041811555)))
}
subroutine7 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((4.5) - (input[1])) ^ (2.0)) + (((2.3) - (input[2])) ^ (2.0))) + (((1.3) - (input[3])) ^ (2.0))) + (((0.3) - (input[4])) ^ (2.0))))
    return((subroutine10(input)) + ((var0) * (0.3044555865539922)))
}
subroutine8 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.0) - (input[1])) ^ (2.0)) + (((2.3) - (input[2])) ^ (2.0))) + (((3.3) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))))
    return((subroutine11(input)) + ((var0) * (0.0)))
}
subroutine9 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((4.8) - (input[1])) ^ (2.0)) + (((3.4) - (input[2])) ^ (2.0))) + (((1.9) - (input[3])) ^ (2.0))) + (((0.2) - (input[4])) ^ (2.0))))
    return((subroutine12(input)) + ((var0) * (0.8898986041811555)))
}
subroutine10 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((4.8) - (input[1])) ^ (2.0)) + (((3.4) - (input[2])) ^ (2.0))) + (((1.9) - (input[3])) ^ (2.0))) + (((0.2) - (input[4])) ^ (2.0))))
    return((subroutine13(input)) + ((var0) * (0.37953658977037247)))
}
subroutine11 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.7) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((5.0) - (input[3])) ^ (2.0))) + (((1.7) - (input[4])) ^ (2.0))))
    return((subroutine14(input)) + ((var0) * (110.34516826676301)))
}
subroutine12 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.7) - (input[1])) ^ (2.0)) + (((3.8) - (input[2])) ^ (2.0))) + (((1.7) - (input[3])) ^ (2.0))) + (((0.3) - (input[4])) ^ (2.0))))
    return((subroutine15(input)) + ((var0) * (0.0)))
}
subroutine13 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.7) - (input[1])) ^ (2.0)) + (((3.8) - (input[2])) ^ (2.0))) + (((1.7) - (input[3])) ^ (2.0))) + (((0.3) - (input[4])) ^ (2.0))))
    return((subroutine16(input)) + ((var0) * (0.37953658977037247)))
}
subroutine14 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.6) - (input[1])) ^ (2.0)) + (((2.9) - (input[2])) ^ (2.0))) + (((3.6) - (input[3])) ^ (2.0))) + (((1.3) - (input[4])) ^ (2.0))))
    return((subroutine17(input)) + ((var0) * (0.0)))
}
subroutine15 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.4) - (input[1])) ^ (2.0)) + (((3.4) - (input[2])) ^ (2.0))) + (((1.7) - (input[3])) ^ (2.0))) + (((0.2) - (input[4])) ^ (2.0))))
    return((subroutine18(input)) + ((var0) * (0.7142250613852136)))
}
subroutine16 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.4) - (input[1])) ^ (2.0)) + (((3.4) - (input[2])) ^ (2.0))) + (((1.7) - (input[3])) ^ (2.0))) + (((0.2) - (input[4])) ^ (2.0))))
    return((subroutine19(input)) + ((var0) * (0.0)))
}
subroutine17 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.2) - (input[1])) ^ (2.0)) + (((2.2) - (input[2])) ^ (2.0))) + (((4.5) - (input[3])) ^ (2.0))) + (((1.5) - (input[4])) ^ (2.0))))
    return((subroutine20(input)) + ((var0) * (37.19509025661546)))
}
subroutine18 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.0) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((1.6) - (input[3])) ^ (2.0))) + (((0.2) - (input[4])) ^ (2.0))))
    return((subroutine21(input)) + ((var0) * (0.04218875216876044)))
}
subroutine19 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.0) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((1.6) - (input[3])) ^ (2.0))) + (((0.2) - (input[4])) ^ (2.0))))
    return((subroutine22(input)) + ((var0) * (0.0)))
}
subroutine20 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.4) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((4.5) - (input[3])) ^ (2.0))) + (((1.5) - (input[4])) ^ (2.0))))
    return((subroutine23(input)) + ((var0) * (62.115561183470184)))
}
subroutine21 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.7) - (input[1])) ^ (2.0)) + (((2.6) - (input[2])) ^ (2.0))) + (((3.5) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))))
    return((subroutine24(input)) + ((var0) * (-0.8898986041811555)))
}
subroutine22 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.3) - (input[1])) ^ (2.0)) + (((2.8) - (input[2])) ^ (2.0))) + (((5.1) - (input[3])) ^ (2.0))) + (((1.5) - (input[4])) ^ (2.0))))
    return((subroutine25(input)) + ((var0) * (-0.0)))
}
subroutine23 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.3) - (input[1])) ^ (2.0)) + (((2.5) - (input[2])) ^ (2.0))) + (((4.9) - (input[3])) ^ (2.0))) + (((1.5) - (input[4])) ^ (2.0))))
    return((subroutine26(input)) + ((var0) * (110.34516826676301)))
}
subroutine24 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.9) - (input[1])) ^ (2.0)) + (((3.2) - (input[2])) ^ (2.0))) + (((4.8) - (input[3])) ^ (2.0))) + (((1.8) - (input[4])) ^ (2.0))))
    return((subroutine27(input)) + ((var0) * (-0.0)))
}
subroutine25 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.0) - (input[1])) ^ (2.0)) + (((2.2) - (input[2])) ^ (2.0))) + (((5.0) - (input[3])) ^ (2.0))) + (((1.5) - (input[4])) ^ (2.0))))
    return((subroutine28(input)) + ((var0) * (-0.10077618026650095)))
}
subroutine26 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((4.9) - (input[1])) ^ (2.0)) + (((2.4) - (input[2])) ^ (2.0))) + (((3.3) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))))
    return((subroutine29(input)) + ((var0) * (0.0)))
}
subroutine27 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.0) - (input[1])) ^ (2.0)) + (((2.7) - (input[2])) ^ (2.0))) + (((5.1) - (input[3])) ^ (2.0))) + (((1.6) - (input[4])) ^ (2.0))))
    return((subroutine30(input)) + ((var0) * (-0.0)))
}
subroutine28 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.2) - (input[1])) ^ (2.0)) + (((2.8) - (input[2])) ^ (2.0))) + (((4.8) - (input[3])) ^ (2.0))) + (((1.8) - (input[4])) ^ (2.0))))
    var1 <- exp((-0.06389634699048878) * ((((((7.2) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((5.8) - (input[3])) ^ (2.0))) + (((1.6) - (input[4])) ^ (2.0))))
    var2 <- exp((-0.06389634699048878) * ((((((6.1) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((4.9) - (input[3])) ^ (2.0))) + (((1.8) - (input[4])) ^ (2.0))))
    var3 <- exp((-0.06389634699048878) * ((((((6.0) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((4.8) - (input[3])) ^ (2.0))) + (((1.8) - (input[4])) ^ (2.0))))
    var4 <- exp((-0.06389634699048878) * ((((((4.9) - (input[1])) ^ (2.0)) + (((2.5) - (input[2])) ^ (2.0))) + (((4.5) - (input[3])) ^ (2.0))) + (((1.7) - (input[4])) ^ (2.0))))
    var5 <- exp((-0.06389634699048878) * ((((((7.9) - (input[1])) ^ (2.0)) + (((3.8) - (input[2])) ^ (2.0))) + (((6.4) - (input[3])) ^ (2.0))) + (((2.0) - (input[4])) ^ (2.0))))
    var6 <- exp((-0.06389634699048878) * ((((((5.6) - (input[1])) ^ (2.0)) + (((2.8) - (input[2])) ^ (2.0))) + (((4.9) - (input[3])) ^ (2.0))) + (((2.0) - (input[4])) ^ (2.0))))
    return((((((((-0.04261957451303831) + ((var0) * (-0.37953658977037247))) + ((var1) * (-0.0))) + ((var2) * (-0.0))) + ((var3) * (-0.37953658977037247))) + ((var4) * (-0.37953658977037247))) + ((var5) * (-0.26472396872040066))) + ((var6) * (-0.3745962010653211)))
}
subroutine29 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.1) - (input[1])) ^ (2.0)) + (((2.5) - (input[2])) ^ (2.0))) + (((3.0) - (input[3])) ^ (2.0))) + (((1.1) - (input[4])) ^ (2.0))))
    return((subroutine31(input)) + ((var0) * (0.0)))
}
subroutine30 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.0) - (input[1])) ^ (2.0)) + (((2.3) - (input[2])) ^ (2.0))) + (((3.3) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))))
    return((subroutine32(input)) + ((var0) * (-0.8898986041811555)))
}
subroutine31 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.3) - (input[1])) ^ (2.0)) + (((2.8) - (input[2])) ^ (2.0))) + (((5.1) - (input[3])) ^ (2.0))) + (((1.5) - (input[4])) ^ (2.0))))
    return((subroutine33(input)) + ((var0) * (-110.34516826676301)))
}
subroutine32 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((5.1) - (input[1])) ^ (2.0)) + (((2.5) - (input[2])) ^ (2.0))) + (((3.0) - (input[3])) ^ (2.0))) + (((1.1) - (input[4])) ^ (2.0))))
    var1 <- exp((-0.06389634699048878) * ((((((4.9) - (input[1])) ^ (2.0)) + (((2.4) - (input[2])) ^ (2.0))) + (((3.3) - (input[3])) ^ (2.0))) + (((1.0) - (input[4])) ^ (2.0))))
    var2 <- exp((-0.06389634699048878) * ((((((6.3) - (input[1])) ^ (2.0)) + (((2.5) - (input[2])) ^ (2.0))) + (((4.9) - (input[3])) ^ (2.0))) + (((1.5) - (input[4])) ^ (2.0))))
    var3 <- exp((-0.06389634699048878) * ((((((5.4) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((4.5) - (input[3])) ^ (2.0))) + (((1.5) - (input[4])) ^ (2.0))))
    var4 <- exp((-0.06389634699048878) * ((((((6.2) - (input[1])) ^ (2.0)) + (((2.2) - (input[2])) ^ (2.0))) + (((4.5) - (input[3])) ^ (2.0))) + (((1.5) - (input[4])) ^ (2.0))))
    var5 <- exp((-0.06389634699048878) * ((((((5.6) - (input[1])) ^ (2.0)) + (((2.9) - (input[2])) ^ (2.0))) + (((3.6) - (input[3])) ^ (2.0))) + (((1.3) - (input[4])) ^ (2.0))))
    var6 <- exp((-0.06389634699048878) * ((((((6.7) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((5.0) - (input[3])) ^ (2.0))) + (((1.7) - (input[4])) ^ (2.0))))
    return((((((((0.11172510039290856) + ((var0) * (-0.8898986041811555))) + ((var1) * (-0.8898986041811555))) + ((var2) * (-0.0))) + ((var3) * (-0.0))) + ((var4) * (-0.0))) + ((var5) * (-0.756413813553974))) + ((var6) * (-0.0)))
}
subroutine33 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.0) - (input[1])) ^ (2.0)) + (((2.2) - (input[2])) ^ (2.0))) + (((5.0) - (input[3])) ^ (2.0))) + (((1.5) - (input[4])) ^ (2.0))))
    return((subroutine34(input)) + ((var0) * (-65.00217641452454)))
}
subroutine34 <- function(input) {
    var0 <- exp((-0.06389634699048878) * ((((((6.2) - (input[1])) ^ (2.0)) + (((2.8) - (input[2])) ^ (2.0))) + (((4.8) - (input[3])) ^ (2.0))) + (((1.8) - (input[4])) ^ (2.0))))
    var1 <- exp((-0.06389634699048878) * ((((((7.2) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((5.8) - (input[3])) ^ (2.0))) + (((1.6) - (input[4])) ^ (2.0))))
    var2 <- exp((-0.06389634699048878) * ((((((6.1) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((4.9) - (input[3])) ^ (2.0))) + (((1.8) - (input[4])) ^ (2.0))))
    var3 <- exp((-0.06389634699048878) * ((((((6.0) - (input[1])) ^ (2.0)) + (((3.0) - (input[2])) ^ (2.0))) + (((4.8) - (input[3])) ^ (2.0))) + (((1.8) - (input[4])) ^ (2.0))))
    var4 <- exp((-0.06389634699048878) * ((((((4.9) - (input[1])) ^ (2.0)) + (((2.5) - (input[2])) ^ (2.0))) + (((4.5) - (input[3])) ^ (2.0))) + (((1.7) - (input[4])) ^ (2.0))))
    var5 <- exp((-0.06389634699048878) * ((((((7.9) - (input[1])) ^ (2.0)) + (((3.8) - (input[2])) ^ (2.0))) + (((6.4) - (input[3])) ^ (2.0))) + (((2.0) - (input[4])) ^ (2.0))))
    var6 <- exp((-0.06389634699048878) * ((((((5.6) - (input[1])) ^ (2.0)) + (((2.8) - (input[2])) ^ (2.0))) + (((4.9) - (input[3])) ^ (2.0))) + (((2.0) - (input[4])) ^ (2.0))))
    return((((((((1.8136162062461285) + ((var0) * (-110.34516826676301))) + ((var1) * (-13.999391039896215))) + ((var2) * (-108.44329471899991))) + ((var3) * (-110.34516826676301))) + ((var4) * (-22.21095753342801))) + ((var5) * (-0.0))) + ((var6) * (-0.0)))
}


summ=data.frame(t(sapply( unique(tracks$track_id),function(id) {
hlp=subset(tracks,track_id==id)
ch=try(sum(sqrt(rowSums(apply(hlp[chull(hlp$norm_x,hlp$norm_y),c("norm_x","norm_y")],2,diff)^2))))
if (class(ch)=="try-error") ch=0
return(c(unique(hlp$cellType_treatment),id,mean(hlp$delta_z,na.rm=TRUE),sum(hlp$delta_z,na.rm=TRUE),ch))
}
)))

names(summ)=c("cellType_treatment","track_id","delta_z","total","ch_peri")
summ[,1]=as.factor(summ[,1])
levels(summ[,1])=levels(tracks$cellType_treatment)

summ$cellType=factor(sapply(strsplit(as.character(summ$cellType_treatment),split="_"),function(x) x[1]))

summ$treat=factor(sapply(strsplit(as.character(summ$cellType_treatment),split="_"),function(x) x[2]),levels=c("control","10.0 µm" ,"20.0 µm","40.0 µm","60.0 µm","80.0 µm","100.0 µm","cxcl1","cxcl8","fmlp"))

cols=blue2red(7)
plot(density(subset(summ,cellType=="ht1080"&treat==levels(treat)[1])$delta_z,bw=1.5),main="ht1080",xlab="mean delta_z",col=cols[1])
for (i in 2:7)
lines(density(subset(summ,cellType=="ht1080"&treat==levels(treat)[i])$delta_z,bw=1.5),col=cols[i])
legend("topright",col=cols,lty=1,legend=levels(summ$treat)[1:7])

plot(density(subset(summ,cellType=="leukocytes"&treat==levels(treat)[1])$delta_z,bw=.55),main="leukocytes",xlab="mean delta_z",ylim=c(0,.4))
for (i in 2:4)
lines(density(subset(summ,cellType=="leukocytes"&treat==levels(treat)[6+i])$delta_z,bw=.55),col=i)
legend("topright",col=1:4,lty=1,legend=levels(summ$treat)[-(2:7)])

plot(density(log(subset(summ,cellType=="ht1080"&treat==levels(treat)[1])$delta_z+.5),bw=0.25),main="ht1080",xlab="mean delta_z",col=cols[1],ylim=c(0,.8))
for (i in 2:7)
lines(density(log(subset(summ,cellType=="ht1080"&treat==levels(treat)[i])$delta_z+.5),bw=0.25),col=cols[i])
legend("topleft",col=cols,lty=1,legend=levels(summ$treat)[1:7])

plot(density(log(subset(summ,cellType=="leukocytes"&treat==levels(treat)[1])$delta_z+.5),bw=.2),main="leukocytes",xlab="mean delta_z",ylim=c(0,1.5))
for (i in 2:4)
lines(density(log(subset(summ,cellType=="leukocytes"&treat==levels(treat)[6+i])$delta_z+.5),bw=.2),col=i)
legend("topleft",col=1:4,lty=1,legend=levels(summ$treat)[-(2:7)])

###chull

bw=density(subset(summ,cellType=="leukocytes"&treat==levels(treat)[1])$ch_peri)$bw
plot(density(subset(summ,cellType=="leukocytes"&treat==levels(treat)[1])$ch_peri,bw=bw),main="leukocytes",xlab="ch_peri")
for (i in 2:4)
lines(density(subset(summ,cellType=="leukocytes"&treat==levels(treat)[6+i])$ch_peri,bw=bw),col=i)
legend("topright",col=1:4,lty=1,legend=levels(summ$treat)[-(2:7)])

plot(hlp[chull(hlp$norm_x,hlp$norm_y),c("norm_x","norm_y")])
lines(hlp[,c("norm_x","norm_y")],type="l")


#' dmrff.meta
#'
#' Identify differentially methylated regions by meta-analysing multiple studies
#' using variance-weighted fixed effects meta-analysis.
#'
#' @param objects List of objects generated by \code{\link{dmrff.pre}}
#' for each participating EWAS.
#' @param p.cutoff Unadjusted p-value cutoff for membership in a candidate DMR
#' (Default: 0.05).
#' @param maxgap Maximum distance between consecutive features (Default: 500bp).
#' @param verbose If \code{TRUE} (default), then output status messages.
#' @return A data frame listing all candidate regions and their summary statistics.
#'
#' @examples
#' pre1 <- dmrff.pre(est1, se1, meth1, ...)
#' pre2 <- dmrff.pre(est2, se2, meth2, ...)
#' ...
#' pre9 <- dmrff.pre(est9, se9, meth9, ...)
#' meta <- dmrff.meta(list(pre1, pre2, ..., pre9))
#' meta$dmrs[which(meta$dmrs$p.adjust < 0.05 & meta$dmrs$n > 1), ]
#'
#' @export
dmrff.meta <- function(objects, maxgap=500, p.cutoff=0.05, verbose=T) {
    stopifnot(is.list(objects))
    stopifnot(length(objects) > 1)

    for (i in 1:length(objects)) {
        if (!is.list(objects[[i]])
            && all(c("estimate","se","chr","pos","sites","rho") %in% names(objects[[i]])))
            stop("object ", i, " was not created by dmrff.pre()")

        if (!("sd" %in% names(objects[[i]]))) ## if pre from older version of dmrff
            objects[[i]]$sd <- rep(1,length(objects[[i]]$se))

        idx <- order(objects[[i]]$chr, objects[[i]]$pos)
        sorted <- identical(idx, 1:length(idx))
        if (!sorted) { ## support for a previous version of dmrff that did not sort
            objects[[i]]$sites <- objects[[i]]$sites[idx]
            objects[[i]]$chr <- objects[[i]]$chr[idx]
            objects[[i]]$pos <- objects[[i]]$pos[idx]
            objects[[i]]$estimate <- as.numeric(objects[[i]]$estimate[idx])
            objects[[i]]$se <- as.numeric(objects[[i]]$se[idx])
            objects[[i]]$sd <- as.numeric(objects[[i]]$sd[idx])
        }
        ## scale summary stats as if methylation was standarized
        objects[[i]]$estimate <- objects[[i]]$estimate/objects[[i]]$sd
        objects[[i]]$se <- objects[[i]]$se/objects[[i]]$sd
    }

    ## identify a set of CpG sites in every dataset
    sites <- objects[[1]]$sites
    for (i in 2:length(objects))
        sites <- intersect(sites, objects[[i]]$sites)

    ## extract CpG site summary statistics
    estimate <- sapply(objects, function(obj)
                       obj$estimate[match(sites, obj$sites)])
    se <- sapply(objects, function(obj)
                 obj$se[match(sites, obj$sites)])
    site.idx <- sapply(objects, function(obj) match(sites, obj$sites))

    ## meta-analysis CpG site associations
    ma <- ivwfe.ma(estimate, se)
    idx <- match(sites, objects[[1]]$sites)
    ma$chr <- objects[[1]]$chr[idx]
    ma$pos <- objects[[1]]$pos[idx]

    ## identify candidate regions
    candidates <- dmrff.candidates(ma$estimate, ma$p.value, ma$chr, ma$pos,
                                   maxgap=maxgap, p.cutoff=p.cutoff,
                                   verbose=verbose)

    if (is.null(candidates)) {
        return(list(ewas=ma, dmrs=NULL))
    }

    ## shrink candidate regions and meta-analyze statistics
    compute.dmr.stats <- function(start.idx,end.idx) {
        stats <- sapply(1:length(objects), function(i) {
            start.idx <- site.idx[start.idx,i]
            end.idx <- site.idx[end.idx,i]
            idx <- start.idx:end.idx
            if (length(idx) > ncol(objects[[i]]$rho))
                return(c(B=0,S=1))
            ivwfe.stats(objects[[i]]$estimate[idx],
                        objects[[i]]$se[idx],
                        rho=extract.rho(objects[[i]]$rho[idx,,drop=F]))
        })
        ivwfe.ma(stats["B",,drop=F], stats["S",,drop=F])
    }
    compute.dmr.z <- function(start.idx,end.idx) {
        compute.dmr.stats(start.idx, end.idx)$z
    }
    stats <- shrink.candidates(candidates$start.idx,
                               candidates$end.idx,
                               compute.dmr.z)

    full <- do.call(rbind, parallel::mclapply(1:nrow(stats), function(i) {
        compute.dmr.stats(stats$start.idx[i], stats$end.idx[i])
    }))

    stats$B <- NA
    stats$S <- NA
    stats$estimate <- full[,"estimate"]
    stats$se <- full[,"se"]

    list(ewas=ma,
         dmrs=collate.stats(stats, ma$chr, ma$pos, simple=T))
}


#
# $Id: scantime.r 8159 2014-12-18 23:29:22Z chambm $
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
# The Original Code is the IDPicker project.
#
# The Initial Developer of the Original Code is Yaoyi Chen.
#
# Copyright 2014 Vanderbilt University
#
# Contributor(s): Jay Holman
#

userLibPath=paste(Sys.getenv("LOCALAPPDATA"),"idpQuantify",sep="\\")
dir.create(userLibPath)
print (userLibPath)
.libPaths(userLibPath)
if (!require(missMDA)) {install.packages('missMDA', repos="http://cran.us.r-project.org"); require(missMDA)}
if (!require(MASS)) {install.packages('MASS', repos="http://cran.us.r-project.org"); require(MASS)}

cmd_args = commandArgs();
#args 7,7+n ..... name of samples
setwd(cmd_args[6])
print (cmd_args)
data=read.table("peptideScanTime.tsv", header=TRUE,sep="\t")
mztolLower=cmd_args[length(cmd_args)-1]
mztolLower=as.numeric(substr(mztolLower, 1, nchar(mztolLower)-3))*10^(-6)

mztolUpper=cmd_args[length(cmd_args)]
mztolUpper=as.numeric(substr(mztolUpper, 1, nchar(mztolUpper)-3))*10^(-6)
timetol=0.1

##if only one sample
if (length(data)==5){
newdata=data
colnames(newdata)[2]="scantime"
out=paste(cmd_args[7],"-peptideScantimeRegression.tsv",sep="")
write.table(newdata,file=out, quote = FALSE,sep="\t",row.names =F)
}

##if more than two samples
if(length(data)>6){
#mark 1 when data !=0
data=replace(data,data==0,NA)

library(missMDA)

res.comp<-imputePCA(data[2:(length(data)-3)],ncp=1)
##res.pca<-PCA(res.comp$completeObs)
reg_data<-data.frame(res.comp$completeObs)

for(i in 2:(length(data)-3)){
out=paste(cmd_args[(i+5)],"-peptideScantimeRegression.tsv",sep="")
##only output the missing data the existing peptides.
mark=data.matrix(data[i])
newdata=data.frame(distinctMatch=data[1][is.na(mark)],scantime=reg_data[i-1][is.na(mark)],charge=data[(length(data)-2)][is.na(mark)],precursorMZ=data[(length(data)-1)][is.na(mark)],peptide=data[(length(data))][is.na(mark)])
##
write.table(newdata,file=out, quote = FALSE,sep="\t",row.names =F)
}
#write.table(data.frame(data[1],reg_data,data[(length(data)-2):length(data)]),file="peptideScantimeRegression_full.tsv", quote = FALSE,sep="\t",row.names =F)

}

#if only two samples
if (length(data)==6){
pep_inter=subset(data,scantime1!=0&scantime2!=0)
only1=subset(data,scantime2==0)
only2=subset(data,scantime1==0)

##with scantime1 na
m1=lm(scantime1~scantime2,data=pep_inter)
##these are peptides absent from rep 1 , predicted for rep1
data1=data.frame(distinctMatch=only2$distinctMatch,scantime=round(predict(m1,only2,interval="none"),digits=4),charge=only2[4],precursorMZ=only2[5],peptide=only2[6])

#with scantime2 na
m2=lm(scantime2~scantime1,data=pep_inter)
#these are peptides absent from rep 2 , predicted for rep2
data2=data.frame(distinctMatch=only1$distinctMatch, scantime=round(predict(m2,only1,interval="none"),digits=4),charge=only1[4],precursorMZ=only1[5],peptide=only1[6])

out1=paste(cmd_args[7],"-peptideScantimeRegression.tsv",sep="")
out2=paste(cmd_args[8],"-peptideScantimeRegression.tsv",sep="")
write.table(data1,file=out1,quote = FALSE,row.names=FALSE,sep="\t")
write.table(data2,file=out2,quote = FALSE,row.names=FALSE,sep="\t")
data1_1=data.frame(distinctMatch=only2$distinctMatch,scantime1=round(predict(m1,only2,interval="none"),digits=4),scantime2=only2$scantime2,charge=only2[4],precursorMZ=only2[5],peptide=only2[6])
data2_1=data.frame(distinctMatch=only1$distinctMatch, scantime1=only1$scantime1,scantime2=round(predict(m2,only1,interval="none"),digits=4),charge=only1[4],precursorMZ=only1[5],peptide=only1[6])
data_t=rbind(pep_inter,data1_1,data2_1)

#write.table(data_t,file="peptideScantimeRegression_full.tsv", quote = FALSE,sep="\t",row.names =F)

}


###VISUALISE MODEL OUTPUTS###
# install.packages("tidyverse")
library(tidyverse)
library(dplyr)
library(ggrepel)
require(rgdal)
library(ggpubr)

#some data were missing from the world bank
#Sudan had the population density taken from WorldoMeter: https://www.worldometers.info/world-population/sudan-population/
#Countries with missing GDP per capita information were supplemented with WB data. These include:
# Greenland
# New Caledonia
# Venezuela, RB
# Faroe Islands
# Bahamas, The
# Iran, Islamic Rep.
# French Polynesia
# Syrian Arab Republic
# Northern Mariana Islands
# Isle of Man
# Liechtenstein
# Cayman Islands
# Virgin Islands (U.S.)
# Guam
# Aruba
# Barbados
# Bermuda
# Curacao

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

#set cluster number
cluster_num <- 6

#read in data
mydata <- read.csv(file.path(folder, 'data_inputs', 'country_data.csv'))

#exclude certain outlier countries
# mydata <- mydata[which(mydata$country != 'Macao SAR, China' & mydata$country != 'Maldives' & mydata$country != 'Bangladesh'),]

#split high income countries
high_income <- mydata[which(mydata$income == 'High income'),]

#drop high income countries
mydata <- mydata[which(mydata$income != 'High income'), ]

#drop countries <1000km
mydata <- mydata[which(mydata$area >= 5000), ]

#drop countries <1000km
mydata <- mydata[which(mydata$pop_density < 500), ]

#get statistical summary
summary(mydata)

#remove missing data
mydata <- na.omit(mydata)

#allocate country name as row name
rownames(mydata) <- mydata$country

#subset country info df
country_info <- select(mydata, income, region)

### subset 3 main variables
subset <- select(mydata, coverage_4g, pop_density, gdp_per_cap)

#scale data to be mean centralized
subset <- scale(subset)

#set the seed value for reproducible results
#k means uses randomised initial centroids
set.seed(42)

#determine number of clusters
wss <- ''
for (i in 1:20) wss[i] <- sum(kmeans(subset, centers=i)$withinss)

#set export directory and export wgsss
tiff(file.path(folder, 'figures', "clustering_wgsss_variables.tiff"))
plot(1:20, wss, type="b", xlab="Number of Clusters", ylab="Within groups sum of squares")
dev.off()

# K-Means Cluster Analysis
fit <- kmeans(subset, cluster_num)
data <- data.frame(subset, fit$cluster)

#turn row names into country column
country_info$country <- rownames(country_info)

#turn row names into country column
data$country <- rownames(data)

#merge cluster results with additional country info
data <- merge(data, country_info, by='country')

#omit missing data rows
data <- na.omit(data) # listwise deletion of missing

#country characters to lower format for merging
data$country <- tolower(data$country)

#remove whitespace for merging
data$country <- gsub(" ", "", data$country)

#read file containing ISO3 country codes
iso3 <- read.csv(file.path(folder, 'data_inputs', 'global_information.csv'))

#lower characters and remove whitespace for merging
iso3$country <- tolower(iso3$country)
iso3$country <- gsub(" ", "", iso3$country)

#merge data
data <- merge(data, iso3, by='country', all=TRUE)

#omit missing rows
data <- na.omit(data)

#rename variable to cluster
names(data)[names(data) == 'fit.cluster'] <- 'cluster'

cluster_1 <- data$cluster[data$country=='malawi'][1]
cluster_2 <- data$cluster[data$country=='kenya'][1]
cluster_3 <- data$cluster[data$country=='pakistan'][1]
cluster_4 <- data$cluster[data$country=='morocco'][1]
cluster_5 <- data$cluster[data$country=='peru'][1]
cluster_6 <- data$cluster[data$country=='mexico'][1]

data$cluster[data$cluster== cluster_1] <- 'C1'
data$cluster[data$cluster== cluster_2] <- 'C2'
data$cluster[data$cluster== cluster_3] <- 'C3'
data$cluster[data$cluster== cluster_4] <- 'C4'
data$cluster[data$cluster== cluster_5] <- 'C5'
data$cluster[data$cluster== cluster_6] <- 'C6'

#select desired columns
long <- select(data, country, coverage_4g, pop_density, gdp_per_cap, cluster, income, region, ISO_3digit)

#transform from wide to long
long <- gather(long, 'coverage_4g', 'pop_density', 'gdp_per_cap', key='metric', value='value')

#create factor levels/labels
long$metric = factor(long$metric, levels=c("gdp_per_cap", "pop_density", "coverage_4g"),
                                  labels=c("GDP per capita", "Population Density", "4G Coverage"))
long$income = factor(long$income, levels=c("Low income", "Lower middle income", "Upper middle income"),
                                  labels=c("Low income", "Lower middle income", "Upper middle income"))

long$cluster = factor(long$cluster, levels=c('C1', 'C2', 'C3', 'C4', 'C5', 'C6'))
# long$cluster = factor(long$cluster, levels=c(1,2,3,4,5,6))

#rename columns
names(long)[names(long) == 'region'] <- 'Region'
names(long)[names(long) == 'income'] <- 'Income'

boxplot <- ggplot(long, aes(cluster, value, colour=cluster, shape=Income)) +
  geom_boxplot(aes(group=factor(cluster))) +
  geom_jitter(width = 0.4, height=0.5, size=1.7) + theme(legend.position = "bottom") +
  #green, light_blue, organge, yellow, dark blue, dark organge
  # scale_colour_manual(values = c("#009E73", "#56B4E9", "#E69F00", "#F0E442", "#0072B2", "#D55E00")) +
  scale_colour_manual(values = c("#F0E442","#E69F00","#D55E00", "#0072B2", "#56B4E9","#009E73")) +
  expand_limits(x = 0, y = 0) +
  guides(colour=FALSE, shape=FALSE) + #guide_legend(ncol=3, title=NULL), guide_legend(ncol=2, reverse=T, title=NULL
  scale_y_continuous(breaks = seq(-2, 8, by = 1), limits=c(-2,3)) +
  labs(title = "Summary Statistics by Cluster Number", x='Cluster Number', y='Mean Centred Values',
       subtitle = "Squares indicate Upper Middle Income, Triangles indicate Lower Middle Income, Circles indicate Lower Income") +
  facet_wrap(~metric)

#export to folder
path = file.path(folder, 'figures', 'clustering_boxplot.tiff')
tiff(path, units="in", width=7, height=5, res=300)
print(boxplot)
dev.off()

#subset data for exporting
data <- select(data, ISO_3digit, country, cluster)

#allocate high income group to df
high_income$cluster <- 'High Income'

#remove whitespace and lower for merging
high_income$country <- gsub(" ", "", high_income$country)
high_income$country <- tolower(high_income$country)

#merge on country column
high_income <- merge(high_income, iso3, by='country')

#subset data
high_income <- select(high_income, ISO_3digit, country, cluster)

#concatenate dfs vertically via row bind
data = rbind(data, high_income)

#export data
write.csv(data, file.path(folder, 'results', 'data_clustering_results.csv'))

rm(data, country_info, fit, high_income, iso3, long, mydata, folder, path,
   subset, i, wss, cluster_num)

if (!require(rgeos)) {
  install.packages("rgeos", repos = "http://cran.us.r-project.org")
  require(rgeos)
}
if (!require(rgdal)) {
  install.packages("rgdal", repos = "http://cran.us.r-project.org")
  require(rgdal)
}
# if (!require(raster)) {
#   install.packages("raster", repos = "http://cran.us.r-project.org")
#   require(raster)
# }
if(!require(ggplot2)) {
  install.packages("ggplot2", repos="http://cloud.r-project.org")
  require(ggplot2)
}
if(!require(viridis)) {
  install.packages("viridis", repos="http://cloud.r-project.org")
  require(viridis)
}
if(!require(dplyr)) {
  install.packages("dplyr", repos = "https://cloud.r-project.org/")
  require(dplyr)
}
if(!require(gtable)) {
  install.packages("gtable", repos = "https://cloud.r-project.org/")
  require(gtable)
}
if(!require(grid)) {
  install.packages("grid", repos = "https://cloud.r-project.org/")
  require(grid)
}
if(!require(readxl)) {
  install.packages("readxl", repos = "https://cloud.r-project.org/")
  require(readxl)
}
if(!require(magrittr)) {
  install.packages("magrittr", repos = "https://cloud.r-project.org/")
  require(magrittr)
}

#set ggplot2 theme for map
theme_map <- function(...) {
  theme_minimal() +
    theme(
      text = element_text(family = "Ubuntu Regular", color = "#22211d"),
      axis.line = element_blank(),
      axis.text.x = element_blank(),
      axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      axis.title.x = element_blank(),
      axis.title.y = element_blank(),
      # panel.grid.minor = element_line(color = "#ebebe5", size = 0.2),
      panel.grid.major = element_line(color = "#ebebe5", size = 0.2),
      panel.grid.minor = element_blank(),
      plot.background = element_rect(fill = "#f5f5f2", color = NA),
      panel.background = element_rect(fill = "#f5f5f2", color = NA),
      legend.background = element_rect(fill = "#f5f5f2", color = NA),
      panel.border = element_blank(),
      ...
    )
}

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

#get data
data <- read.csv(file.path(folder,'results','data_clustering_results.csv'), stringsAsFactors = F)

shapes <- file.path(folder, 'data_inputs', "global_countries.shp")

#fortify the data AND keep trace of the commune code! (Takes ~2 minutes)
gde_15 <- readOGR(shapes, layer = "global_countries")

#fortify the data
map_data_fortified <- fortify(gde_15, region = "ISO_3digit") %>% mutate(id = id)

#now join the thematic data
map_data <- map_data_fortified %>% left_join(data, by = c("id" = "ISO_3digit"))

#swap na label for 'no data'
map_data$cluster[is.na(map_data$cluster)] <- "No Data"

#create map
cluster_map <- ggplot() +
  geom_polygon(data = map_data, aes(fill = factor(cluster),
              x = long, y = lat, group = group), colour='grey', size = 0.2) +
  coord_equal() +  theme_map() +
  labs(x = NULL, y = NULL,  fill = 'Cluster', title = "Global Countries by Cluster",
       subtitle = "Clustering based on GDP Per Capita, Population Density and 4G Coverage") +
  theme(legend.position = "bottom") +
  guides(fill=guide_legend(ncol=8)) +
  scale_fill_manual(values = c("#F0E442","#E69F00","#D55E00", "#0072B2", "#56B4E9","#009E73", "#999999", "#000000"))

#export to folder
path = file.path(folder, 'figures', 'map.tiff')
tiff(path, units="in", width=12, height=12, res=300)
print(cluster_map)
dev.off()

rm(data, gde_15, map_data, map_data_fortified)

cluster_panel <- ggarrange(boxplot, cluster_map, ncol = 1, nrow = 2, align = c("hv"))

#export to folder
path = file.path(folder, 'figures', 'cluster_panel.png')
ggsave(path, units="in", width=10, height=10)
print(cluster_panel)
dev.off()


library(data.table)
library(dplyr)
library(tidyr)
library(stringr)
library(igraph)
library(h2o)
library(randomForest)
library(ggplot2)
library(ModelMetrics)
path = "../datasets/genes_data/"

#---------------------------------#
# Functions
#---------------------------------#
# autoencoder function
autoencoder_fn <- function(data){
  dt_pos <- filter(data, label=='disease')
  dt_unknown <- filter(data, label == 'unknown')
  dt_neg <- filter(data, label == 'non-disease')

  h2o.init(nthreads = -1)
  dt_ho_p <- as.h2o(dt_pos)
  dt_ho_n <- as.h2o(dt_neg)
  dt_ho_u <- as.h2o(dt_unknown)

  features <- setdiff(colnames(dt_ho_n), c('ensg', 'label'))

  splits_neg <- h2o.splitFrame(dt_ho_n,
                               ratio = c(0.5),
                               seed = 5622)

  train_neg  <- splits_neg[[1]]
  test_neg <- splits_neg[[2]]

  model_neg <- h2o.deeplearning(x = features,
                                training_frame = train_neg,
                                model_id = "model_neg",
                                autoencoder = TRUE,
                                reproducible = TRUE, #slow - turn off for real problems
                                ignore_const_cols = FALSE,
                                seed = 562,
                                hidden = c(100, 10, 100),
                                epochs = 800,
                                activation = "Tanh")
  print(paste("train mse on negative cases is ", h2o.mse(model_neg), sep=''))
  anomaly_neg <- h2o.anomaly(model_neg, test_neg) %>%
    as.data.frame() %>%
    tibble::rownames_to_column() %>%
    mutate(ensg = as.vector(test_neg[, 'ensg']),
           node_type = as.vector(test_neg[, 'label']))

  anomaly_uknown <- h2o.anomaly(model_neg, dt_ho_u) %>%
    as.data.frame() %>%
    tibble::rownames_to_column() %>%
    mutate(ensg = as.vector(dt_ho_u[, 'ensg']),
           node_type = as.vector(dt_ho_u[, 'label']))

  anomaly_pos <- h2o.anomaly(model_neg, dt_ho_p) %>%
    as.data.frame() %>%
    tibble::rownames_to_column() %>%
    mutate(ensg = as.vector(dt_ho_p[, 'ensg']),
           node_type = as.vector(dt_ho_p[, 'label']))

  anomaly <- bind_rows(anomaly_neg, anomaly_uknown, anomaly_pos)
  return(anomaly)
}
# random forest helper function
random_forest_helper <- function(data){
  set.seed(534976)
  known_cases <- filter(data, label != 'unknown')
  known_cases$label <- ifelse(known_cases$label=='disease', 1, 0)
  unknown_cases <- filter(data, label == 'unknown')
  idx_train <- sample(nrow(known_cases), 0.5*nrow(known_cases))
  train <- known_cases[idx_train,]
  test <- known_cases[-idx_train,]
  mrf <- randomForest(data=train[,-1], as.factor(label)~., importance=T, do.trace=T, na.action=na.omit)
  test$rf_pred <- predict(mrf, newdata=test[,-1], type='prob')[,2]
  test$rf_pred_b <- ifelse(test$rf_pred > 0.5, 1, 0)
  unknown_cases$rf_pred <- predict(mrf, newdata=unknown_cases[,-1], type='prob')[,2]
  data.name <- deparse(substitute(data))

  cm <- table(real=test$label, predicted=test$rf_pred_b)
  auc <- auc(test$label, test$rf_pred)
  prec <- ppv(test$label, test$rf_pred, cutoff=0.5)
  rec <- recall(test$label, test$rf_pred, cutoff=0.5)
  f1_score <- f1Score(test$label, test$rf_pred, cutoff=0.5)

  print(paste("Results for", data.name, sep=' '))
  print("Confusion matrix on a test set:")
  print(cm)
  print(paste("AUC:", auc, sep=' '))
  print(paste("precision:",prec , sep=' '))
  print(paste("recall:", rec, sep=' '))
  print(paste("f1:", f1_score, sep=' '))
  return(list(test, unknown_cases, c(data.name, cm, auc, prec, rec, f1_score)))
}
label_class_conversion <- function(data){
  data$class <- ifelse(data$label=='disease', 1, ifelse(data$label=='non-disease', 0, 2))
  data$label <- NULL
  return(data)
}
#---------------------------------#
# load data
#_________________________________#
dt_interactions <- fread(paste(path, "interactions.csv", sep=''), header=T)
dt_nodes <- fread(paste(path, "node_attributes.csv", sep=''), header=T)
nodes_hops <- fread(paste(path, "nodes_hops.csv", sep=''), header=T)
nodes_hops[is.na(nodes_hops)] <- 0
#---------------------------------#
# embeddings to features
#_________________________________#
flist <- list.files(path = path, pattern="graphsage_embs")
embs_list <- list()
for(file in flist){
  dt <- fread(paste(path, file, sep=''), header=T)
  dt <- dt[,-1]
  name_comp <- str_split(file, pattern='_')[[1]]
  edge_type <- name_comp[1]
  colnames(dt) <-  c(paste(edge_type, colnames(dt)[-c(257)], sep="_"), colnames(dt)[c(257)])
  data_name <- paste(edge_type, "embs", sep="_")
  assign(data_name, dt)
  embs_list[[data_name]] <- dt
}
dt_embs <- embs_list %>%
  Reduce(function(dtf1,dtf2) full_join(dtf1,dtf2,by="ensg"), .)
dt_embs[is.na(dt_embs)] <- 0

#---------------------------------#
# dataset with all fetutes
#_________________________________#
nodes_hops$label <- NULL
dt_all <- left_join(dt_nodes, nodes_hops, by= "ensg") %>%
  left_join(dt_embs, by="ensg")

# reducing graph and nodes to those that have non-empty biological features
# reducing graph and nodes to those that have non-empty biological features
dt_reduced <- dt_all
dt_reduced$is_empty <- rowSums(dt_reduced[,c(3:234)])
dt_reduced <- filter(dt_reduced, is_empty!=0)
dt_reduced$is_empty <- NULL
dt_reduced <- dt_all
#---------------------------------#
# 3 sets of features
#_________________________________#
# rf requires column names to be of a proper format
colnames(dt_reduced)[4:11] <- paste("brain",colnames(dt_reduced)[4:11], sep='_')
colnames(dt_reduced) <- str_replace_all(colnames(dt_reduced),'- | ','_')
colnames(dt_reduced) <- str_replace_all(colnames(dt_reduced),'-','_')

dt_biological <- dt_reduced[,c(1:234)]
dt_graph <- dt_reduced %>% select(ensg, label, contains("epi"), contains('ppi'), contains('coexp'))
# all - dt_reduced

write.table(label_class_conversion(dt_reduced), paste(path, "all_features.csv", sep=''), sep=',', col.names=T, row.names = F)
write.table(label_class_conversion(dt_biological), paste(path, "biological_features.csv", sep=''), sep=',', col.names=T, row.names = F)
write.table(label_class_conversion(dt_graph), paste(path, "graph_features.csv", sep=''), sep=',', col.names=T, row.names = F)

#---------------------------------#
# autoencoder for 3 feature sets
#_________________________________#
anomaly_biological <- autoencoder_fn(data=dt_biological) %>% mutate(feature_set="biological")
anomaly_graph <- autoencoder_fn(data=dt_graph) %>% mutate(feature_set="graph-related")
anomaly_all <- autoencoder_fn(data=dt_reduced) %>% mutate(feature_set="all")

anomaly <- bind_rows(anomaly_biological, anomaly_graph, anomaly_all)

mean_mse <- anomaly %>%
  group_by(feature_set, node_type) %>%
  summarise(mean = mean(Reconstruction.MSE),
            std=sd(Reconstruction.MSE),
            count=n()
            )
print("Autoencoder mse for all feature sets:")
print(mean_mse)
p_autoencoder <- ggplot(anomaly, aes(x=Reconstruction.MSE, fill=node_type)) +
  geom_density(position="dodge", alpha=0.3) +
  theme_bw(base_size=18) + facet_wrap(~feature_set, scales='free')
p_autoencoder

png(paste(path, "reconstruction_mse.png", sep=''), width = 500, height=700)
print(p_autoencoder)
dev.off()

#---------------------------------#
# random forest
#_________________________________#
rf_biological <- random_forest_helper(data=dt_biological)
rf_graph <- random_forest_helper(data=dt_graph)
rf_all <- random_forest_helper(data=dt_reduced)

# save the unknown prediction for graph features
predictions_rf <- rf_graph[[2]] %>%
  select(ensg, label, rf_pred)

write.table(predictions_rf, paste(path, "rf_predictions_graph_set", sep=''),
              sep=',', col.names = T, row.names = F)