library(randomForest)
library(caret)
library(doMC)
library(mmadsenr)
library(futile.logger)
library(dplyr)
library(ggthemes)

# Train and tune random forest classifiers for each of the three data sets coming out of the experiment
# "equifinality-3", for binary analysis.
#
# Assumes that data-preparation.r has previously loaded CSV files and created binary
# data files, stored in a local data directory.
#
# Reduces the four class data into a two class problem for basic classifier analysis, and it splits off
# a test data set, placing it in the environment.
#
# NOTE:  This analysis takes a LONG time to run, so it is kept separate from the Rmarkdown
# analysis script.  At the completion of the analysis, it saves an environment image, which
# other scripts, such as RMarkdown documents, can load, and access the fitted model popsampled_results.
#
# Only the model training and fitting is done in this script.  The test data set is not analyzed
# here, since it can be done quickly enough that I want to be working in RMarkdown to examine different
# options.

# Set up logging
log_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "popsampled-classification.log")
flog.appender(appender.file(log_file), name='cl')

clargs <- commandArgs(trailingOnly = TRUE)
if(length(clargs) == 0) {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-population-data.rda")
  sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-sampled-data.rda")
} else {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-population-data.rda", args = clargs)
  sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-sampled-data.rda", args = clargs)
}

load(pop_data_file)
load(sampled_data_file)

flog.info("Loaded data file: %s", pop_data_file, name='cl')
flog.info("Loaded data file: %s", sampled_data_file, name='cl')

flog.info("Beginning classification analysis of equifinality-3 data sets", name='cl')

# set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
num_cores <- get_parallel_cores_given_os(dev=TRUE)
flog.info("Number of cores used in analysis: %s", num_cores, name='cl')
registerDoMC(cores = num_cores)

########### Training and Tuning Variables ##############

#
# Common training and tuning parameters for ctmixtures analysis
#

gbm_grid <- expand.grid(.interaction.depth = (1:6)*2,
                        .n.trees = (1:10)*25,
                        .shrinkage = 0.05)

training_control <- trainControl(method="repeatedcv",
                                 number=10, repeats=5)

# make this repeatable - comment this out or change it to get a fresh analysis result
seed_value <- 58132133
set.seed(seed_value)
flog.info("RNG seed to replicate this analysis: %s", seed_value, name='cl')

# Set up sampling of train and test data sets
training_set_fraction <- 0.8
test_set_fraction <- 1.0 - training_set_fraction

# set up popsampled_results data frames
experiment_names <- c("Population Census", "Sample Size 10%", "Sample Size 20%")
popsampled_results <- data.frame()

popsampled_results_roc <- NULL
popsampled_results_model <- NULL
popsampled_results_cm <- NULL

###### Population Data ######

flog.info("Starting analysis of population census data", name='cl')

# first row of popsampled_results
i <- 1
exp_name <- experiment_names[i]

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes
eq3_pop_df$two_class_label <- factor(ifelse(eq3_pop_df$model_class_label == 'allneutral', 'neutral', 'biased'))

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "model_class_label", "innovation_rate")

#######

#model <- train_randomforest(df, training_set_fraction, fit_grid, fit_control, exclude_columns)
model <- train_gbm_classifier(eq3_pop_df, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

popsampled_results_model[["population_census"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
popsampled_results_cm[["population_census"]] <- cm

# calculate a ROC curve
population_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(population_roc$auc@y.values)
popsampled_results_roc[["population_census"]]  <- population_roc

popsampled_results <- rbind(popsampled_results, results)

########################### sampled data ##########################

flog.info("Starting analysis of sampled data set", name='cl')

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes
eq3_sampled_df$two_class_label <- factor(ifelse(eq3_sampled_df$model_class_label == 'allneutral', 'neutral', 'biased'))

## sample size 10 ##
# second row of popsampled_results
i <- 2
exp_name <- experiment_names[i]

eq3_sampled_10 <- dplyr::filter(eq3_sampled_df, sample_size == 10)

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "model_class_label", "innovation_rate", "sample_size")

#######

#model <- train_randomforest(df, training_set_fraction, fit_grid, fit_control, exclude_columns)
model <- train_gbm_classifier(eq3_sampled_10, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)
popsampled_results_model[["sampled_10"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
popsampled_results_cm[["sampled_10"]] <- cm

# calculate a ROC curve
population_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(population_roc$auc@y.values)
popsampled_results_roc[["sampled_10"]]  <- population_roc

popsampled_results <- rbind(popsampled_results, results)

## sample size 20 ##
# second row of popsampled_results
i <- 3
exp_name <- experiment_names[i]

eq3_sampled_20 <- dplyr::filter(eq3_sampled_df, sample_size == 20)

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "model_class_label", "innovation_rate", "sample_size")

#######

#model <- train_randomforest(df, training_set_fraction, fit_grid, fit_control, exclude_columns)
model <- train_gbm_classifier(eq3_sampled_20, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

popsampled_results_model[["sampled_20"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
popsampled_results_cm[["sampled_20"]] <- cm

# calculate a ROC curve
population_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(population_roc$auc@y.values)
popsampled_results_roc[["sampled_20"]]  <- population_roc

popsampled_results <- rbind(popsampled_results, results)

############## Complete Processing and Save popsampled_results ##########3

# we can now use plot_multiple_roc() to plot all the ROC curves on the same plot, etc.
# as well as graph various of the metrics as they vary across sample size and TA duratio
#plot_multiple_roc_from_list(popsampled_results_roc)

if(length(clargs) == 0) {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                              filename = "classification-pop-sampled_results-gbm.RData")
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                                      filename = "classification-pop-sampled_results-gbm-dfOnly.RData")

} else {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                              filename = "classification-pop-sampled_results-gbm.RData", args = clargs)
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                                      filename = "classification-pop-sampled_results-gbm-dfOnly.RData", args = clargs)
}

flog.info("Saving popsampled_results of analysis to R environment snapshot: %s", image_file, name='cl')
save(popsampled_results, popsampled_results_model, popsampled_results_roc, popsampled_results_cm, file=image_file)

flog.info("Saving just data frame of popsampled_results of analysis to R environment snapshot: %s", image_file_popsampled_results, name='cl')
save(popsampled_results, file=image_file_popsampled_results)

# End
flog.info("Analysis complete", name='cl')


#'---
#'output:
#'  pdf_document:
#'    number_sections: true
#'title: "Further analysis of COVID branching process"
#'author: Tim Lucas and Emma Davis
#'fontsize: 8pt
#'geometry: margin=0.5in
#'---

#' # Major model update 1
#'
#' - Quarantine now applies to asymptomatics
#' - Examine delay for contact tracing
#' - Change onset delay to either a 1 day delay or non-adherence.
#' - People that are quarantined have adherence of 1.
#' -

#+setup, echo = TRUE, cache = FALSE

knitr::opts_chunk$set(cache = TRUE, fig.width = 8, fig.height = 5, cache.lazy = FALSE)

library(data.table)
library(tidyverse)
library(git2r)
library(tictoc)
library(ggplot2)
library(patchwork)
library(cowplot)
library(latex2exp)
library(furrr)
library(sn)
library(ggrepel)
library(testthat)

devtools::load_all()

# git2r::revparse_single('.',"HEAD")$sha

set.seed(200516)

#' Delay shape is adherence probability
#'
#' Cap cases was chosen in a seperate analysis (choose_cap.R or something.)
no.samples <- 3

scenarios <- tidyr::expand_grid(
  ## Put parameters that are grouped by disease into this data.frame
  delay_group = list(tibble::tibble(
    delay = c("Adherence"),
    delay_shape = c(0.9),
    delay_scale = 1
  )),
  inc_meanlog = 1.434065,
  inc_sdlog = 0.6612,
  inf_shape = 2.115779,
  inf_rate = 0.6898583,
  inf_shift = 3,
  min_quar_delay = 1,
  max_quar_delay = c(1,4),
  index_R0 = c(1.1,1.3,1.5),
  prop.asym = c(0.4),
  control_effectiveness = seq(0.4, 1, 0.2),
  self_report = c(0.5),
  test_delay = c(0,2), #time from isolation to test result
  sensitivity = c(0.65), #percent of cases detected
  precaution = c(0,7), #this could be between 0 and 7? Number of days stay in isolation if negative test
  num.initial.cases = c(5)) %>%
  tidyr::unnest("delay_group") %>%
  dplyr::mutate(scenario = 1:dplyr::n())

cap_cases <- 2000
max_days <- 300
## Parameterise fixed paramters
sim_with_params <- purrr::partial(ringbp::scenario_sim,
                                  cap_max_days = max_days,
                                  cap_cases = cap_cases,
                                  r0isolated = 0,
                                  disp.iso = 1,
                                  disp.com = 0.5,
                                  quarantine = TRUE)

#+ full_run
tic() ## Run parameter sweep
sweep_results <- ringbp::parameter_sweep(scenarios,
                                         sim_fn = sim_with_params,
                                         samples = no.samples,
                                         show_progress = TRUE)
toc()

# #+ writeout
# saveRDS(sweep_results, file = "data-raw/res_20200515_highk.rds")

# Plot figure 2:  --------------------------------------------------------
# Parameter distributions (incubation, generation interval etc.)

ringbp::make_figure_2()

# Load in results  -------------------------------------------------------

# sweep_results_extra <- readRDS("data-raw/res_20200505_testing_R0_1point5.rds")
# sweep_resultsA <- readRDS("data-raw/res_20200507_complete.rds")
# sweep_resultsB <- readRDS("data-raw/res_20200507_completeB.rds")
#
# sweep_results <- bind_rows(sweep_resultsA, sweep_resultsB)
# sweep_results <- sweep_results %>% unnest(sims) %>%
#   dplyr::group_by(max_quar_delay,index_R0,control_effectiveness,
#                   self_report,test_delay,sensitivity,precaution) %>%
#   nest()

res <- sweep_results %>%
  dplyr::group_by(scenario) %>%
  dplyr::mutate(pext = extinct_prob(sims[[1]], cap_cases = cap_cases, week_range = 40:42)) %>%
  dplyr::ungroup(scenario)

#+ plots3

#+ plotsS, eval = TRUE, cache = FALSE, fig.height = 5, fig.width = 9

# A colour-blind-friendly palette
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")

res %>%
  filter(max_quar_delay == 1) %>%
  filter(precaution == 7) %>%
  filter(test_delay == 2) %>%
  filter(sensitivity == 0.65) %>%
  mutate(prop.asym = factor(sensitivity, labels = c('sensitivity = 65%'))) %>%
  mutate(adherence = factor(self_report, labels = c('50% self reporting'))) %>%
  mutate(index_R0 = factor(index_R0)) %>%
  ggplot(aes(control_effectiveness, 1 - pext, colour = index_R0)) +
  ggplot2::scale_colour_manual(values = cbPalette[c(4,2,7)],name=TeX("Index $\\R_0$")) +
  geom_line() +
  geom_point() +
  facet_grid(adherence ~ prop.asym) +
  ggtitle('Contact trace delay is 1, test delay is 2 days,\nminimum isolation is 7 days') +
  theme(text = element_text(size = 16),plot.title = element_text(size = 16, face = "bold")) +
  ylab('Prob. large outbreak') +
  xlab('Contact tracing coverage') +
  ylim(c(0,0.5))

res %>%
  filter(self_report == 0.5) %>%
  filter(precaution == 7) %>%
  filter(test_delay == 2) %>%
  filter(sensitivity == 0.65) %>%
  mutate(prop.asym = factor(sensitivity, labels = c('sensitivity = 65%'))) %>%
  mutate(max_quar_delay = factor(max_quar_delay, labels = c('1 day trace delay', '4 days'))) %>%
  mutate(index_R0 = factor(index_R0)) %>%
  ggplot(aes(control_effectiveness, 1 - pext, colour = index_R0)) +
  geom_line() +
  geom_point() +
  ggplot2::scale_colour_manual(values = cbPalette[c(4,2,7)],name=TeX("Index $\\R_0$")) +
  facet_grid(max_quar_delay ~ prop.asym) +
  ggtitle('Self-reporting is 50%, test delay is 2 days,\nminimum isolation is 7 days') +
  theme(text = element_text(size = 16),plot.title = element_text(size = 16, face = "bold")) +
  ylab('Prob. large outbreak') +
  xlab('Contact tracing coverage') +
  ylim(c(0,0.5))

res %>%
  filter(self_report == 0.5) %>%
  filter(max_quar_delay == 1) %>%
  filter(sensitivity == 0.65) %>%
  mutate(test_delay = factor(test_delay, labels = c('instant test','2 day delay'))) %>%
  mutate(precaution = factor(precaution, labels = c('immediate release if negative', 'minimum 7 days'))) %>%
  mutate(index_R0 = factor(index_R0)) %>%
  ggplot(aes(control_effectiveness, 1 - pext, colour = index_R0)) +
  ggplot2::scale_colour_manual(values = cbPalette[c(4,2,7)],name=TeX("Index $\\R_0$:")) +
  ggplot2::theme(legend.position = "bottom") +
  theme(text = element_text(size = 16),plot.title = element_text(size = 16, face = "bold")) +
  geom_line() +
  geom_point() +
  facet_grid(test_delay ~ precaution) +
  ggtitle('Self-reporting is 50%, sensitivity is 65%,\ntrace delay is 1') +
  ylab('Prob. large outbreak') +
  xlab('Contact tracing coverage') +
  ylim(c(0,0.6))

# res %>%
#   filter(self_report == 0.5) %>%
#   filter(max_quar_delay == 1) %>%
#   filter(index_R0 == 1.3) %>%
#   mutate(test_delay = factor(test_delay, labels = c('instant test','2 day delay'))) %>%
#   mutate(precaution = factor(precaution, labels = c('immediate release if negative', 'minimum 7 days'))) %>%
#   mutate(sensitivity = factor(sensitivity, labels = c('No testing','65%','95%'))) %>%
#   ggplot(aes(control_effectiveness, 1 - pext, colour = sensitivity)) +
#   ggplot2::scale_colour_manual(values = cbPalette[c(1,3,6)],name="Test sensitivity:") +
#   ggplot2::theme(legend.position = "bottom") +
#   geom_line() +
#   geom_point() +
#   facet_grid(test_delay ~ precaution) +
#   labs(title = TeX('\\textbf{Self-reporting is 50%, trace delay is 1,}'), subtitle = TeX('\\textbf{$\\R_0$ is $1.3$}')) +
#   theme(text = element_text(size = 16),plot.title = element_text(size = 16, face = "bold")) +
#   ylab('Prob. large outbreak') +
#   xlab('Contact tracing coverage') +
#   ylim(c(0,0.4))

#+ by_size, eval = TRUE, cache = TRUE, fig.height = 5, fig.width = 9

res2 <- list()
week_range <- 40:42

sweep_resultsB <- sweep_results %>%
  filter(self_report == 0.5,
         test_delay == 2)

for(i in seq_len(nrow(sweep_resultsB))){
  #print(i)
  tmp <- sweep_resultsB$sims[i][[1]]
  tmp <-
    tmp %>%
    dplyr::group_by(sim) %>% # group by simulation run
    mutate(max_weekly = max(weekly_cases),
           time_to_size = which(cumulative>=500)[1], #time to reach 500 cases (weeks)
           total = max(cumulative)) %>%
    dplyr::filter(week %in% week_range) %>%
    dplyr::summarise(extinct =
                       ifelse(all(weekly_cases == 0 &
                                    cumulative < cap_cases),
                              1, 0),
                     max_weekly = max(max_weekly),
                     time_to_size = min(time_to_size),
                     total = max(total)) %>%
    dplyr::ungroup()
  tmp <-
    tmp %>%
    mutate(index_R0 = sweep_resultsB$index_R0[i],
           control_effectiveness = sweep_resultsB$control_effectiveness[i],
           max_quar_delay = sweep_resultsB$max_quar_delay[i],
           precaution = sweep_resultsB$precaution[i],
           sensitivity = sweep_resultsB$sensitivity[i])

  res2[[i]] <- tmp
}
res2 <- do.call(rbind, res2)

#+ plots_by_size2, eval = TRUE, cache= FALSE

# Cumulation is *the number of runs, with that many total, that went extinct*.
# At cumulative size = 4,
#   cumulation is 0 (everything has more than 4 total cases)
#   so p(outbreak) is total outbreaks / total runs

# at cumulative size = 10
#   cumulation is +ve (say 100)
#   So 100 runs reached 10 but still went extinct.
#   Therefore 1900 runs carried on.
#   so p(outbreak) is (total outbreaks) / (total runs - cumulation)

# we want:
# total outbreaks / n
total_cumulative_distr <-
  res2 %>%
  mutate(total = ifelse(total > 2000, 2000, total)) %>%
  group_by(index_R0, control_effectiveness, max_quar_delay, precaution, sensitivity) %>%
  do(res = tibble(cumdistr = nrow(.) * ecdf(.$total)(4:2000),
                  total = 4:2000,
                  outbreaks = nrow(.) - sum(.$extinct),
                  runs = nrow(.),
                  max_quar_delay = .$max_quar_delay[1],
                  index_R0 = .$index_R0[1],
                  precaution = .$precaution[1],
                  sensitivity = .$sensitivity[1],
                  control_effectiveness = .$control_effectiveness[1],
                  poutbreak = (outbreaks) / (runs - cumdistr)))

total_cumulative_distr <- do.call(rbind, total_cumulative_distr$res) %>%
  mutate(index_R0 = factor(index_R0, labels = c('R0 = 1.1', '1.3','1.5'))) %>%
  mutate(precaution = factor(precaution, labels = c('immediate release', '7 days'))) %>%
  mutate(sensitivity = factor(sensitivity, labels = c('65% sensitive'))) %>%
  mutate(max_quar_delay = factor(max_quar_delay, labels = c('1 day trace delay', '4 days'))) %>%
  filter(outbreaks != 0)

T1 <- total_cumulative_distr %>% filter(sensitivity=="65% sensitive") %>%
  filter(precaution=="7 days")
ggplot(T1,
         aes(total, poutbreak, colour = factor(control_effectiveness), group = factor(control_effectiveness))) +
    geom_line() +
    facet_grid(max_quar_delay ~ index_R0) +
    scale_colour_manual(values = cbPalette) +
    ylab('Prob. large outbreak') +
    guides(colour=guide_legend(title="Prop. Traced")) +
    ggtitle('Prob. of outbreak with total cases so far') +
    ggplot2::theme(legend.position = "bottom") +
    theme(text = element_text(size = 16),plot.title = element_text(size = 16, face = "bold")) +
    xlim(c(0,1000)) +
    ylim(c(0,1))

#+ plots_by_max_weekly, cache = FALSE

total_cumulative_distr <-
  res2 %>%
  group_by(index_R0, control_effectiveness, max_quar_delay, precaution, sensitivity) %>%
  do(res = tibble(cumdistr = sum(.$extinct) * ecdf(.$max_weekly[.$extinct == 1])(1:max(.$max_weekly)),
                  max_max_weekly = max(.$max_weekly),
                  max_weekly = 1:max(.$max_weekly),
                  extinct = sum(.$extinct),
                  outbreaks = nrow(.) - sum(.$extinct),
                  max_quar_delay = .$max_quar_delay[1],
                  runs = nrow(.),
                  index_R0 = .$index_R0[1],
                  precaution = .$precaution[1],
                  sensitivity = .$sensitivity[1],
                  control_effectiveness = .$control_effectiveness[1],
                  poutbreak = (outbreaks) / (runs - cumdistr)))

total_cumulative_distr <-
  do.call(rbind, total_cumulative_distr$res) %>%
  filter(poutbreak < 1) %>%
  mutate(index_R0 = factor(index_R0, labels = c('R0 = 1.1', '1.3','1.5'))) %>%
  mutate(max_quar_delay = factor(max_quar_delay, labels = c('1 day trace delay', '4 day trace delay'))) %>%
  mutate(precaution = factor(precaution, labels = c('immediate release', '7 days'))) %>%
  mutate(sensitivity = factor(sensitivity, labels = c('65% sensitive')))

T1 <- total_cumulative_distr %>% filter(sensitivity=="65% sensitive") %>%
  filter(precaution=="7 days")

ggplot(T1,
       aes(max_weekly, poutbreak, colour = factor(control_effectiveness), group = factor(control_effectiveness))) +
  geom_line() +
  facet_grid(max_quar_delay ~ index_R0, scale = 'free_x') +
  scale_colour_manual(values = cbPalette) +
  ylab('Prob. large outbreak') +
  xlab('weekly cases') +
  guides(colour=guide_legend(title="Prop. Traced")) +
  ggtitle('Prob. of outbreak with size of worst week') +
  ggplot2::theme(legend.position = "bottom") +
  theme(text = element_text(size = 16),plot.title = element_text(size = 16, face = "bold")) +
  xlim(c(0,150))

# Histogram of how long it takes to reach 500 cases (weeks)

ggplot(res2, aes(time_to_size)) + geom_histogram(aes(y=..density..),breaks=1:30,
                                                 na.rm=T, col="orange",fill="orange") +
  ggtitle('Time to reach 500 cases') +
  xlab('Time (weeks)')

res3 <- res2 %>% filter(sensitivity==0.65) %>%
  #filter(max_quar_delay==1) %>%
  filter(precaution==7) %>%
  mutate(total = pmin(total,2000))

res3 <- res3 %>%
  group_by(control_effectiveness, index_R0, max_quar_delay) %>%
  mutate(x := total[order(total)]) %>%
  mutate(y := 1-seq_along(total)/length(total)) %>%
  ungroup

res3 <- res3 %>% group_by(control_effectiveness, index_R0,x,max_quar_delay) %>%
  mutate(y=max(y)) %>%
  ungroup()

res3 %>% mutate(index_R0 = factor(index_R0, labels=c("1.1","1.3","1.5"))) %>%
    mutate(control_effectiveness = factor(control_effectiveness, labels=c("Prop. traced 40%","60%","80%","100%"))) %>%
    mutate(max_quar_delay = factor(max_quar_delay, labels=c("1 day trace delay","4 days"))) %>%
  ggplot(aes(x,y,colour=index_R0)) + geom_line() +
  scale_colour_manual(values = cbPalette[c(4,2,7)]) +
  facet_grid(max_quar_delay ~ control_effectiveness) +
  xlim(c(5,2000)) + ylim(c(0,1)) +
  scale_x_continuous(breaks=c(5,500,1000,2000)) +
  ggplot2::theme(legend.position = "bottom") +
  theme(text = element_text(size = 16),plot.title = element_text(size = 16, face = "bold")) +
  xlab('outbreak size, X') +
  ylab('risk of outbreak larger than X') +
  ggtitle('Risk of outbreak exceeding size X, by tracing coverage and speed')

# Boxplots?
# res3 %>% filter(sensitivity==0.65) %>%
#   mutate(control_effectiveness = factor(control_effectiveness,labels=c("Prop. traced 40%","60%","80%","100%"))) %>%
#   mutate(index_R0 = factor(index_R0, labels=c("1.1","1.3", "1.5"))) %>%
#   mutate(max_quar_delay = factor(max_quar_delay, labels=c("1 day trace delay","4 days"))) %>%
#   ggplot(aes(control_effectiveness,max_weekly)) + geom_boxplot() +
#   facet_grid(index_R0 ~ max_quar_delay) +
#   scale_y_log10()

delay_shape = c(0.9)
delay_scale = 1
inc_meanlog = 1.434065
inc_sdlog = 0.6612
inf_shape = 2.115779
inf_rate = 0.6898583
inf_shift = 3
min_quar_delay = 1
max_quar_delay = 4
index_R0 = 1.3
prop.asym = 0.4
prop.ascertain = control_effectiveness = 0.6
self_report = c(0.5)
test_delay = 2 #time from isolation to test result
sensitivity = 0.65 #percent of cases detected
precaution = 7 #this could be between 0 and 7? Number of days stay in isolation if negative test
num.initial.cases = 5
disp.iso = 1
r0community = index_R0
r0isolated = 0
disp.com = 0.16
quarantine = TRUE
testing = TRUE
cap_cases = 2000
cap_max_days = 300


args <- commandArgs(TRUE)

depth.f <- args[1]
sex.f <- args[2]
outfile <- args[3]

rt <- read.table(depth.f,header=TRUE,sep="\t")

# https://genomebiology.biomedcentral.com/articles/10.1186/gb-2013-14-10-r120
# GC矫正公式
# Depth_correct = Depth_raw * (m/Mx)
# m是所有exon的中位值
# Mx是与该targe具有相同GC含量的所有target的深度的中位值

shift_sex <- function(df){ # NOT USED
    chr.all <- unique(df$chromosome)
    sex <- NULL
    # 常染色体平均深度
    df.autochr <- df[df$chromosome != "chrX" & df$chromosome != "chrY",]
    mean.cov.autochr <- mean(df.autochr$depth)

    # 检查是否存在chrY
    if ("chrY" %in% chr.all){
        df.chrY <- df[df$chromosome == "chrY",]
        depth.chrY <- df.chrY$depth
        mean.cov.chrY <- mean(depth.chrY)
        if (mean.cov.chrY >= 50){
            sex <- "male"
            print("==========================")
            print(paste("the mean cov of chrY is: ",mean.cov.chrY,sep=""))
            print(paste("the mean cov of autochr is: ",mean.cov.autochr,sep=""))
            print("this sample is assumed as male")
            print("==========================")
        }else{
            sex <- "unknown"
        }
    }

    # 判断是否存在chrX
    if ("chrX" %in% chr.all){
        df.chrX <- df[df$chromosome == "chrX",]
        depth.chrX <- df.chrX$depth
        mean.cov.chrX <- mean(depth.chrX)
        r <- mean.cov.chrX / mean.cov.autochr
        if (r >= 0.4 & r <= 0.6){
            sex <- "male"
            print("==========================")
            print(paste("the mean cov of chrX is: ",mean.cov.chrX,sep=""))
            print(paste("the mean cov of autochr is: ",mean.cov.autochr,sep=""))
            print(paste("mean.cov.chrX / mean.cov.autochr is: ",r,sep=""))
            print(paste("this sample is assumed as male"))
            print("==========================")
        }else{
            sex <- "female"
            print("==========================")
            print(paste("the mean cov of chrX is: ",mean.cov.chrX,sep=""))
            print(paste("the mean cov of autochr is: ",mean.cov.autochr,sep=""))
            print(paste("mean.cov.chrX / mean.cov.autochr is: ",r,sep=""))
            print(paste("this sample is assumed as female"))
            print("==========================")
        }
    }

    if.chrX <- "chrX" %in% chr.all
    if.chrY <- "chrY" %in% chr.all
    if (!if.chrX & !if.chrY){
        sex <- "unknown"
        print("==========================")
        print("this sample can not find chrX or chrY")
        print("this sample sex is unknown")
        print("==========================")
    }

    return(sex)
}

# 性别矫正
#this.sex <- shift_sex(rt)

sex.df <- read.table(sex.f,header=FALSE,sep="\t")
this.sex <- sex.df[1,2]
print(paste("infered sex is:",this.sex))

# check chr naming
chrom <- rt[1,1]
if (grepl('chr',chrom)){
    # with chr-prefix
    chr_naming <- 'with_prefix'
}else{
    chr_naming <- 'no_prefix'
}

if (this.sex == "male"){
    if (chr_naming == "with_prefix"){
        df.sexchr <- rt[rt$chromosome == "chrX" | rt$chromosome == "chrY",]
        cov <- df.sexchr$depth # sex chr's cov
        rt[rt$chromosome == "chrX" | rt$chromosome == "chrY",]$depth <- cov * 2
    }else{
        df.sexchr <- rt[rt$chromosome == "X" | rt$chromosome == "Y",]
        cov <- df.sexchr$depth # sex chr's cov
        rt[rt$chromosome == "X" | rt$chromosome == "Y",]$depth <- cov * 2
    }
}

median.depth.all <- median(rt$depth)
print(paste("median depth of all exon is",median.depth.all,sep=": "))

# GC矫正
depth.new <- c()
for (i in 1:nrow(rt)){
    depth.raw <- rt[i,5]
    gc <- rt[i,7]
    same.gc <- rt[rt$gc == gc,]
    med.depth <- median(same.gc$depth)
    if (med.depth == 0){
		dep.new <- depth.raw # 如果med.depth=0,x/0会产生NA/Inf
	}else{
		dep.new <- round(depth.raw * (median.depth.all/med.depth),0) # 四舍五入
	}

    depth.new <- c(depth.new,dep.new)
}

rt$depth_corrected <- depth.new

write.table(rt,outfile,quote=FALSE,sep="\t",row.names=FALSE)


pdf_file<-"pdf/scatterplots_three_points.pdf"
cairo_pdf(bg="grey98", pdf_file,width=14,height=9)

par(mai=c(2,1,1,1),omi=c(0,0,0,0),xpd=T,family="Lato Light",las=1)

# Define data and prepare chart

names<-c("BMW:\n44,6 Bn.","Daimler:\n45,5 Bn.","","Facebook:\n75-100 Bn.")
myValue<-c(44.6,45.5,100,75)
myRevenue<-c(60.5,97.8,2.5,2.5)
myProfit<-c(4.8,4.7,1,1)

myC1<-rgb(80,80,80,maxColorValue=255)
myC2<-rgb(255,97,0,maxColorValue=255)
myC3<-"grey"
myC4<-rgb(58,87,151,maxColorValue=255)

# Define chart and other elements

plot(myRevenue,myProfit,axes=F,type="n",xlab="Revenue (years)",ylab="Profit (years)",xlim=c(-20,100),ylim=c(-1,6),cex.lab=1.5)
for (i in 1:3)
{
arrows(myRevenue[i],-1,myRevenue[i],myProfit[i],length=0.10,lty="dotted",angle=10,code=0,lwd=1,col="grey70")
arrows(-20,myProfit[i],myRevenue[i],myProfit[i],length=0.10,lty="dotted",angle=10,code=0,lwd=1,col="grey70")
}
points(myRevenue,myProfit,pch=19,cex=myValue/2.6,col=c(myC1,myC2,myC3,myC4))
text(myRevenue,myProfit,names,col="white",cex=1.3)
axis(1,at=c(2.5,60.5,97.8),labels=c("2.5*","60.5","97.8"),cex.axis=1.25)
axis(2,at=c(1,4.8),labels=c("1.0","4.8\n4.7"),cex.axis=1.25)
text(-25.5,5.08,"**")
text(-26.5,1.08,"*")

# Titling

mtext(line=1,"Facebook, BMW and Daimler by comparison",cex=3.5,adj=0,family="Lato Black")
mtext(line=-1,"Profit, revenue, stock market value (circle size, status: 01.30.2012)",cex=1.75,adj=0,font=3)
mtext(line=-3,"All values in Bn. Euro",cex=1.75,adj=0,font=3)
mtext(side=1,line=6.5,"Source www.spiegel.de",cex=1.75,adj=1,font=3)
mtext(side=1,line=4.5,"* Estimated",cex=1.75,adj=0)
mtext(side=1,line=6.5,"** Result before tax",cex=1.75,adj=0)
dev.off()


library(caret)
library(mmadsenr)
library(xtable)
library(ggthemes)
library(dplyr)
getOption('xtable.comment',FALSE)

load(get_data_path(suffix = "experiment-ctmixtures/equifinality-4/results", filename = "biased-gbm-merged-dfonly.RData"))
load(get_data_path(suffix = "experiment-ctmixtures/equifinality-4/results", filename = "classification-gbm-merged-dfonly.RData"))
load(get_data_path(suffix = "experiment-ctmixtures/equifinality-4/results", filename = "cm-merged-gbm.RData"))

# fix a couple of annoying mismatches stemming from the model fitting scripts
tmp <- cm_objects[["population_census"]]
cm_objects[["Population Census"]] <- tmp
cm_objects[["population_census"]] <- NULL

tmp <- cm_objects[["perlocus_pop"]]
cm_objects[["Per-Locus Population Census"]] <- tmp
cm_objects[["perlocus_pop"]] <- NULL

tmp <- cm_objects[["combined_tassize"]]
cm_objects[["All Sample Sizes and TA Durations"]] <- tmp
cm_objects[["combined_tassize"]] <- NULL

c_names <- classifier_results$experiments

names <- NULL
ratios <- NULL
groups <- NULL
for(name in c_names) {
  print(name)
  names <- c(names, name)

  experiment_row <- subset(classifier_results, experiments == name)
  group <- experiment_row$exp_group

  groups <- c(groups, group)

  num <- cm_objects[[name]][["table"]][[3]]
  den <- cm_objects[[name]][["table"]][[4]]
  r <- (num / (num + den)) * 100.0
  print(sprintf("r: %f", r))

  ratios <- c(ratios, r)
}

#error_ratio_neutral <- as.data.frame(cbind(names,as.numeric(ratios)))
error_ratio_neutral <- data.frame(names,as.numeric(ratios))
names(error_ratio_neutral) <- c("Data Collection Treatment", "% Misclassified")

# reorder in ascending order of ratio
error_ratio_neutral <- dplyr::arrange(error_ratio_neutral, ratios)

filename <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4/results",
                            filename = "misclassification-ratio-neutral-biased.RData")
save(error_ratio_neutral, file = filename)

# now make a nice looking table

print(xtable(error_ratio_neutral,
      align="|l|l|c|",digits = c(0,0,1)), include.rownames = FALSE, comment=FALSE,floating=FALSE,
      file = "../paper/misclassification-percentage-neutral-data.tex")


ta_comfort <- function(rh, iclo, wind, M, H) {
    .Call('biometeoR_ta_comfort', PACKAGE = 'biometeoR', rh, iclo, wind, M, H)
}


# with R first install.packages
################ install.packages('Rilostat')
################ install.packages('tidyverse')

require(tidyverse)
require(Rilostat)

ref_indicator = c(	'EAP_TEAP_SEX_AGE_NB', 		# Labour Force by Sex and Age
					'EAP_TEAP_SEX_AGE_GEO_NB',	# Labour Force by Sex Age and Rural/Urban Areas
					'EAP_TEAP_SEX_AGE_EDU_NB',	# Labour Force by Sex, Age and Education
					'EMP_DWAP_SEX_AGE_RT'		# Employment to Population Ratio by Sex and Age
				)

X <- get_ilostat(id = 'CAN_A', segment = 'ref_area', filters = list(indicator = ref_indicator, timefrom = '2000', source = 'BA'))

X %>% filter(indicator %in% 'EMP_DWAP_SEX_AGE_RT') %>% select(source:obs_value) %>% spread(time, obs_value)

 get_ilo(collection = 'STI', indicator = 'EMP_DWAP_SEX_AGE_GEO_RT', timefrom = '2008', ref_area = 'CAN', classif1 = 'AGGREGATE') %>% select(source:obs_value) %>% spread(time, obs_value) %>% save_ilo()


##' Plot figure 1
##'
##' Shapefiles can be obtained from
##' https://data.humdata.org/dataset/dr-congo-health-0. Download
##' RDC_Zone_de_sante.zip, unpack it and pass the directory in which it was
##' unpacked to this function.
##'
##' @param shapefile_dir directory containing the shape files
##' @return plot
##' @importFrom sf st_read st_union st_centroid
##' @importFrom lwgeom st_make_valid
##' @importFrom dplyr rename mutate filter if_else left_join group_by summarise select %>%
##' @importFrom tidyr replace_na
##' @importFrom purrr map map_dbl
##' @importFrom ggplot2 ggplot geom_sf geom_text xlab ylab coord_sf theme scale_fill_gradient aes element_blank
##' @author Sebastian Funk
##' @export
figure1 <- function(shapefile_dir) {

    health_zone_province <- katanga_measles_cases %>%
        dplyr::select(name=health_zone, province) %>%
        unique

    ## name assimilation
    katanga <- st_read(dsn=shapefile_dir, layer="zoneste") %>%
        rename(name=NOM_ZS) %>%
        mutate(name=as.character(name)) %>%
        mutate(name=if_else(name == "Mbulala", "Mbulula", name),
               name=if_else(name == "Kabondo Dianda", "Kabondo-Dianda", name),
               name=if_else(name == "Malemba", "Malemba-Nkulu", name),
               name=if_else(name == "Kilela Balanda", "Kilela-Balanda", name),
               name=if_else(name == "Kiyambi", "Kiambi", name),
               name=if_else(name == "Mufunga Sampwe", "Mufunga-Sampwe", name)) %>%
        filter(name %in% health_zone_province$name) %>%
        st_make_valid %>%
        left_join(health_zone_province)

    katanga_province <- katanga %>%
        group_by(province) %>%
        summarise(geometry=st_union(geometry)) %>%
        mutate( ## https:/.data=/github.com/tidyverse/ggplot2/issues/2111
            CENTROID = map(geometry, st_centroid),
            COORDS = map(CENTROID, st_coordinates),
            COORDS_X = map_dbl(COORDS, 1),
            COORDS_Y = map_dbl(COORDS, 2))

    health_zone_2015 <- katanga_measles_cases %>%
        filter(week_start >= "2015-01-01" & week_start <  "2016-01-01") %>%
        group_by(health_zone) %>%
        summarise(cases=sum(cases, na.rm=TRUE)) %>%
        select(name=health_zone, cases)

    map_2015 <- katanga %>%
        left_join(health_zone_2015, by="name") %>%
        replace_na(list(cases=0)) %>%
        mutate(cases=if_else(Nom_ZS_PUC %in% c("Kikula", "Lukafu", "Manika", "Kanzenze"), NA_real_, cases))

    p <- ggplot(map_2015) +
        geom_sf(aes(fill=cases), color="grey80") +
        geom_text(data=katanga_province, size=5, aes(COORDS_X-50000, COORDS_Y+10000,
                                                     label=province)) +
        xlab("") + ylab("") +
        coord_sf(datum=NA) +
        theme(axis.line = element_blank(),
              panel.grid.major = element_blank(),
              panel.grid.minor = element_blank(),
              panel.border = element_blank(),
              panel.background = element_blank(),
              axis.ticks = element_blank(),
              axis.text.x = element_blank(),
              axis.text.y = element_blank()) +
        scale_fill_gradient("Reported cases", low="white", high="black", na.value="white")
    return(p)
}


library('Metrics')
library('RUnit')

test.suite <- defineTestSuite("Metrics",
                              dirs = file.path("inst/tests"),
                              testFileRegexp = '^.+\\.r')

test.result <- runTestSuite(test.suite)

printTextProtocol(test.result)


#Import libraries---------
library(raster)
library(rgdal)
library(rgeos)
library(landsat)
library(RStoolbox)
library(cluster)
library(NbClust)
library(factoextra)
library(tmap)
library(doParallel)
library(randomForest)
library(caret)
library(ROCR)
library(stargazer)
library(simpleboot)

#Set seed and multicore-------
set.seed(12345)

cl <- makeCluster(detectCores())
registerDoParallel(cl)

#Plot the different light bands from the Orthonomic photos -------------
#below code sourced from :
#https://www.earthdatascience.org/courses/earth-analytics/multispectral-remote-sensing-data/landsat-data-in-r-geotiff/

#Color band combinations for landsat 5:
#https://www.esri.com/arcgis-blog/products/product/imagery/band-combinations-for-landsat-8/?rmedium=redirect&rsource=/esri/arcgis/2013/07/24/band-combinations-for-landsat-8

spec_rgb <-
  stack(
    "C:/Users/Sanil Purryag/Google Drive/St Andrews docs/Modules/Semester 2/Thesis data/PortMoak_RTK_Ortho.tif"
  )

spec_br <- brick(spec_rgb)

#rename the different bands
names(spec_rgb) <- c('Blue', 'Green', 'Red', 'NIR', 'RE')

names(spec_br) <- c('Blue', 'Green', 'Red', 'NIR', 'RE')

#check if files have been properly renamed

names(spec_br)

#Import the DSM data
spec_lidar <-
  raster(
    "C:/Users/Sanil Purryag/Google Drive/St Andrews docs/Modules/Semester 2/Thesis data/PortMoak_RTK_DSM.tif"
  )

#Plot each individual band

plot(
  spec_br,
  stretch = "hist",
  maxv = 65535,
  #col = gray(0:100 / 100),
  box = FALSE,
  axes = FALSE
)

#True color composite plot

par(col.axis = "white",
    col.lab = "white",
    tck = 0)
plotRGB(
  spec_br,
  r = 3,
  g = 2,
  #should be 2.5 times more
  b = 1,
  stretch = "hist",
  axes = FALSE,
  scale = 65535,
  main = "RGB composite image/n Landsat Bands 3,2,1"
)

#False color composite plot
par(col.axis = "white",
    col.lab = "white",
    tck = 0)
plotRGB(
  spec_br,
  r = 5,
  g = 4,
  b = 3,
  stretch = "hist",
  axes = FALSE,
  main = "RGB False composite image\n Landsat Bands 5,4,3"
)
box(col = "white")

#Exploratory analysis------------

#Plot histogram of values from DSM

#assign and replace NAs with base 160
histlidar <- spec_lidar
NAvalue(histlidar) <- 160
#Plot distribution of values in hist
hist(
  histlidar,
  main = "Distribution of DSM Values(100,000 pixels sampled)",
  xlab = "DSM Elevation Value (Inches)",
  ylab = "Frequency",
  col = "cornflowerblue",
  ylim = c(0, 20000),
  xlim = c(150, 200)
)

hist(spec_br,
     xlab = "Pixel Intensity",
     ylab = "Frequency",
     col = "cornflowerblue")
# ylim = c(0, 20000),
# xlim = c(150, 200))

#Pairs plot of different bands
pairsplot <- pairs(spec_rgb)

#Hillshading (DSM Workstream)-----------
#Below code adapted from:
#https://github.com/mgimond/Spatial/blob/master/A4-Raster-Operations.Rmd
#https://www.rdocumentation.org/packages/raster/versions/2.6-7/topics/focal

#Estimate the slope and aspect of the terrain
slope <- terrain(spec_lidar, opt = 'slope')
aspect <- terrain(spec_lidar, opt = 'aspect')

#Create hillshade (DTM) using the queen case (neighbours = 8)
#Current specification used for rough terrain estimation
hill <- hillShade(slope, aspect, 40, 270)

#plot the tmap package to see greyscale raster
hill <-
  aggregate(hill, 25) # aggregate the raster by a factor of 25
tm_shape(hill) + tm_raster(palette = "Greys") +
  tm_legend(outside = TRUE, text.size = .6) + tm_layout(title = "Hillshaded DSM")

#Histogram of hillside values - 100,000 sampled values
hist(
  hill,
  main = "Distribution of Aggregated hill values",
  xlab = "Hillshaded values",
  ylab = "Frequency",
  col = "cornflowerblue"
)
abline(v = 0.5, col = "Red", lty = 4)

#Zonal statistics - Sobel----

#===============================================================================Sobel Kernel Application

#Assign hill to new object
hillside <- hill
#Threshold hillside
hillside[hillside > 0.5] <- NA
na.omit(hillside)
#plot code adapted from:
#https://stackoverflow.com/questions/28247812/r-raster-package-plot-producing-monochrome-images

plot(hill,
     main = "Hillshaded DSM raster",
     col = gray.colors(
       10,
       start = 0.3,
       end = 0.9,
       gamma = 2.2,
       alpha = NULL
     ))
plot(
  hillside,
  main = "Thresholded DSM hillshaded raster at 0.5 level",
  col = gray.colors(
    10,
    start = 0.3,
    end = 0.9,
    gamma = 2.2,
    alpha = NULL
  )
)

#Sobel weight matrix definition
Sobel <- matrix(c(-1, 0, 1,-2, 0, 2,-1, 0, 1) / 4, nrow = 3)
f5    <- focal(hillside, w = Sobel, fun = sum)
# tm_shape(f5) + tm_raster(palette = "black") +
#   tm_legend(legend.show = TRUE, "Distribution of values")
freq(f5)
plot(f5,
     col = gray.colors(
       10,
       start = 0.3,
       end = 0.9,
       gamma = 2.2,
       alpha = NULL
     ),
     main = "Sobel Edge Detection Application")
#Flatten the map by reprojecting the raster to a Km by km dimension and to the British grid
Projected.sobel <-
  projectRaster(f5, crs = "+init=epsg:27700 +units=km")
#project the raster to a resolution of 10m per cell
Reprojection.sobel <-
  projectRaster(Projected.sobel,
                crs = crs(Projected.sobel),
                res = 0.010)
plot(Reprojection.sobel, main = "Reprojected Sobel Raster")
count.sobel <- freq(Reprojection.sobel)
print(count.sobel)

#===============================================================================Sobel over different levels
# #Different levels of thresholding based on 0.01 increase between 0.1 and 1
# #100 numbers between 0 and 1
# seq.length <- seq(0.1, 1, 0.01)
# sobel.count <- list()
#
# for (i in seq.length) {
#   #Reset before thresholding
#   hillside <- hill
#   #threshold hillside by i
#   hillside[hillside > i] <- NA
#   na.omit(hillside)
#   #Compute sobel kernel and associated focal stats
#   Sobel <- matrix(c(-1, 0, 1,-2, 0, 2,-1, 0, 1) / 4, nrow = 3)
#   f6    <- focal(hillside, w = Sobel, fun = sum)
#   #Reproject the computed focal raster
#   Projected.sobel <-
#     projectRaster(f6, crs = "+init=epsg:27700 +units=km")
#   #project the raster to a resolution of 10m per cell
#   Reprojection.sobel <-
#     projectRaster(Projected.sobel,
#                   crs = crs(Projected.sobel),
#                   res = 0.010)
#   #Obtain the frequency of observed values
#   count.sobel <- as.matrix(freq(Reprojection.sobel))
#   sobel.count[[paste0("Threshold level ", i)]] <- count.sobel
#   #print(sobel.count)
# }
#
# tree.sobel <- c()
# for (m in 1:length(sobel.count)) {
#   tree.sobel <-
#     c(tree.sobel, (sobel.count[[m]][(as.numeric(which(sobel.count[[m]] == 0))), 2]))
# }
#
# plot(
#   y = tree.sobel,
#   x = seq.length,
#   type = "o",
#   ylab = "Count of Trees",
#   xlab = "Thresholding Values",
#   main = "Sobel Tree count evolution based on Thresholding ",
#   col = "cornflowerblue"
# )
#===============================================================================Sobel Adjusted thresholds
#Different levels of thresholding based on 0.01 increase between 0 and 0.6
#100 numbers between 0 and 1
seq.length1 <- seq(0.1, 0.6, 0.001)
sobel.count5 <- list()

for (h in seq.length1) {
  #Reset before thresholding
  hillside <- hill
  #threshold hillside by i
  hillside[hillside > h] <- NA
  na.omit(hillside)
  #Compute sobel kernel and associated focal stats
  Sobel <- matrix(c(-1, 0, 1,-2, 0, 2,-1, 0, 1) / 4, nrow = 3)
  f7    <- focal(hillside, w = Sobel, fun = sum)
  #Reproject the computed focal raster
  Projected.sobel5 <-
    projectRaster(f7, crs = "+init=epsg:27700 +units=km")
  #project the raster to a resolution of 10m per cell
  Reprojection.sobel5 <-
    projectRaster(Projected.sobel5,
                  crs = crs(Projected.sobel5),
                  res = 0.010)
  #Obtain the frequency of observed values
  count.sobel5 <- as.matrix(freq(Reprojection.sobel5))
  sobel.count5[[paste0("Threshold level ", h)]] <- count.sobel5
  #print(sobel.count5)
}

tree.sobel1 <- c()
for (o in 1:length(sobel.count5)) {
  tree.sobel1 <-
    c(tree.sobel1, (sobel.count5[[o]][(as.numeric(which(sobel.count5[[o]] == 0))), 2]))
}

plot(
  y = tree.sobel1,
  x = seq.length1,
  type = "o",
  ylab = "Count of Trees",
  xlab = "Thresholding Values",
  main = "Sobel Tree count evolution based on Thresholding ",
  col = "cornflowerblue"
)

#===============================================================================Sobel Non parametric CI

#compute the SE of the simulated distribution
standard.error.sobel <- sd(tree.sobel1) / sqrt(length(tree.sobel1))
mean.error.sobel  <- mean(tree.sobel1)
#upper and lower normal limits
ul.sobel <- mean.error.sobel + 1.96 * (standard.error.sobel)
ll.sobel <- mean.error.sobel -  1.96 * (standard.error.sobel)
#add lines for bands to the plot y axis
abline(h = mean.error.sobel, col = "black", lty = 2)
abline(h = ul.sobel, col = "red", lty = 2)
abline(h = ll.sobel, col = "red", lty = 2)

#compute a nonparametric bootstrap from the different thresholded counts
#code adapted from:
#https://stats.stackexchange.com/questions/16516/how-can-i-calculate-the-confidence-interval-of-a-mean-in-a-non-normally-distribu

#Take tree counts from different thresholds and laplace application
#2000 resamples, 5% trim

sobel.boot <- one.boot(tree.sobel1, mean, R = 2000, tr = 0.05)
hist(sobel.boot, main = "Sobel count bootstrap distribution", col = "cornflowerblue")
sobel.bootstrap <- boot.ci(sobel.boot, type = c("perc", "bca"))
print(sobel.bootstrap)

#Zonal statistics - Laplace----

#===============================================================================Laplacian filter Application

#Assign hill to new object
hillside <- hill
#Threshold hillside
hillside[hillside > 0.5] <- NA
na.omit(hillside)

laplace <- matrix(c(0, 1, 0, 1,-4, 1, 0, 1, 0), nrow = 3)
f10    <- focal(hillside, w = laplace, fun = sum)
#tm_shape(f10) + tm_raster(palette = "black") +
#  tm_legend(legend.show = TRUE)
freq(f10)
plot(f10,
     col = gray.colors(
       10,
       start = 0.3,
       end = 0.9,
       gamma = 2.2,
       alpha = NULL
     ),
     main = "Laplace Edge Detection Application")

#Flatten the map by reprojecting the raster to a Km by km dimension and to the British grid
Projected.laplace <-
  projectRaster(f10, crs = "+init=epsg:27700 +units=km")
#project the raster to a resolution of 10m per cell
Reprojection.laplace <-
  projectRaster(Projected.laplace,
                crs = crs(Projected.laplace),
                res = 0.010)
count.laplace <- freq(Reprojection.laplace)
print(count.laplace)
plot(Reprojection.laplace, main = "Reprojected Laplace")
#===============================================================================Laplacian over different levels

# #Different levels of thresholding based on 0.01 increase between 0.1 and 1
# #100 numbers between 0 and 1
# seq.length <- seq(0.1, 1, 0.01)
# laplace.count <- list()
#
# for (i in seq.length) {
#   #Reset before thresholding
#   hillside <- hill
#   #threshold hillside by i
#   hillside[hillside > i] <- NA
#   na.omit(hillside)
#   #Compute sobel kernel and associated focal stats
#   laplace <- matrix(c(0, 1, 0, 1,-4, 1, 0, 1, 0), nrow = 3)
#   f11    <- focal(hillside, w = laplace, fun = sum)
#   #Reproject the computed focal raster
#   Projected.laplace <-
#     projectRaster(f11, crs = "+init=epsg:27700 +units=km")
#   #project the raster to a resolution of 10m per cell
#   Reprojection.laplace <-
#     projectRaster(Projected.laplace,
#                   crs = crs(Projected.laplace),
#                   res = 0.010)
#   #Obtain the frequency of observed values
#   count.laplace <- as.matrix(freq(Reprojection.laplace))
#   laplace.count[[paste0("Threshold level ", i)]] <- count.laplace
#   #print(laplace.count)
# }
#
# tree.laplace <- c()
# for (m in 1:length(laplace.count)) {
#   tree.laplace <-
#     c(tree.laplace, (laplace.count[[m]][(as.numeric(which(laplace.count[[m]] ==
#                                                             0))), 2]))
# }
#
# plot(
#   y = tree.laplace,
#   x = seq.length,
#   type = "o",
#   ylab = "Count of Trees",
#   xlab = "Thresholding Values",
#   main = "Laplace Tree count evolution based on Thresholding ",
#   col = "cornflowerblue"
# )
#===============================================================================Laplacian over bounded threshold
#Different levels of thresholding based on 0.01 increase between 0.1 and 0.6
#100 numbers between 0 and 1
seq.length2 <- seq(0.1, 0.6, 0.001)
laplace.count5 <- list()

for (y in seq.length2) {
  #Reset before thresholding
  hillside <- hill
  #threshold hillside by i
  hillside[hillside > y] <- NA
  na.omit(hillside)
  #Compute sobel kernel and associated focal stats
  laplace <- matrix(c(0, 1, 0, 1,-4, 1, 0, 1, 0), nrow = 3)
  f16    <- focal(hillside, w = laplace, fun = sum)
  #Reproject the computed focal raster
  Projected.laplace5 <-
    projectRaster(f16, crs = "+init=epsg:27700 +units=km")
  #project the raster to a resolution of 10m per cell
  Reprojection.laplace5 <-
    projectRaster(Projected.laplace5,
                  crs = crs(Projected.laplace5),
                  res = 0.010)
  #Obtain the frequency of observed values
  count.laplace5 <- as.matrix(freq(Reprojection.laplace5))
  laplace.count5[[paste0("Threshold level ", y)]] <- count.laplace5
  #print(laplace.count)
}

tree.laplace1 <- c()
for (d in 1:length(laplace.count5)) {
  tree.laplace1 <-
    c(tree.laplace1, (laplace.count5[[d]][(as.numeric(which(laplace.count5[[d]] ==
                                                              0))), 2]))
}

plot(
  y = tree.laplace1,
  x = seq.length2,
  type = "o",
  ylab = "Count of Trees",
  xlab = "Thresholding Values",
  main = "Laplace Tree count evolution based on Thresholding ",
  col = "cornflowerblue"
)

#compute the SE of the simulated distribution
standard.error.laplace <-
  sd(tree.laplace1) / sqrt(length(tree.laplace1))
mean.error.laplace <- mean(tree.laplace1)
#upper and lower normal limits
ul.laplace <- mean.error.laplace + 1.96 * (standard.error.laplace)
ll.laplace <- mean.error.laplace - 1.96 * (standard.error.laplace)
#add lines for bands to the plot y axis
abline(h = mean.error.laplace, col = "black", lty = 1)
abline(h = ul.laplace, col = "red", lty = 2)
abline(h = ll.laplace, col = "red", lty = 2)

#compute a nonparametric bootstrap from the different thresholded counts
#code adapted from:
#https://stats.stackexchange.com/questions/16516/how-can-i-calculate-the-confidence-interval-of-a-mean-in-a-non-normally-distribu

#Take tree counts from different thresholds and laplace application
#2000 resamples, 5% trim

laplace.boot <- one.boot(tree.laplace1, mean, R = 2000, tr = 0.05)
hist(laplace.boot, main = "laplace count bootstrap distribution", col = "cornflowerblue")
laplace.bootstrap <- boot.ci(laplace.boot, type = c("perc", "bca"))
print(laplace.bootstrap)

#Measures of accuracy for zonal stats---------
#Code adapted from:
#https://gis.stackexchange.com/questions/119305/how-to-calculate-and-compare-rmse-between-two-dems
#https://gis.stackexchange.com/questions/4802/rmse-between-two-rasters-step-by-step

#Extract the values from the thresholded rasters at 0.5
hill.error <- getValues(hillside)
f5.error <- getValues(f5)
f10.error <- getValues(f10)

#Sobel at 0.5 threshold (RMSE)
#sqrt(mean(Actual - Predicted)^2)
diff.sobel <- (hill.error - f5.error) ^ 2
avg.sobel <- mean(na.omit(diff.sobel))
#RMSE.sobel <- sqrt(avg.sobel)
print(avg.sobel)

#Sobel at 0.5 threshold (PNSR)
PNSR.sobel <- 10 * log(((0.6910431 ^ 2) / avg.sobel))
print(PNSR.sobel)

#Laplacian at 0.5 threshold (RMSE)
diff.laplace <- (hill.error - f10.error) ^ 2
avg.laplace <- mean(na.omit(diff.laplace))
#RMSE.laplace <- sqrt(avg.laplace)
print(avg.laplace)

#Laplacian at 0.5 Threshold (PNSR)
PNSR.laplace <- 10 * log(((2.675293 ^ 2) / avg.laplace))
print(PNSR.laplace)

#Compute the different index and color composites--------------

#Aggregate Orthophoto by a factor of 45
spec_br1 <- aggregate(spec_rgb, 45, progress = 'text')

names(spec_br1) <- c('Blue', 'Green', 'Red', 'NIR', 'RE')

#Normalized Differentiation Vegetation Index (NDVI)
#Formula sourced from:
##https://www.earthdatascience.org/courses/earth-analytics/multispectral-remote-sensing-data/vegetation-indices-NDVI-in-R/

NIR <- spec_br1[[4]]
Red <- spec_br1[[3]]
Blue <- spec_br1[[1]]

#Compute the NDVI raster
Spec_ndvi <-
  overlay(
    NIR,
    Red,
    fun = function(x, y) {
      (x - y) / (x + y)
    }
  )

#Plot the NDVI
par(mar = c(1, 1, 1, 0.5))
plot(Spec_ndvi, main = "Normalized differentiation vegetation index", box = FALSE)

#Enhanced Vegetation index (EVI)
#Formula sourced from:
#https://cran.r-project.org/web/packages/LSRS/LSRS.pdf

Spec_evi <- overlay(
  NIR,
  Red,
  Blue,
  fun = function(x, y, z) {
    2.5 * ((x - y) / (x + (6 * y) + (7.5 * z) + 1))
  }
)

#Unsupervised machine learning on stacked orthophoto (Kmeans)---------------
#Formula:
#https://medium.com/regen-network/remote-sensing-indices-389153e3d947

#Below code adapted from:
#http://rspatial.org/analysis/rst/9-remotesensing.html
#https://geoscripting-wur.github.io/AdvancedRasterAnalysis/

#Create determinant rasters of the cluster
#benchmark <- stack(Spec_evi, Spec_ndvi, spec_br1[[5]])
benchmark <- stack(Spec_evi, Spec_ndvi)

#==============================================================================Plot all clustering possibilities
kposs <- c()
kpossibilities <- function(num = 10) {
  for (k in 1:num) {
    set.seed(12345)
    kmncluster <-
      kmeans(
        na.omit(benchmark[]),
        centers = k,
        iter.max = 500,
        nstart = 5,
        algorithm = "Lloyd"
      )
    kposs <- c(kposs, kmncluster$tot.withinss)
    kclass <- spec_br1[[1]]
    kclass[] <- kmncluster$cluster
    plot(kclass, main = paste(k, "cluster(s)"))
  }
  return(kposs)
}

totalwss <- kpossibilities()
plot(
  y = totalwss,
  x = seq(1, 10, 1),
  main = "Elbow Method Results",
  type = "o",
  ylab = "Total Within Sum of Squares",
  xlab  = "Number of clusters",
  col = "cornflowerblue"
)
abline(v = 3,
       lty = 2,
       col = "red",
       lwd = 3)
abline(h = 1840.6808,
       lty = 2,
       col = "red",
       lwd = 3)

# nbclustering.avg <-
#   NbClust(
#     data = benchmark[],
#     diss = NULL,
#     distance = "euclidean",
#     min.nc = 2,
#     max.nc = 15,
#     method = "average",
#     index = "cindex",
#     alphaBeale = 0.1
#   )

#============================================================================== Plot desired and create the training data

#Attempt to perform 3 cluster classification based on reduced NDVI image

#Kmeans clustering result
set.seed(12345)
kmncluster <-
  kmeans(
    na.omit(benchmark[]),
    centers = 3,
    iter.max = 500,
    nstart = 5,
    algorithm = "Lloyd"
  )

#Create training polygons and assign to arbitrary raster for visualisation
kclass <- spec_br1[[5]]
kclass[] <- kmncluster$cluster
#plot clustering result
plot(kclass)
freq(kclass)

#Edit the clustered raster details
classes <- kclass
names(classes) <- "Classes"
#plot Thematic raster
par(mar = c(1, 1, 1, 0.5))
plot(classes, main = "Thematic Raster")

#Create training data by isolating unwanted regions/classes through thresholding
#1 and 2 appears to be redundant here
classification <- classes
#plot(classification)
#Clusters less than 6 are omitted
#classification[classification < 6] <- NA
classification[classification > 2] <- NA

plot(classification)

#isolate the predictive bands; bands 1-4
#preds <- stack(spec_br1[[1]],spec_br1[[2]],spec_br1[[3]],spec_br1[[4]])
preds <- spec_br1
#mask predictors with defined classification to obtain training data
covmasked <- mask(preds, classification)
plot(covmasked)
trainlayer <- addLayer(covmasked, classification)
plot(trainlayer)

#Extract the values from training stack
values <- getValues(trainlayer)
valuetable <- na.omit(values)
valuetable <- as.data.frame(valuetable)
#colnames(valuetable)[5] <- "Classes"
valuetable$Classes <- as.factor(valuetable$Classes)
print(unique(valuetable$Classes))

#All band possibilities#####

allband <- stack(spec_br1, Spec_ndvi, Spec_evi)
names(allband) <-
  c('Blue', 'Green', 'Red', 'NIR', 'RE', 'NDVI', 'EVI')

kpossibilities1 <- function(num = 10) {
  for (k in 1:num) {
    set.seed(12345)
    kmncluster <-
      kmeans(
        na.omit(allband[]),
        centers = k,
        iter.max = 500,
        nstart = 5,
        algorithm = "Lloyd"
      )

    kclass <- spec_br1[[1]]
    kclass[] <- kmncluster$cluster
    plot(kclass, main = paste(k, "cluster(s)"))
  }
}

kpossibilities1()

#Graph the valuetable based on the associated classes####
#Plot the different bands across the classes####
band.clust <- function(cluster) {
  par(mfrow = c(2, 3))
  val_class <- subset(valuetable, Classes == cluster)
  for (p in 1:5) {
    hist(
      val_class[[p]],
      main = c(paste(
        "Cluster",
        paste(cluster),
        colnames(val_class)[p],
        " Band distrbution"
      )),
      col = "cornflowerblue",
      xlab = c(paste(colnames(val_class)[p]), " values")
    )
  }
}

for (v in 6:7) {
  band.clust(v)
}

dev.off()

#Compute a tree count using kmeans-------------

classification <- classes

Projected.kmeans <-
  projectRaster(classification, crs = "+init=epsg:27700 +units=km", res = 0.010)

plot(Projected.kmeans, main = "kmeans projected raster")

freq(Projected.kmeans)

#Supervised machine learning on stacked orthophoto (RandomForest)---------------
#below code adapted from:
##https://geoscripting-wur.github.io/AdvancedRasterAnalysis/

tune <- tuneRF(x = valuetable[, c(1:5)],
               y = valuetable$Classes)
#plot OOB error
plot(
  tune,
  type = "o",
  main = "RF Tuning result",
  ylab = "OOB Error percentage",
  xlab = "Number of variables randomly sampled at each split",
  col = "cornflowerblue"
)

set.seed(12345)
#Fit the Random forest model
modelRF.final <-
  randomForest(
    x = valuetable[, c(1:5)],
    y = valuetable$Classes,
    mtry = 4,
    importance = TRUE
  )

#variable importance plot
varimp <- varImpPlot(modelRF.final)

#Predict tree cover on predictors (insample prediction)
predTree <- predict(preds, model = modelRF.final)

#plot predicted raster
par(mar = c(1, 1, 1, 0.5))
plot(predTree, main = "Random Forest Predicted Raster")

#Plot classes is one for tree and zero for notree
#Reproject ther raster
Projected.pred <-
  projectRaster(predTree, crs = "+init=epsg:27700 +units=km")

#project the raster to a resolution of 10m per cell
Reprojection.pred <-
  projectRaster(Projected.pred,
                crs = crs(Projected.pred),
                res = 0.010)
plot(Reprojection.pred)
#Threshold the reprojection for the count of trees (Based on color from legend)
Thresholded <- Reprojection.pred
RFcount <- freq(Thresholded)
print(RFcount)

#Edit confusion matrix for better interpretation - from computed RF model
colnames(modelRF.final$confusion) <-
  c("Trees", "Non-Trees", "class Error")
rownames(modelRF.final$confusion) <- c("Trees", "Non-Trees")
modelRF.final$confusion

#Plot sample tree from random forest
#(getTree(modelRF.final,4, labelVar = TRUE))

#below code adapted from:
#https://stackoverflow.com/questions/30366143/how-to-compute-roc-and-auc-under-roc-after-training-using-caret-in-r

#Compute the accuracy metrics
predictions <-
  as.vector(modelRF.final$votes[, 2]) # Random forest output
predictions.auc <- prediction(predictions, valuetable$Classes)
#AUC
auc.performance <- performance(predictions.auc, "auc")
#ROC
roc.performance <- performance(predictions.auc, "tpr", "fpr")
#plot the ROC
#below code adapted from:
#https://chandramanitiwary.wordpress.com/2014/03/17/r-tips-part2-rocr-example-with-randomforest/

plot(roc.performance,
     main = "ROC curve for Fitted Random Forest",
     col = "cornflowerblue",
     lwd = 2,
     xlab = "Specificity",
     ylab = "Sensitivity")
abline(
  a = 0,
  b = 1,
  lwd = 2,
  lty = 2,
  col = "gray"
)

#AUC detailed stats
auc <- unlist(slot(auc.performance, "y.values"))
#Compute min and max values
minauc <- min(round(auc, digits = 2))
maxauc <- max(round(auc, digits = 2))
minauct <- paste(c("min(AUC) = "), minauc, sep = "")
maxauct <- paste(c("max(AUC) = "), maxauc, sep = "")

#Threshold definition adapted from:
#https://stackoverflow.com/questions/16347507/obtaining-threshold-values-from-a-roc-curve
cutoffs <- data.frame(cut=roc.performance @alpha.values[[1]], fpr=roc.performance @x.values[[1]],
                      tpr=roc.performance @y.values[[1]])
head(cutoffs)
#order cutoffs
cutoffs <- cutoffs[order(cutoffs$tpr, decreasing=TRUE),]

#####################################################################10% threshold

set.seed(12345)
#Fit the Random forest model
modelRF.final <-
  randomForest(
    x = valuetable[, c(1:5)],
    y = valuetable$Classes,
    mtry = 4,
    importance = TRUE,
    cutoff = c(0.9,0.1)
  )

#variable importance plot
varimp <- varImpPlot(modelRF.final)

#Predict tree cover on predictors (insample prediction)
predTree <- predict(preds, model = modelRF.final)

#plot predicted raster
par(mar = c(1, 1, 1, 0.5))
plot(predTree, main = "Random Forest Predicted Raster")

#Plot classes is one for tree and zero for notree
#Reproject ther raster
Projected.pred <-
  projectRaster(predTree, crs = "+init=epsg:27700 +units=km")

#project the raster to a resolution of 10m per cell
Reprojection.pred <-
  projectRaster(Projected.pred,
                crs = crs(Projected.pred),
                res = 0.010)
plot(Reprojection.pred)
#Threshold the reprojection for the count of trees (Based on color from legend)
Thresholded <- Reprojection.pred
RFcount <- freq(Thresholded)
print(RFcount)

#Edit confusion matrix for better interpretation - from computed RF model
colnames(modelRF.final$confusion) <-
  c("Trees", "Non-Trees", "class Error")
rownames(modelRF.final$confusion) <- c("Trees", "Non-Trees")
modelRF.final$confusion

#Plot sample tree from random forest
#(getTree(modelRF.final,4, labelVar = TRUE))

#below code adapted from:
#https://stackoverflow.com/questions/30366143/how-to-compute-roc-and-auc-under-roc-after-training-using-caret-in-r

#Compute the accuracy metrics
predictions <-
  as.vector(modelRF.final$votes[, 2]) # Random forest output
predictions.auc <- prediction(predictions, valuetable$Classes)
#AUC
auc.performance <- performance(predictions.auc, "auc")
#ROC
roc.performance <- performance(predictions.auc, "tpr", "fpr")
#plot the ROC
#below code adapted from:
#https://chandramanitiwary.wordpress.com/2014/03/17/r-tips-part2-rocr-example-with-randomforest/

plot(roc.performance,
     main = "ROC curve for Fitted Random Forest",
     col = "cornflowerblue",
     lwd = 2,
     xlab = "Specificity",
     ylab = "Sensitivity")
abline(
  a = 0,
  b = 1,
  lwd = 2,
  lty = 2,
  col = "gray"
)

#AUC detailed stats
auc <- unlist(slot(auc.performance, "y.values"))
#Compute min and max values
minauc <- min(round(auc, digits = 2))
maxauc <- max(round(auc, digits = 2))
minauct <- paste(c("min(AUC) = "), minauc, sep = "")
maxauct <- paste(c("max(AUC) = "), maxauc, sep = "")

#Threshold definition adapted from:
#https://stackoverflow.com/questions/16347507/obtaining-threshold-values-from-a-roc-curve
cutoffs <- data.frame(cut=roc.performance @alpha.values[[1]], fpr=roc.performance @x.values[[1]],
                      tpr=roc.performance @y.values[[1]])
head(cutoffs)
#order cutoffs
cutoffs <- cutoffs[order(cutoffs$tpr, decreasing=TRUE),]


#' Clean
#'
#' Delete all '*.RData' files with given basename.
#' Can be used to clean the saved observation and baseline matrices.
#' Use with caution.
#'
#' @param basename A \code{character} string.
#' @return None
#' @examples
#' Clean("33.0_observation_matrix_tmp")
#' Clean("observation_matrix_tmp")
Clean<-function(basename){
  list_files = list.files('Data',pattern = paste0(basename, '.RData'))
  for (file in list_files){
    file.remove(file.path("Data", file))
  }
}

#' CreateObservationMatrices
#'
#' Compute 2D Sparse matrices enconding observations recorded in \code{case.df}.
#' Rows are locations (indexed by postcodes) and columns are time steps.
#' If a \code{character} vector of length N is passed as argument \code{types}, then N
#' matrices are created only for the events with matching \code{case.df$types}.
#' The matrices are saved on disk as '*observation_matrix.RData' files.
#'
#' @param case.df A \code{data.frame} of events.
#' @param types \code{NULL} or a \code{character} vector.
#' @param date.time.field A \code{character} string.
#' @param postcode.field A \code{character} string.
#' @param more.postcodes A \code{character} vector
#' @param more.weeks A \code{integer} vector
#' @return None
#' @importFrom Matrix sparseMatrix
#' @examples
#' CreateObservationMatrices(case.df)
#' CreateObservationMatrices(case.df, types=c("1.0", "33.0"), date.time.field = "SAMPLE_DT_numeric", postcode.field = "Patient Postcode")
CreateObservationMatrices<-function(case.df, types=NULL, date.time.field = 'week', postcode.field = 'postcode',
  more.postcodes=c(), more.weeks=c()){

  if (length(more.postcodes) > 0){
    postcodes = sort(unique(c(unlist(case.df[,postcode.field]), unlist(more.postcodes))))
    postcodes = sort(postcodes)
  }else{
    postcodes = sort(unique(case.df[,postcode.field]))
  }
  n.postcodes = length(postcodes)

  if (is.null(types)){
    n.types = 1
  }else{
    n.types = length(types)
  }

  maxim = max(c(case.df[,date.time.field], unlist(as.integer(more.weeks))), na.rm = T)
  minim = min(c(case.df[,date.time.field], unlist(as.integer(more.weeks))), na.rm = T)

  n.weeks = maxim - minim + 1
  for (e in 1:n.types){
    if (!is.null(types)){
      type=types[e]
      cat("Step", e, "of", n.types, ", creating observation matrix for", type, "type\n")
      idx = case.df$type == type
      case.df = case.df[idx,] ## BUG here do not overwrite case.df
    }
    observation.matrix = as(matrix(data=0,
                                   nrow=n.postcodes,
                                   ncol=n.weeks + 1,
                                   dimnames=list(postcodes,
                                                 c('NA', as.character(minim:maxim)) )), "sparseMatrix")
    # the dimensions correspond to postcode, type, time
    for (i in 1:nrow(case.df)){
      postcode = case.df[i, postcode.field]
      week = case.df[i, date.time.field]
      if (is.na(week)){
        week = 'NA'
      }
      observation.matrix[postcode, as.character(week)] = observation.matrix[postcode, as.character(week)] + 1
    }
    attribute_list = attributes(observation.matrix)
    if (is.null(types)){
      attribute_list$type = NA
    }else{
      attribute_list$type = type
    }
    attribute_list$date.time.field = date.time.field
    attributes(observation.matrix)<-attribute_list

    if (!is.null(types)){
      save.and.tell("observation.matrix",
                  file = file.path(getwd(), paste0(type, '_observation_matrix.RData')))
    }else{
      save.and.tell("observation.matrix",
                  file = file.path(getwd(), 'observation_matrix.RData'))
    }
  }
}

#' Map postcodes to coordinates
#
#' Returns and save 'postcode2coord.RData' a data frame that maps the postcodes included in \code{rownames(matrix)} to geographical coordinates.
#' \code{matrix} can be a \code{Matrix} or a \code{sparseMatrix} object storing baseline or observation data.
#' Requires the all postcode data tabulated in a \code{data.frame} called \code{postcode.data} available in the workspace.
#'
#' @param matrix A \code{Matrix} or \code{sparseMatrix}.
#' @return A \code{data.frame}.
#' @examples
#' postcode2coord = PostcodeMap(observation.matrix)
PostcodeMap<-function(matrix, postcode.field = 'postcode'){
  writeLines("Compiling the table that maps the rows of the observation/baseline matrix to geo-coordinates and population.")
  ret<-tryCatch({
    load("postcode2coord.RData", verbose = 1)
    if (all(as.character(postcode2coord[, postcode.field]) == rownames(matrix))){
      writeLines("Using data loaded from `postcode2coord.RData`")
      postcode2coord
    }else{
      writeLines("Data loaded from `postcode2coord.RData` is for a different matrix and will be overwritten by the map for the current matrix.")
      stop() #raise error
    }
  },
  error = function(e){
    postcode2coord = data.frame(postcode.field = rownames(matrix))
    names(postcode2coord) = postcode.field

    postcode2coord$index = 1:NROW(matrix)
    postcode2coord['key'] = c(sapply(postcode2coord[postcode.field],
                                     function(x){gsub(" ", "", toupper(x),  fixed = TRUE)}))

    # Insert coordinates and population density
    # postcode.data is a data.frame to load.
    data("population_per_postcode_with_coordinates")
    postcode.data['key'] = c(sapply(postcode.data['postcode'],
                                    function(x){gsub(" ", "", toupper(x),  fixed = TRUE)}))

    postcode.data[postcode.field] = NULL

    postcode2coord = merge(postcode2coord, postcode.data, by='key', all.x=T, all.y=F, sort=F)
    postcode2coord = postcode2coord[order(postcode2coord$index),]

    idx = is.na(postcode2coord$latitude)
    if(any(idx)){
      cat("Retrieving coordinates from api.getthedata for", sum(idx), "postcodes.\n")
      TTT=Sys.time()
      postcode2coord[idx, c("latitude", "longitude", "Total")] = t(apply(postcode2coord[idx,], 1,
                                                                         postcode.to.location.and.population,
                                                                         postcode.data, postcode.field = 'key'))
      print(Sys.time() - TTT)
    }

    postcode2coord['key'] = NULL
    save.and.tell('postcode2coord', file=file.path(getwd(),
                                                   paste0("postcode2coord.RData")))

    return(postcode2coord)
  }
  )
  return(ret)
}

#' Find temporal component of the baseline
#'
#' Returns a vector representing the temporal component of the baseline. This is obtained by calling
#' \code{cmle} and \code{predict.cmle}, which fit a seasonal trend model to aggregated data and return its best estimate, respectively.
#'
#' @param case.df A \code{data.frame} containing the events.
#' @param save.on.dir \code{logical}. If TRUE then the vector is saved in `timefactor.RData` file.
#' @param get.from.dir \code{logical}. If TRUE then the vector is obtained from the `timefactor.RData` file.
#' @param date.time.field A \code{character} string.
#' @param start \code{numeric}. Starting parameters (not yet implemented).
#' @param n.iterations An \code{integer}.
#' @return A \code{numeric} vector.
#' @examples
#' time.factor = TimeFactor(case.df)
TimeFactor<-function(case.df, save.on.dir = TRUE, get.from.dir = FALSE,
                     date.time.field = "week", start = NULL, n.iterations=20){
  time.factor<-tryCatch({
    if(get.from.dir == FALSE){
      stop("Not loading from local directory.")
    }
    load(file.path(getwd(), paste0('timefactor.RData')))
    cat("Temporal baseline loaded.\n")
    time.factor
  },
  error = function(e){
    cat("Computing the temporal baseline.\n")
    Parameters = cmle(case.df[,date.time.field], n.iterations, start)
    maxim = max(case.df[,date.time.field], na.rm = T)
    minim = min(case.df[,date.time.field], na.rm = T)
    n.weeks = maxim - minim + 1
    x = minim:maxim

    prediction.cmle = predict.cmle(x, Parameters)

    na = sum(is.na(case.df[,date.time.field]))

    time.factor = c(na, prediction.cmle)
    names(time.factor) = c('NA', x)
    attr=attributes(time.factor)
    attr$Parameters = Parameters
    attributes(time.factor) = attr
    if(save.on.dir){
      save.and.tell('time.factor', file=file.path(getwd(), paste0('timefactor.RData')))
    }
    return(time.factor)
  })
  return(time.factor)
}

EmmtypeFactor<-function(case.file){
  load(paste0(case.file, ".RData"))
  emmtype.factor = c(table(case.df$emmtype))
  emmtype.factor = emmtype.factor/ sum(emmtype.factor)
  xy.list=list()
  for (i in 1:length(emmtype.factor)) {
    xy.list[[i]]=emmtype.factor[i]
  }
  xy.list = setNames(xy.list, names(emmtype.factor))
  return(xy.list)
}

EmmtypeFactor.tau<-function(case.file, emmtypes, date.time.field = 'SAMPLE_DT_numeric'){
  load(paste0(case.file, ".RData"))
  n.weeks = max(case.df[,date.time.field], na.rm = T) - min(case.df[,date.time.field], na.rm = T) + 1

  xy.list=list()

  for (emmtype in emmtypes) {
    tmp = vector(mode = 'numeric', length=n.weeks)
    for (tau in 1:n.weeks){
      idx = (case.df$SAMPLE_DT_numeric <= tau) & (case.df$emmtype == emmtype)
      idx.tau = case.df$SAMPLE_DT_numeric <= tau
      tmp[tau] = sum(idx) / sum(idx.tau)
    }
    names(tmp) = as.character(1:n.weeks)
    xy.list[[emmtype]]=tmp
  }

  return(xy.list)
}

#' At a given week, a fraction lambda_untyped \approx 0.6 of all cases are not typed.
#' the baselines e.g. are as follows:
#' - for the emmtype 33.0: (1-lambda_untyped) * lambda_33.0 * lambda_t * lambda_geo
#' - for the entyped: lambda_untyped * lambda_t * lambda_geo
#'
EmmtypeFactor.delay_<-function(case.file, starting.week, n.weeks){
  if (starting.week < n.weeks){
    starting.week = n.weeks
    cat(sprintf("We enforced `starting.week=n.week=%d`", n.weeks), ".\n")
  }
  load(paste0(case.file, ".RData"))
  #n.weeks = max(case.df$SAMPLE_DT_numeric[!is.na(case.df$SAMPLE_DT_numeric)]) - min(case.df$SAMPLE_DT_numeric[!is.na(case.df$SAMPLE_DT_numeric)]) + 1
  MAX = max(case.df$SAMPLE_DT_numeric, na.rm = T)
  # MIN = min(case.df$SAMPLE_DT_numeric[!is.na(case.df$SAMPLE_DT_numeric)])
  # n.weeks=MAX-MIN+1
  # tmp = vector(mode = 'numeric', length=n.weeks)
  tmp = rep(0, n.weeks)
  # len = NROW(case.df)
  # case.df = case.df[case.df$SAMPLE_DT_numeric <= case.df$RECEPT_DT_numeric,]
  for(w in starting.week:MAX){
    for (i in 1:n.weeks){
      week = w - n.weeks + i
      idx1 = case.df$SAMPLE_DT_numeric == week
      idx2 = case.df$RECEPT_DT_numeric > w
      tmp[i] = tmp[i] + sum(idx1 & idx2) / sum(idx1)
    }
  }
  tmp = tmp / length(starting.week:MAX) # (MAX - starting.week + 1)
  # cum.tmp = cumsum(tmp) / 1:length(tmp)
  # for (i in 1:n.weeks){
  #   if (is.na(cum.tmp[i])){
  #     cum.tmp[i] = cum.tmp[i-1]
  #   }
  # }
  # names(cum.tmp) = as.character(1:n.weeks)
  return(tmp)
}

#' Create and save a baseline matrix
#'
#' Compute and save on disk a 2D dense matrix representing the
#' baseline, given a \code{data.frame} of events (\code{case.df}), where  rows represent the spatial component of the baseline
#' (indexed, e.g., by postcodes) and columns represent the temporal component.
#' It is possible to insert null rows corresponding to postcodes not included in \code{case.df} using \code{more.postcodes} field
#' for increased accuracy.
#'
#' @param case.df A \code{data.frame} of events.
#' @param save.on.dir \code{logical}. If TRUE then the vector is saved in `baseline_matrix.RData` file.
#' @param date.time.field A \code{character} string.
#' @param postcode.field A \code{character} string.
#' @param more.postcodes A \code{character} vector of postcodes.
#' @param more.weeks A \code{integer} vector of postcodes.
#' @return A \code{Matrix}.
#' @examples
#' baseline.matrix = CreateBaselineMatrix(case.df, more.postcodes=c('CV31 1LS', 'E1 3BS'))
#' baseline.matrix = CreateBaselineMatrix(case.df, date.time.field = 'SAMPLE_DT_numeric', postcode.field = 'Patient Postcode')
CreateBaselineMatrix<-function(case.df, save.on.dir=FALSE,
                               date.time.field='week', postcode.field='postcode',
                               more.postcodes=c(), more.weeks=c()){

  if (length(more.postcodes) > 0){
    postcodes = sort(unique(c(unlist(case.df[,postcode.field]), unlist(more.postcodes))))
  }else{
    postcodes = sort(unique(case.df[,postcode.field]))
  }

  n.postcodes= length(postcodes)
  maxim = max(c(case.df[,date.time.field], unlist(as.integer(more.weeks))), na.rm = T)
  minim = min(c(case.df[,date.time.field], unlist(as.integer(more.weeks))), na.rm = T)
  n.weeks = maxim - minim + 1

  baseline.matrix = matrix(data=0,
                           nrow = n.postcodes,
                           ncol = n.weeks + 1,
                           dimnames=list(postcodes, c('NA', as.character(minim:maxim))))

  time.factor = TimeFactor(case.df, save.on.dir, get.from.dir = TRUE, date.time.field = date.time.field)
  spatial.factor = PostcodeMap(matrix(data=0,
                                      nrow = n.postcodes,
                                      ncol = n.weeks + 1,
                                      dimnames=list(postcodes, c('NA', as.character(minim:maxim)) )))$Total

  for(j in 1:ncol(baseline.matrix)){
    for(i in 1:nrow(baseline.matrix)){
      baseline.matrix[i,j] = time.factor[j] * spatial.factor[i]
    }
  }
  baseline.matrix = baseline.matrix / sum(spatial.factor, na.rm = T)

  attribute_list = attributes(baseline.matrix)
  attribute_list$date.time.field = date.time.field
  attributes(baseline.matrix)<-attribute_list

  if(save.on.dir){
    save.and.tell("baseline.matrix", file=file.path(getwd(), paste0('baseline_matrix.RData')))
  }
  return(baseline.matrix)
}

#' Simulate an observation matrix
#'
#' Given  vectors of length M and N, representing spatial
#' and temporal factors (e.g., population density per location and sesonal trends, respectively),
#' this function computes a MxN baseline matrix and simulate a Poisson point process.
#'
#' @param population A \code{numeric} vector.
#' @param time.factor \code{numeric} vector.
#' @param total.average A \code{numeric}.
#' @param  save.baseline.matrix A \code{logical}.
#' @param n.unknown.time A \code{numeric}. Represents the baseline for cases that have unknown date report.
#' @return A \code{sparseMatrix} observation matrix.
#' @importFrom Matrix sparseMatrix
#' @examples
#' sim = Simulate(spatial.factor, time.factor, total.average)
Simulate<-function(population, time.factor, total.average, save.baseline.matrix=F, n.unknown.time=0){
  baseline.matrix = population %o% time.factor
  baseline.matrix = baseline.matrix / sum(baseline.matrix) * total.average
  # colnames(baseline.matrix) = c("NA", as.character(names(time.factor)))

  flatten.baseline.matrix = c(baseline.matrix)
  n.col = ncol(baseline.matrix)
  simulation = rpois(length(flatten.baseline.matrix), lambda=flatten.baseline.matrix)
  simulation = matrix(simulation, ncol=n.col)
  rownames(simulation) = as.character(names(population))
  colnames(simulation) = as.character(names(time.factor))
  simulation = as(simulation, 'sparseMatrix')
  if(save.baseline.matrix){
    attribute_list = attributes(simulation)
    attribute_list$baseline.matrix = baseline.matrix
    attributes(simulation)<-attribute_list
  }
  return(simulation)
}

# this function estimates the prevalence of an emm type.
# According to wikipedia, the duration of treatment is around 10 days
# This suggested that an individual stays infected for around 10 days.
# Given the number of reports in a week (incidence), we model the fraction of active cases
# using weighting each reported cases with an decaying exponential with rate d=1/2 weeks
#
EmmtypeFactor.tau2<-function(case.file, emmtypes, d=1/2, date.time.field = 'SAMPLE_DT_numeric'){
  # According to wikipedia, the duration of treatment is around 10 days
  # This suggested that an individual stays infected for is the decay rate of infected people.
  load(paste0(case.file, ".Rdata"))

  max.week = max(case.df[,date.time.field][!is.na(case.df[,date.time.field])])
  min.week = min(case.df[,date.time.field][!is.na(case.df[,date.time.field])])
  n.weeks = max.week - min.week + 1

  xy.list=list()
  tmp = vector(mode = 'numeric', length=n.weeks)
  for (tau in min.week:max.week){
    idx = case.df[,date.time.field] <= tau
    if(any(idx)){
      value = sum(
        # truncnorm::dtruncnorm(case.df[idx,date.time.field], mean=tau, sd=d, b=tau)
        dexp(-(case.df[idx,date.time.field] - tau), rate=d)
      )
    }else{
      value=1
    }

    id = tau - min.week + 1
    tmp[id] = value
  }
  for (emmtype in emmtypes){
    tmp2 = vector(mode = 'numeric', length=n.weeks)
    for (tau in min.week:max.week){
      idx = (case.df[,date.time.field] <= tau) & (case.df$emmtype == emmtype)
      if(any(idx)){
        value = sum(
          # truncnorm::dtruncnorm(case.df[idx,date.time.field], mean=tau, sd=sd, b=tau)
          dexp(-(case.df[idx,date.time.field] - tau), rate=d)
        )
      }else{
        value = 0
      }
      id = tau - min.week + 1
      tmp2[id] = value
    }
    names(tmp2) = as.character(min.week:max.week)
    xy.list[[emmtype]] = tmp2 / tmp
    attributes(xy.list)$total = tmp
  }
  return(xy.list)
}