# 3. faza: Vizualizacija podatkov

library(ggplot2)
library(dplyr)
library(readr)
library(tibble)

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

# Uvozimo zemljevid.

evropa <- uvozi.zemljevid("http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/50m/cultural/ne_50m_admin_0_countries.zip",
                          "ne_50m_admin_0_countries", encoding = "UTF-8") %>%
  pretvori.zemljevid() %>% filter(continent == "Europe" | sovereignt %in% c("Turkey", "Cyprus"),
                                  long > -30, sovereignt != "Russia")

#prikaz praznega zemljevida

ggplot() + geom_polygon(data = evropa, aes(x = long, y = lat, group = group)) + coord_map(xlim = c(-25, 45), ylim = c(32, 72))

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

#prikaz števila gostov na zemljevidu
## poračun prenočitev v državi

tabela2$drzava <- gsub("Germany.*$", "Germany", tabela2$drzava)
evropa$name_sort <- gsub("^Slovak Republic$", "Slovakia", evropa$name_sort) %>% factor()

nocitve <- tabela2 %>% group_by(drzava, leto) %>%
  summarise(noc = sum(stevilo_gostov)) %>%
  group_by(drzava) %>% summarise(noc = mean(noc, na.rm = TRUE))

evropa$name_sort <- gsub("^Slovak Republic$", "Slovakia", evropa$name_sort) %>% factor() #zemljevid

#prikaz zemljevida

zemljevid <- ggplot() + geom_polygon(data = left_join(evropa, nocitve, by = c("name_sort" = "drzava")),
                             aes(x = long, y = lat, group = group, fill = noc/1e6)) +
  coord_map(xlim = c(-25, 40), ylim = c(32, 72)) +
  guides(fill = guide_colorbar(title = "Nočitve (milijoni)")) +
  xlab("") + ylab("")

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

#prikaz zaposljenih v turizmu v 10 najbolj obiskanih državah v letih - črtni

slovar2 <- c(
  "France" = "Francija",
  "Italy" = "Italija",
  "Spain" = "Španija",
  "Germany" = "Nemčija",
  "Austria" = "Avstrija",
  "United Kingdom" = "Velika Brtanija",
  "Netherlands" = "Nizozemska",
  "Croatia" = "Hrvaška",
  "Greece" = "Grčija",
  "Poland" = "Poljska",
  "drzava" = "Država"
)

g2 = ggplot(tabela3 %>% filter(drzava %in% c("France", "Italy", "Spain", "Germany", "Austria", "United Kingdom", "Netherlands","Croatia","Greece","Poland")) %>%
              group_by(leto, drzava) %>%
              summarise(zaposleni = sum(stevilo_zaposlenih, na.rm = TRUE)),
           aes(x = leto, y = zaposleni, color = slovar2[drzava])) + geom_line() +
          guides(color = guide_legend(title = "Država"))

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

#število zaposljenih po starostnih skupinah skozi leta - črtni

slovar3 <- c(
  "From 15 to 24 years" = "15-24 let",
  "From 25 to 34 years" = "25-34 let",
  "From 35 to 44 years" = "35-44 let",
  "From 45 to 54 years" = "45-54 let"
)

g3 = ggplot(tabela3 %>%
              group_by(leto, starost_delavcev) %>%
              summarise(zaposleni = sum(stevilo_zaposlenih, na.rm = TRUE)),
            aes(x = leto, y = zaposleni, color = slovar3[starost_delavcev])) + geom_line() +
  guides(color = guide_legend(title = "Starost"))

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

# število zaposljenih v evropi v posamezni panogi turizma v letu 2015 - stolpični

slovar4 <- c(
  "Accommodation" = "Nastanitev",
  "Accommodation and food service activities" = "Hrana in nastanitev",
  "Air transport" = "Zračni prevoz",
  "Travel agency, tour operator reservation service and related activities" = "Turistične storitve"
)

g4 = ggplot(tabela3 %>% filter(leto %in% c("2015"))%>%
               group_by(panoga_turizma) %>%
               summarise(zaposleni = sum(stevilo_zaposlenih, na.rm = TRUE)),
             aes(x = slovar4[panoga_turizma], y = zaposleni)) + geom_col() +
  theme(axis.text.x = element_text(angle = 0, hjust = 0.5))

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

#število nstanitev v različnih območjih po evropi - primerjava domačini in tujci - stolpični

slovar5 <- c(
  "Camping grounds, recreational vehicle parks and trailer parks" = "Kampiranje",
  "Holiday and other short-stay accommodation" = "Počitnice",
  "Hotels and similar accommodation" = "Hoteli",
  "Total nights spent by non-residents" = "Tujci",
  "Total nights spent by residents" = "Domačini")

domacini_tujci <- tabela2 %>%
  filter(vrsta_nocitve %in% c("Hotels and similar accommodation", "Holiday and other short-stay accommodation", "Camping grounds, recreational vehicle parks and trailer parks"))%>%
group_by(vrsta_nocitve, domacini_tujci) %>%
  summarise(gosti = sum(stevilo_gostov, na.rm = TRUE))

g5 = ggplot(domacini_tujci, aes(x = slovar5[vrsta_nocitve], y = gosti / 1e9, fill = slovar5[domacini_tujci])) + geom_bar(stat = "identity", position = "dodge") +
  theme(axis.text.x = element_text(angle = 0, hjust = 0.5)) + labs(x="Vrsta nočitve", y="število gostov") +
  guides(fill = guide_legend(title = "Tip gostov"))


gg_color_hue <- function(n) {
  hues = seq(15, 375, length = n + 1)
  hcl(h = hues, l = 65, c = 100)[1:n]
}


#Importar dataset
#dataset = read.csv("..\datasets\Part 1 - Data Preprocessing\Section 2 -------------------- Part 1 - Data Preprocessing --------------------\Data.csv")
dataset = read.csv("Data.csv")
dataset = dataset[,2:3]

##Dividir en entrenamiento y Test

#install.packages("caTools")
library(caTools)

set.seed(123)
split = sample.split(dataset$Purchased,SplitRatio = 0.8)
training_set = subset(dataset,split==TRUE)
testing_set = subset(dataset,split==FALSE)

#Escalado de valores
# training_set[,2:3] = scale(training_set[,2:3])
# testing_set[,2:3] = scale(testing_set[,2:3])


# Create a list
# Allows the user the gather a range of objects within a list

# Vector with numerics from 1 up to 10
my_vector <- 1:10

# Matrix with numerics from 1 up to 9
my_matrix <- matrix(1:9, ncol = 3)

# First 10 elements of the built-in data frame mtcars
my_df <- mtcars[1:10,]

# Construct list with these different elements:
my_list <- list(my_vector, my_matrix, my_df)


##### Code for estimating country specific effective reproduction number with different methods  ####
#####  parts of the code reutilizes already partly written code by othe researcrhes, the sources for these are:
#####https://www.datacamp.com/community/tutorials/replicating-in-r-covid19
##### https://www.r-bloggers.com/effective-reproduction-number-estimation/
#####
######
######
#####

### instructions to run the code  ####
### 1. set the homedirectory in your computer where to save the results
##   ADD HOMEDIRECTORY, for example "c:/DATA/COVID/RESULTS_CALCULATION"
Homedir<-"ADD DIRECTORY TO SAVE RESULTS HERE"

### 2. Uncomment the package installations if they are not installed

# install.packages("purrr")
# install.packages("knitr")
#install.packages("kableExtra")
# install.packages("viridis")
# install.packages("accelerometry")
# install.packages("tidyverse")
# install.packages("R0")
#install.packages("IRdisplay")
#install.packages("smoother")
#install.packages("HDInterval")

####### 3.   Specify the country the analysis should be performed for   #####
Country_Name<-"France"

##### 4.  Specify the date the analysis should start
starting_date <- "2020-03-22"

### 5. Execute all the code, outputs will be saved in the homedirectory as a csv file with name "Reproduction_number_estimates.csv"

#### Possible errors    #####
##### some error messages are displayed during the analysis, these are no real errors but mostly messages from different
##### estimation tools on assumptions taken or if some parts of the analysis takes longer than expected
##### only if the analysis stops and it not finished there can be an error. This error is due to the country specific data
##### this can either depend tht the starting date is taken too early, some methods do not work in this situation. Other possibility
#### is that in some countries zero cases can be reported for a longer timeperiod.
############################

suppressPackageStartupMessages(library(purrr))
suppressPackageStartupMessages(library(knitr))
suppressPackageStartupMessages(library(kableExtra))
suppressPackageStartupMessages(library(viridis))
suppressPackageStartupMessages(library(accelerometry))
suppressPackageStartupMessages(library(tidyverse))
suppressPackageStartupMessages(library(IRdisplay))
suppressPackageStartupMessages(library(smoother))
suppressPackageStartupMessages(library(HDInterval))

starting_date <- "2020-03-22"
Country_Name<-"France"

### Set up distribution on generation time
GT_pmf <- structure( c(0, 0.1, 0.1, 0.2, 0.2, 0.2, 0.1, 0.1), names=0:7)
GT_obj <- R0::generation.time("empirical", val=GT_pmf)

GT_obj<-R0::generation.time("gamma", c(6.6, 1.5))

Homedir<-"H:/COVID/R0_technical_paper/Graphs_test"

## Read in ECDC data   ##
data_ECDC <- read.csv("https://opendata.ecdc.europa.eu/covid19/casedistribution/csv", na.strings = "", fileEncoding = "UTF-8-BOM")

#####  Define functions to calculate effective reproduction number #######

####### Functions to use for effective reproduction number calculations   #######

##### Kevin systrom method   ########

est_rt_Systrom <- function(covid_cases, state_selected) {

  R_T_MAX = 12
  r_t_range = seq(0, R_T_MAX, length = R_T_MAX*100 + 1)
  GAMMA = 1/7

  #' Compute new cases and smooth them
  smooth_new_cases_1 <- function(cases){
    cases %>%
      arrange(date) %>%
      mutate(new_cases = c(cases[1], diff(cases))) %>%
      mutate(new_cases_smooth = round(
        smoother::smth.gaussian(new_cases, window = 7, alpha=7/4, tails = FALSE)
      )) %>%
      select(state, date, new_cases, new_cases_smooth)
  }

  #' Start using data first when smoothed value is above 25
  smooth_new_cases_25 <- function(x){
    start_index <- which(x$new_cases_smooth > 25)[1]
    length_vector <-dim(x)[1]
    return(x[start_index:length_vector,])
  }

  compute_likelihood <- function(cases){
    likelihood <- cases %>%
      filter(new_cases_smooth > 0) %>%
      mutate(
        r_t = list(r_t_range),
        lambda = map(lag(new_cases_smooth, 1), ~ .x * exp(GAMMA * (r_t_range - 1))),
        likelihood_r_t = map2(new_cases_smooth, lambda, dpois, log = TRUE)
      ) %>%
      slice(-1) %>%
      select(-lambda) %>%
      unnest(c(likelihood_r_t, r_t))
  }

  compute_posterior <- function(likelihood){
    likelihood %>%
      arrange(date) %>%
      group_by(r_t) %>%
      mutate(posterior = exp(
        zoo::rollapplyr(likelihood_r_t, 7, sum, partial = TRUE)
      )) %>%
      group_by(date) %>%
      mutate(posterior = posterior / sum(posterior, na.rm = TRUE)) %>%
      # HACK: NaNs in the posterior create issues later on. So we remove them.
      mutate(posterior = ifelse(is.nan(posterior), 0, posterior)) %>%
      ungroup() %>%
      select(-likelihood_r_t)
  }

  # Estimate R_t and a 95% highest-density interval around it
  estimate_rt <- function(posteriors){
    posteriors %>%
      group_by(state, date) %>%
      summarize(
        r_t_simulated = list(sample(r_t_range, 10000, replace = TRUE, prob = posterior)),
        r_t_most_likely = r_t_range[which.max(posterior)]
      ) %>%
      mutate(
        r_t_lo = map_dbl(r_t_simulated, ~ hdi(.x)[1]),
        r_t_hi = map_dbl(r_t_simulated, ~ hdi(.x)[2])
      ) %>%
      select(-r_t_simulated)
  }

  estimates <- covid_cases %>%
    filter(state == state_selected) %>%
    smooth_new_cases_1() %>%
    smooth_new_cases_25()  %>%
    compute_likelihood() %>%
    compute_posterior() %>%
    estimate_rt()

  return(estimates)

}

##### cislaghi method

est_rt_Cislaghi <- function(ts, window_interval) {
  data1 <- accelerometry::movingaves(ts, window=5)
  names(data1) <- names(ts)[3:(length(ts)-2)]
  res <- sapply( (1+window_interval):length(data1), function(t) {
    data1[t]/data1[t-window_interval]
  })
  return(res)

}

###### JRC method ###########################

est_rt_JRC <- function(ts, window_interval) {
  res <- sapply( 1:(length(ts)-window_interval), function(t) {
    ((log(ts[t+window_interval])-log(ts[t]))/window_interval)*7 + 1
  })
  return(res)

}

#### RKI method   ##############################

est_rt_rki <- function(ts, GT=4L) {
  # Sanity check
  if (!is.integer(GT) | !(GT>0)) stop("GT has to be postive integer.")
  # Estimate, if s=1 is t-7
  res <- sapply( (2*GT):length(ts), function(t) {
    sum(ts[t-(0:(GT-1))]) / sum(ts[t-2*GT+1:GT])
  })
  names(res) <- names(ts)[(2*GT):length(ts)]
  return(res)
}

###### Exponential growth, Wallinga & Lipsitch   ########

R.from.r <- function (r, GT) {
  Tmax = length(GT$GT)
  R = 1/sum(GT$GT * (exp(-r * (0:(Tmax - 1)))))
}

est_rt_exp <- function(ts, GT_obj, half_window_width=3L) {
  # Loop over all time points where the sliding window fits in
  res <- sapply((half_window_width+1):(length(ts)-half_window_width), function(t) {
    # Define the sliding window
    idx <- (t-half_window_width):(t+half_window_width)
    data <- data.frame(Date=1:length(ts), y=as.numeric(ts))
    # Fit a Poisson GLM
    m <- glm( y ~ 1 + Date, family=poisson, data= data  %>% slice(idx))
    # Extract the growth rate
    r <- as.numeric(coef(m)["Date"])

    # Equation 2.9 from Wallinga & Lipsitch
    R <- R.from.r(r, GT_obj)
    return(R)
  })
  names(res) <- names(ts)[(half_window_width+1):(length(ts)-half_window_width)]
  return(res)
}

######### Wallinga & Teunis   ##############

est_rt_wt <- function(ts1, GT_obj) {
  end1 <- length(ts1)

  R0::est.R0.TD(ts1, GT=GT_obj, begin=1, end=as.numeric(end1),correct=TRUE, nsim=1000)
}

#### function to calculate country specific value

Est_R0 <- function(start_date, country_name) {

  data2<-data_ECDC[,c("dateRep", "cases", "countriesAndTerritories")]
  # Set cases with minus value to 0
  data2$cases[which(data2$cases <0)]<-0
  # change format of Dates
  data2$dateRep <- as.Date(as.character(data2$dateRep), format="%d/%m/%Y")
  names(data2) <- c("Date", "y", "CountryName")

  data2<-data_ECDC[,c("dateRep", "cases", "countriesAndTerritories")]
  # Set cases with minus value to 0
  data2$cases[which(data2$cases <0)]<-0
  # change format of Dates
  data2$dateRep <- as.Date(as.character(data2$dateRep), format="%d/%m/%Y")
  names(data2) <- c("Date", "y", "CountryName")
  eval(parse(text=paste("index1 <- which(data2$CountryName ==\"",country_name, "\")", sep="" )))
  out <- data2[index1,]
  # Get starting date for the country
  out<-out[dim(out)[1]:1,]

  out <- out[out$Date %in% seq(from=as.Date(start_date) , to=out$Date[length(out$Date)] , by=1),]

out3 <- out
    names(out3)<-c("date", "cases1", "state")

  out3$cases[1] <-out3$cases1[1]
  for (j in 2:dim(out3)[1]) {
    out3$cases[j] <-   out3$cases[j-1]+  out3$cases1[j]
  }

  #### cislaghi method  ######

  rt_Cislaghi_3 <- est_rt_Cislaghi(out$y  %>% setNames(out$Date), window_interval=3)
  rt_Cislaghi_4 <- est_rt_Cislaghi(out$y  %>% setNames(out$Date), window_interval=4)
  rt_Cislaghi_5 <- est_rt_Cislaghi(out$y  %>% setNames(out$Date), window_interval=5)
  rt_Cislaghi_6 <- est_rt_Cislaghi(out$y  %>% setNames(out$Date), window_interval=6)

  rt_Cislaghi_3_df <- data.frame(Date=as.Date(names(rt_Cislaghi_3)), R_hat=rt_Cislaghi_3, Method=" 3")
  rt_Cislaghi_4_df <- data.frame(Date=as.Date(names(rt_Cislaghi_4)), R_hat=rt_Cislaghi_4, Method=" 4")
  rt_Cislaghi_5_df <- data.frame(Date=as.Date(names(rt_Cislaghi_5)), R_hat=rt_Cislaghi_5, Method=" 5")
  rt_Cislaghi_6_df <- data.frame(Date=as.Date(names(rt_Cislaghi_6)), R_hat=rt_Cislaghi_6, Method=" 6")

  #### Kevins Systrom method    ######

  # r_t_range is a vector of possible values for R_t
  R_T_MAX = 12
  r_t_range = seq(0, R_T_MAX, length = R_T_MAX*100 + 1)

  # Gamma is 1/serial interval
  # https://wwwnc.cdc.gov/eid/article/26/6/20-0357_article
  GAMMA = 1/7

  eval(parse(text=paste(" rt_Systrom <- est_rt_Systrom(covid_cases=out3, state_selected=\"",country_name, "\")", sep="" )))

  rt_Systrom_df <- data.frame(Date=rt_Systrom$date, R_hat=rt_Systrom$r_t_most_likely, upper=rt_Systrom$r_t_hi, lower=rt_Systrom$r_t_lo, Method="Systrom")

  ####   JRC method    #######

  rt_jrc <- est_rt_JRC(out$y  %>% setNames(out$Date), window_interval=7)

  rt_jrc_df <- data.frame(Date=as.Date(names(rt_jrc)), R_hat=rt_jrc, Method="JRC, GT=7")

  #############  RKI method ################

  # RKI method as specified in 2020-04-24 version of the article
  rt_rki <- est_rt_rki(out$y  %>% setNames(out$Date), GT=4L)

  rt_rki_df <- data.frame(Date=as.Date(names(rt_rki)), R_hat=rt_rki, Method="RKI, GT=4")

  ###### Wallinga & Lipsitch method    #############

  # Exponential growth with discrete Laplace transform of a GT \equiv = 4 distribution
  rt_exp2 <- est_rt_exp( out$y %>% setNames(out$Date), GT_obj=R0::generation.time("empirical", c(0,0,0,0,0,0,0,1)), half_window_width=3)

  # Exponential growth with discrete Laplace transform of the correct GT distribution
  rt_exp <- est_rt_exp( out$y %>% setNames(out$Date), GT_obj=GT_obj, half_window_width=3)

  rt_exp_df <- data.frame(Date=as.Date(names(rt_exp)), R_hat=rt_exp, Method="Stochastic generation time")
  #rt_exp_df <- data.frame(Date=as.Date(names(rt_exp_int[1:dim(rt_exp_int)[2]])), R_hat=rt_exp_int[1,], lower= rt_exp_int[2,], upper=rt_exp_int[3,], Method="Exp-Growth, random GT")

  rt_exp2_df <- data.frame(Date=as.Date(names(rt_exp2)), R_hat=rt_exp2, Method="Generation time 7 days (constant)")

  ### Wallinga and Teuniss############

  rt_wt <- est_rt_wt( out$y, GT=GT_obj)

  rt_wt_df <- cbind(Date=out$Date[as.numeric(names(rt_wt$R))], R_hat=rt_wt$R, rt_wt$conf.int, Method="W & T, ramdom GT")

  ### Create dataset with all estmates

  out_data <- data.frame(Date = as.Date(out$Date),Cases = out$y)

  # Merge the data

names(rt_Cislaghi_3_df)[2] <- "Cislaghi_3"
out_data <-  merge(x=out_data, y=rt_Cislaghi_3_df[,1:2], by = "Date", all.x=TRUE)
names(rt_Cislaghi_4_df)[2] <- "Cislaghi_4"
out_data <-  merge(x=out_data, y=rt_Cislaghi_4_df[,1:2], by = "Date", all.x=TRUE)
names(rt_Cislaghi_5_df)[2] <- "Cislaghi_4"
out_data <-  merge(x=out_data, y=rt_Cislaghi_5_df[,1:2], by = "Date", all.x=TRUE)
names(rt_Cislaghi_6_df)[2] <- "Cislaghi_4"
out_data <-  merge(x=out_data, y=rt_Cislaghi_6_df[,1:2], by = "Date", all.x=TRUE)
names(rt_Systrom_df)[2:4] <- c("Systrom", "Systrom_upper", "Systrom_lower")
out_data <-  merge(x=out_data, y=rt_Systrom_df[,1:4], by = "Date", all.x=TRUE)
names(rt_jrc_df)[2] <- "JRC"
out_data <-  merge(x=out_data, y=rt_jrc_df[,1:2], by = "Date", all.x=TRUE)
names(rt_rki_df)[2] <- "RKI"
out_data <-  merge(x=out_data, y=rt_rki_df[,1:2], by = "Date", all.x=TRUE)
names(rt_exp_df)[2] <- "Exp_growth_random_GT"
out_data <-  merge(x=out_data, y=rt_exp_df[,1:2], by = "Date", all.x=TRUE)
names(rt_exp2_df)[2] <- "Exp_growth_constant_GT"
out_data <-  merge(x=out_data, y=rt_exp2_df[,1:2], by = "Date", all.x=TRUE)
names(rt_wt_df)[2:4] <- c("Wallinga_Teunis", "Wallinga_Teunis_Upper", "Wallinga_Teunis_lower")
out_data <-  merge(x=out_data, y=rt_wt_df[,1:4], by = "Date", all.x=TRUE)

return(out_data)

}

R_estimates <- Est_R0(start_date=starting_date, country_name=Country_Name)

write.csv(R_estimates, file.path(Homedir, "Reproduction_number_estimates.csv"))


top500_plotter <- function(df, my.val, lab, my.val.lab)
{
  ### Fooling R CMD check
  value <- Type <- .x <- NULL

  g <- ggplot(df, aes(date, value)) +
         geom_line(aes(colour=Type)) +
         geom_point(aes(colour=Type), size=1) +
         theme(legend.direction="horizontal", legend.position=c(.5, .972)) +
         xlab("Date")

  if (!is.null(my.val))
  {
    labeldata <- data.frame(date=df[nrow(df), 1L], value=my.val)

    g <- g + geom_hline(yintercept=my.val, linetype="dashed") +
             geom_text(aes(vjust=-.5, hjust=.8), label="My Computer", data=labeldata) +
             geom_text(aes(vjust=1.5, hjust=.8), label=paste(round(my.val, 2), my.val.lab), data=labeldata)
  }

  g <- g + scale_y_log10(breaks=trans_breaks("log10", function(x) 10^x),
             labels=trans_format("log10", math_format(10^.x)))

  g <- g + ylab(lab)

  g <- g + ggtitle("Performance of the Top 500 Supercomputers")

  return( g )
}

check_columns <- function(columns)
{
  columns <- unique(columns)
  possible <- c("Min", "Mean", "Max", "Median", "Sum")
  printpossible <- paste0(possible, collapse=", ")

  if (typeof(possible) != "character")
    stop(paste("'columns' must be a character vector containing only", possible), call.=FALSE)

  if (length(columns) == 0)
    stop("You must ", call.=FALSE)
  else if (length(columns) > length(possible))
    stop(paste("'columns' must be a character vector with no more than", length(possible)), call.=FALSE)

  for (col in columns)
  {
    if (!(col %in% possible))
      stop(paste("'columns' must be a character vector with possible values", printpossible), call.=FALSE)
  }

  invisible()
}

#' Top500 Data Plotter
#'
#' \code{plot_top500} is a simple interface for being able to quickly summarize
#' historical supercomputing data.  It also includes an option for comparing
#' your own data against the historical supercomputing data.
#'
#' TODO what do the options mean
#'
#' Whichever combination of columns is passed will be plotted, and more than
#' one can be used.  For example, passing \code{columns=c("Min", "Max")} will
#' show the min and max lines.
#'
#' @param columns
#' A vector of strings that determines which values will be
#' shown on the graph.  Options include "Min", "Mean, "Max", "Median", and "Sum".
#' @param type
#' A string indicating the type of quantity to plot.  Options are
#' "theoretical", "linpack", "difference", and "ncores".
#' @param my.val
#' An optional value (matching the type argument) to add to the
#' plot.  Want to see how your macine's performance compares with all
#' supercomputers since 1993?  Pass your own value and see.  Passing NULL does
#' nothing.
#'
#' @export
plot_top500 <- function(type="theoretical", columns=c("Min", "Mean", "Max"), my.val=NULL)
{
  ### Fooling R CMD check
  Type <- value <- NULL
  rm(list=c("Type", "value"))

  check_columns(columns=columns)

  type <- match.arg(tolower(type), c("theoretical", "linpack", "difference", "ncores"))

  if (type == "difference")
  {
    top <- top500.diff()
    lab <- "Difference Between Theoretical Peak and Performance on Linpack Benchmark"
    my.val.lab <- ""
  }
  else
  {
    top <- top500.summary(type=type)

    if (type == "theoretical")
    {
      lab <- "Theoretical Peak GFLOPs"
      my.val.lab <- "Peak GFLOPs   "
    }
    else if (type == "linpack")
    {
      lab <- "GFLOPs Performance on the Linpack Benchmark"
      my.val.lab <- "Linpack GFLOPs    "
    }
    else if (type == "ncores")
    {
      lab <- "Number of Cores"
      my.val.lab <- "Cores"
    }
  }

  top <- top[, c("date", columns)]

  df <- tidyr::gather(top, Type, value, -date)
  df$Type <- factor(df$Type, levels=rev(levels(df$Type)))

  if (is.null(my.val))
    my.val.lab <- ""

  g <- top500_plotter(df=df, my.val=my.val, lab=lab, my.val.lab=my.val.lab)

  return( g )
}


## -----------
## Function file associated with LinkMODdat_Grid.r
## -----------

## Function 1: Extract UID strings from grid file
ExtrUIDs <- function(colstrings){
  require(stringr)
  liststr <- strsplit(colstrings, ",")
  charvec <- str_trim(gsub("[[:punct:]]|c", "", liststr[[1]]))
  return(charvec)
}

## Function 2: Calculate values for each MAIAC pixel
CalcVals <- function(Griddat, MODdat) {
  # Pull UIDs from gridded data
  UIDframe <- cbind.data.frame(ExtrUIDs(Griddat[,3]))
  colnames(UIDframe) <- "UID"
  # Merge Gridded pixels in this MAIAC pixel to MYD/MOD35 data
  Tog <- merge(UIDframe, MODdat, by="UID")
  # Merge in Cloud data from cloud product
  #Tog <- merge(Tog1, Clouddat, by.x=c("Index", "hr", "min"), by.y=c("MaskVal", "hr", "min"))
  # Scale and remove missing values from cloud effective radius and cloud aod
  #Tog$CldEffRad <- ifelse(Tog$CloudEffRad == -9999, NA, Tog$CloudEffRad)*scale
  #Tog$CloudAOD <- ifelse(Tog$CloudAOD == -9999, NA, Tog$CloudAOD)*scale
  # Aggregate cloud AOD and cloud effective radius
  #CER <- mean(Tog$CldEffRad, na.rm=T)
  #CAOD <- mean(Tog$CloudAOD, na.rm=T)
  # Return output
  Outp <- cbind.data.frame(Tog)
  return(Outp)
}


################################################################################################################################################
#                                                Script to create vars for the composition domain                                              #
# Vars: % of                                                                                #
# 1. clothing and footwear,                                                                                #
# 2. DIY and Household goods                                                                                #
# 3. Electrical                                                                                #
# 4. Recreational (toys, books and sport)                                                                                #
# 5. Other goods                                                                                #
################################################################################################################################################

library(sf)
library(stringr)
library(data.table)
library(clusterCrit)
library(parallel)

ru <- st_read("~/Dropbox/liverpool/catchments/catchments2/retail_units/retail_units_all_data_area_id_names_fin.shp", stringsAsFactors = F)
ru2 <- as.data.frame(ru)
setDT(ru2)

################################################################################################################################################
#                                                           Comparison subdomain                                                               #
################################################################################################################################################

##### 1. Clothing and footwear #################################################################################################################
# footwear in category field as 'Footwear', clothing in category as 'Fashion & General Clothing'
clothing <- c('Footwear', 'Fashion & General Clothing')
sum(ru2$category %in% clothing) # 27684
clothing_prop <- ru2[, 100 * sum(category %in% clothing)/.N, keyby = "cluster_id"]

##### 2. DIY and Household #####################################################################################################################
# DIY in subcat as D.I.Y, Household in subcat as Household Stores
ru2[category == "DIY, Hardware, Builder's Merchants & Household Goods", unique(subcat)]
house_goods <- ru2[, 100 * sum(subcat %in% c("D.I.Y.", "Household Stores")) / .N, keyby = "cluster_id"]

##### 3. Electrical goods ######################################################################################################################
ru2[category == "Electrical Goods & Home Entertainment", unique(subcat)]
electrical <- ru2[, 100 * sum(category == "Electrical Goods & Home Entertainment") / .N, keyby = "cluster_id"]

##### 4. Recreational ##########################################################################################################################
# For books, either 'Books, Arts & Crafts, Stationery, Printers' from cat or 'Booksellers' from subcat
ru2[category %in% c('Sports, Toys, Cycle Shops & Hobbies', "Gifts, China & Leather Goods"), unique(subcat)]
hobbies <- ru2[, 100 * sum(category %in% c('Sports, Toys, Cycle Shops & Hobbies', "Gifts, China & Leather Goods")) / .N, keyby = "cluster_id"]

################################################################################################################################################
#                                                           Convenience subdomain                                                              #
################################################################################################################################################

##### 1. Food retailers ########################################################################################################################
groceries_cat <- sapply(gsub(",", "", unique(ru2$category)), function(x) any(str_to_lower(unlist(strsplit(x, " "))) == "groceries"))
groceries_cat[groceries_cat]

butchers_cat <- sapply(gsub(",", "", unique(ru2$category)), function(x) any(str_to_lower(unlist(strsplit(x, " "))) == "butchers"))
butchers_cat[butchers_cat]

bakers_cat <- sapply(gsub(",", "", unique(ru2$category)), function(x) any(str_to_lower(unlist(strsplit(x, " "))) == "bakers"))
bakers_cat[bakers_cat]

food_retailers_cat <- c(names(groceries_cat[groceries_cat]), names(butchers_cat[butchers_cat]), names(bakers_cat[bakers_cat]))

food_retailers <- ru2[, 100 * sum(category %in% food_retailers_cat) / .N, keyby = "cluster_id"]

##### 2. CTNs (Confectionery, Tobacco, Newsagents) #############################################################################################
ctn <- ru2[, 100 * sum(category == 'Confectionery, Tobacco, Newsagents') / .N, keyby = "cluster_id"]

##### 3. Off license ###########################################################################################################################
off_licence_log <- sapply(gsub(",","", unique(ru2$category)), function(x) any(c("off", "license") %in% str_to_lower(unlist(strsplit(x, " ")))))
off_licence_cat <- names(off_licence_log[off_licence_log])
off_license <- ru2[, 100 * sum(category == off_licence_cat) / .N, keyby = "cluster_id"]

##### 4. Chemists ##############################################################################################################################

chemists_log <- sapply(gsub(",","", unique(ru2$subcat)), function(x) any(c("chemist", "chemists") %in% str_to_lower(unlist(strsplit(x, " ")))))
chemists_cat <- unique(ru2$subcat)[which(chemists_log)]

chemists <- ru2[, 100 * sum(subcat %in% chemists_cat) / .N, keyby = "cluster_id"]

################################################################################################################################################
#                                                           Hospitality subdomain                                                              #
################################################################################################################################################

##### 1. Restaurants ###########################################################################################################################
restaurant_log <- sapply(gsub(",","", unique(ru2$category)), function(x) "restaurants" %in% str_to_lower(unlist(strsplit(x, " "))))
restaurant_cat <- names(restaurant_log[restaurant_log])
restaurants <- ru2[, 100 * sum(category == restaurant_cat) / .N, keyby = "cluster_id"]

##### 2. Bars and pubs #########################################################################################################################
bars_log <- sapply(gsub(",","", unique(ru2$category)), function(x) any(c("bars", "pubs") %in% str_to_lower(unlist(strsplit(x, " ")))))
bars_cat <- unique(ru2$category)[which(bars_log)]
bars <- ru2[, 100 * sum(category == bars_cat) / .N, keyby = "cluster_id"]

##### 3. Cafes and fast food ###################################################################################################################
caffes_ff_log <- sapply(gsub(",","", unique(ru2$category)),
                        function(x) any(c("cafes","cafe", "coffee", "fast") %in% str_to_lower(unlist(strsplit(x, " ")))))
caffes_ff_cat <- unique(ru2$category)[which(caffes_ff_log)]
caffes_ff <- ru2[, 100 * sum(category == caffes_ff_cat) / .N, keyby = "cluster_id"]

##### 4. Entertainment #########################################################################################################################
entertainment_log <- sapply(gsub(",","", unique(ru2$category)), function(x) "entertainment" %in% str_to_lower(unlist(strsplit(x, " "))))
entertainment_cat <- unique(ru2$category)[which(entertainment_log)][2]
entertainment <- ru2[, 100 * sum(category == entertainment_cat) / .N, keyby = "cluster_id"]

##### 5. Fitness centres #######################################################################################################################
finess_subcats <- c("Health Clubs", "Sports Clubs", "Leisure Centres & Swimming Baths")
fitness <- ru2[, 100 * sum(subcat %in% finess_subcats) / .N, keyby = "cluster_id"]

##### 6. Health and beauty services ############################################################################################################
health_and_beauty_log <- sapply(gsub(",","", unique(ru2$subcat)),
                                function(x) all(c("health", "beauty") %in% str_to_lower(unlist(strsplit(x, " ")))))
health_and_beauty_cat <- unique(ru2$subcat)[which(health_and_beauty_log)]
health_and_beauty <- ru2[, 100 * sum(subcat %in% health_and_beauty_cat) / .N, keyby = "cluster_id"]

################################################################################################################################################
#                                              Other Consumer Services subdomain                                                               #
################################################################################################################################################

##### 1. Consumer services #####################################################################################################################
consumer_cats <- c("Banks, Financial Services & Building Societies", "Travel Agents & Tour Operators", "Estate Agents & Auctioneers")
consumer_services <- ru2[, 100 * sum(category %in% consumer_cats) / .N, keyby = "cluster_id"]

##### 2. Household services ####################################################################################################################
household_cats <- c("Launderettes, Dry Cleaners & Other", "Car & Motorbike Showrooms", "Household & Home", "Locksmiths, Clothing Alterations & Shoe Repairs")
household_services <- ru2[, 100 * sum(category %in% household_cats) / .N, keyby = "cluster_id"]

##### 3. Business services #####################################################################################################################
# check_wholesale <- sapply(str_to_lower(gsub(",","",ru$store_name)), function(x) "wholesale" %in% unlist(strsplit(x, " "))) # only 27
#
# check_legal <- sapply(str_to_lower(gsub(",","",ru$store_name)), function(x) "legal" %in% unlist(strsplit(x, " ")))
# # perhaps "Estate Agents & Auctioneers" from category, "Financial Advisors", "Insurance Agents", "Mortgage Companies & Advisors",  from subcat
financial_services <- ru2[, 100 * sum(category %in% "Estate Agents & Auctioneers" | subcat %in% c("Financial Advisors", "Insurance Agents", "Mortgage Companies & Advisors")) / .N, keyby = "cluster_id"]
#
# recruitment_subcat <- "Recruitment Agencies"

recruitment_services <- ru2[, 100 * sum(subcat %in% "Recruitment Agencies") / .N, keyby = "cluster_id"]

out <- data.table(cluster_id = clothing_prop$cluster_id,
                  clothing = clothing_prop$V1,
                  house_goods = house_goods$V1,
                  electrical = electrical$V1,
                  hobbies = hobbies$V1,
                  food_retailers = food_retailers$V1,
                  ctn = ctn$V1,
                  off_license = off_license$V1,
                  chemists = chemists$V1,
                  restaurants = restaurants$V1,
                  bars = bars$V1,
                  caffes = caffes_ff$V1,
                  entertainment = entertainment$V1,
                  fitness = fitness$V1,
                  health_and_beauty = health_and_beauty$V1,
                  consumer_services = consumer_services$V1,
                  household_services = household_services$V1,
                  financial_services = financial_services$V1,
                  recruitment_services = recruitment_services$V1)

fwrite(out, "~/Dropbox/liverpool/retail_typology/data/composition/composition_input.csv")

########################################################################################################################
# get_cl_kmeans <- function(k, data_mat, criterion = "S_Dbw"){
#
#   crit_vals <- vector("numeric", length = 1000)
#   seed_vals <- 234:1233
#   for (i in 1:1000){
#     set.seed <- seed_vals[i]
#     temp <- kmeans(data_mat, centers=k, iter.max=10000)
#     # if (temp$tot.withinss < fit){
#     crit_vals[i] <- as.numeric(intCriteria(data_mat, as.integer(temp$cluster), criterion))
#   }
#
#   idx_rm <- is.na(crit_vals)
#   if (any(idx_rm)){
#     crit_vals <- crit_vals[!idx_rm]
#     seed_vals <- seed_vals[!idx_rm]
#   }
#   idx_best <- bestCriterion(crit_vals, criterion)
#   return(c(crit_vals[idx_best], seed_vals[idx_best]))
# }
#
# composition_dt <- fread("/home/michalis/Dropbox/liverpool/retail_typology/data/composition/composition_input.csv")
# comp_std <- composition_dt[, lapply(.SD, scale), .SDcols = 2:19]
#
# # Determine number of clusters
# # wss <- composition_dt[, (.N - 1) * sum(unlist(lapply(.SD, var))), .SDcols = 2:17] #(nrow(composition_dt)-1) * sum(apply(composition_dt,2,var))
# # cal_har_crit <- vector("numeric", 14)
# # for (i in 2:15){
# #   clustering <- kmeans(composition_dt[,2:17], centers=i)
# #   wss[i] <- sum(clustering$withinss)
# #   cal_har_crit[i-1] <- intCriteria(as.matrix(composition_dt[,2:17]), clustering$cluster, "Calinski_Harabasz")
# # }
# # plot(1:15, wss, type="b", xlab="Number of Clusters", ylab="Within groups sum of squares")
#
#
# test_clusters <- do.call(rbind, mclapply(2:18, get_cl_kmeans, as.matrix(comp_std), "S_Dbw", mc.cores = 10))
# # test_clusters
# #          [,1] [,2]
# # [1,] 1.446936  240
# # [2,] 1.590649  589
# # [3,] 1.796437  927
# # [4,] 1.914620  291
# # [5,] 1.120690  950
# # [6,] 1.476037  247
# # [7,] 1.456968  430
# # [8,] 1.373320 1115
# # [9,] 1.335035  978
# # [10,] 1.299188  417
# # [11,] 1.247035  556
# # [12,] 1.205545  484
# # [13,] 1.262809  659
# # [14,] 1.448658  833
# # [15,] 1.443864  521
# # [16,] 1.337600  956
# # [17,] 1.314078  555
# idx_best <- bestCriterion(test_clusters[,1], "S_Dbw") # 5 -> 6 clusters seems more appropriate
# test_clusters[idx_best,] # 1.12069 950 -> 950 seed
#
# set.seed(950)
# clustering <- kmeans(comp_std, centers = 6, iter.max = 10000)
# table(clustering$cluster)
# # 1    2    3    4    5    6
# # 410 1593  232  729  175  190
#
# composition_dt[, clustering := clustering$cluster]
#
# fwrite(composition_dt, "~/Dropbox/liverpool/retail_typology/data/composition/composition_clustering_6.csv")
#
# ru[composition_dt, clustering := i.clustering, on = "cluster_id"]
#
# ru <- st_as_sf(as.data.frame(ru), crs = 27700)
#
# st_write(ru, "/home/michalis/Dropbox/liverpool/retail_typology/data/composition/retail_units_clustering_6.shp", driver = "ESRI Shapefile")
#
# comp_dt_long <- data.table::melt(composition_dt, 20, 2:19)
#
# means <- aggregate(comp_dt_long$value, by = list(comp_dt_long$clustering, comp_dt_long$variable), mean)
# names(means) <- c("cluster", "category", "mean_pct")
# means$cluster <- as.factor(means$cluster)
#
# ggplot(means, aes(x = category, fill = cluster, y = mean_pct)) + geom_dotplot(binaxis = "y", stackdir = "center") +
#   ylab("Mean of Variable (%)") + scale_fill_discrete(name = "Cluster ID")
#   # geom_segment(aes(x=1,y=0.2523363,xend=1,yend=0.2959657 ),colour="black",size=1) +
#   # geom_segment(aes(x=2,y=0.2415900,xend=2,yend=0.3934252 ),colour="black",size=1) +
#   # geom_segment(aes(x=3,y=0.2418190,xend=3,yend=0.4512376 ),colour="black",size=1) +
#   # geom_segment(aes(x=4,y=0.3988005,xend=4,yend=0.2448053 ),colour="black",size=1) +
#   # geom_hline(yintercept=0.2566891)


/*
 * Produces 1D plots of chamber efficiency starting from the DQM output files
 * of the DTChamberEfficiency and DTChamberEfficiencyTest modules.
 *
 *
 * G. Cerminara 2009
 */
#if !defined(__CINT) || defined(__MAKECINT__)
#include "TH2F.h"
#include "TCanvas.h"
#include "TGraphErrors.h"
#include "TStyle.h"
#include "TFile.h"
// #include "macros.C"
#include <vector>
#endif

using namespace std;

vector<TGraphErrors *> plotEffwh(const TH2F *hEffDQM) {
  vector<TGraphErrors *> ret;
  if(hEffDQM != 0) {
    TCanvas *c = newCanvas(hEffDQM->GetName(), hEffDQM->GetName());
    hEffDQM->Draw("COLZ");
    double sector[12];
    double sectErr[12];

    double effiency[4][12];
    double efficiencyErr[4][12];
    cout << "D-1" << endl;
    for(int station = 1; station != 5; ++station) { //loop over stations
      for(int sect = 1; sect != 13; ++sect) { // loop over sectors
	sector[sect-1] = sect;
	effiency[station-1][sect-1] = hEffDQM->GetBinContent(sect,station);
	efficiencyErr[station-1][sect-1] = hEffDQM->GetBinError(sect,station);
	sectErr[sect-1] = 0.5;
      }
    }
    cout << "D-0.5" << endl;

    ret.push_back(new TGraphErrors(12, sector, effiency[0], sectErr, efficiencyErr[0]));
    ret.push_back(new TGraphErrors(12, sector, effiency[1], sectErr, efficiencyErr[1]));
    ret.push_back(new TGraphErrors(12, sector, effiency[2], sectErr, efficiencyErr[2]));
    ret.push_back(new TGraphErrors(12, sector, effiency[3], sectErr, efficiencyErr[3]));
    cout << "D0" << endl;
    cout << " ret.size() : " << ret.size() << endl;
    return ret;
  } else return ret;
}

void plotEfficiency(){
  // Load needed macros and files
  gROOT->LoadMacro("macros.C");     // Load service macros

  // Get the style
  TStyle * style = getStyle("tdr");
  style->cd();

  // retrieve the last open file
  TFile *file = (TFile *)(gROOT->GetListOfFiles()->Last());
  if(file == 0) {
    cout << "No file loaded!Exiting." << endl;
    return;
  }
  cout << "Loading file: " << file->GetName() << endl;

  // retrieve the original histos from the file
  TH2F *histoEff_Whm2 = (TH2F *) file->Get("DQMData/Run 109459/DT/Run summary/05-ChamberEff/EfficiencyMap_All_W-2");

//   if(histoEff_Whm2 != 0) {
//     TCanvas *c = newCanvas(histoEff_Whm2->GetName(), histoEff_Whm2->GetName());
//     histoEff_Whm2->Draw("COLZ");
//     double sector[12];
//     double sectErr[12];

//     double effiency[4][12];
//     double efficiencyErr[4][12];

//     for(int station = 1; station != 5; ++station) { //loop over stations
//       for(int sect = 1; sect != 13; ++sect) { // loop over sectors
// 	sector[sect-1] = sect;
// 	effiency[station-1][sect-1] = histoEff_Whm2->GetBinContent(sect,station);
// 	efficiencyErr[station-1][sect-1] = histoEff_Whm2->GetBinError(sect,station);
// 	sectErr[sect-1] = 0.5;
//       }
//     }

//     TGraphErrors *mb1Eff_Whm2 = new TGraphErrors(12, sector, effiency[0], sectErr, efficiencyErr[0]);
//     TGraphErrors *mb2Eff_Whm2 = new TGraphErrors(12, sector, effiency[1], sectErr, efficiencyErr[1]);
//     TGraphErrors *mb3Eff_Whm2 = new TGraphErrors(12, sector, effiency[2], sectErr, efficiencyErr[2]);
//     TGraphErrors *mb4Eff_Whm2 = new TGraphErrors(12, sector, effiency[3], sectErr, efficiencyErr[3]);

    vector<TGraphErrors *> graphsWhM2 = plotEffwh(histoEff_Whm2);
    cout << "DD" << endl;
    cout << " size: " << graphsWhM2.size() << endl;
    cout << " " << (int)  graphsWhM2[0] << " "
	 << (int)  graphsWhM2[1] << " "
	 << (int)  graphsWhM2[2] << " "
	 << (int)  graphsWhM2[3] << " " << endl;

    TGraphErrors *mb1Eff_Whm2 = graphsWhM2[0];
    TGraphErrors *mb2Eff_Whm2 = graphsWhM2[1];
    TGraphErrors *mb3Eff_Whm2 = graphsWhM2[2];
    TGraphErrors *mb4Eff_Whm2 = graphsWhM2[3];

    cout << "D1" << endl;

    TCanvas *c1 = newCanvas("Efficiency_Whm2", "Efficiency_Whm2");
    mb1Eff_Whm2->Draw("AP");
    mb1Eff_Whm2->SetMarkerColor(1);

    mb2Eff_Whm2->Draw("P");
    mb2Eff_Whm2->SetMarkerColor(2);
    mb3Eff_Whm2->Draw("P");
    mb3Eff_Whm2->SetMarkerColor(3);
    mb4Eff_Whm2->Draw("P");
    mb4Eff_Whm2->SetMarkerColor(4);

//   }

}


# GET & SET WD

getwd()
setwd('/content/LoanTest/LoanTest/LoanTest')

#Read from CSV

test<-read.csv('test.csv',header=TRUE,sep=',')
train<-read.csv('train.csv',header=TRUE,sep=',')

#Statistics

install.packages('psych',dep=TRUE)
install.packages('Hmisc',dep=TRUE)
install.packages('e1071', dep=TRUE)

library(psych)
library(Hmisc)
describe(train)
describe(test)
names(train)
names(test)
summary(train)
summary(test)

# /* MASTER DATA PREP START */

#Missing Value Check & Str Check - TRAIN

str(train$UniqueID)
str(train$ltv)
str(train$branch_id)
str(train$State_ID)
str(train$supplier_id)
str(train$manufacturer_id)
str(train$Current_pincode_ID)
names(train)
str(train$Age)
str(train$Employment.Type)
str(Aadhar_flag)
str(train$MobileNo_Avl_Flag)
str(Acct.Age.Num)
str(Credit.History.Length.Num)
train$branch_id<-as.factor(train$branch_id)
train$State_ID<-as.factor(train$State_ID)
train$supplier_id<-as.factor(train$supplier_id)
train$manufacturer_id<-as.factor(train$manufacturer_id)
train$Current_pincode_ID<-as.factor(train$Current_pincode_ID)
sum(is.na(train$Employment.Type))
mode(train$Employment.Type)

attach(train)

MobileNo_Avl_Flag<-as.factor(MobileNo_Avl_Flag)
Aadhar_flag<-as.factor(Aadhar_flag)
PAN_flag<-as.factor(PAN_flag)
VoterID_flag<-as.factor(VoterID_flag)
Driving_flag<-as.factor(Driving_flag)
Passport_flag<-as.factor(Passport_flag)

#attach(test)
#Missing Value Check & Str Check - TEST

str(test$UniqueID)
str(test$ltv)
str(test$branch_id)
str(test$State_ID)
str(test$supplier_id)
str(test$manufacturer_id)
str(test$Current_pincode_ID)
names(test)
str(test$Age)
str(test$Employment.Type)
str(Aadhar_flag)
str(test$MobileNo_Avl_Flag)
str(Acct.Age.Num)
str(Credit.History.Length.Num)
test$branch_id<-as.factor(test$branch_id)
test$State_ID<-as.factor(test$State_ID)
test$supplier_id<-as.factor(test$supplier_id)
test$manufacturer_id<-as.factor(test$manufacturer_id)
test$Current_pincode_ID<-as.factor(test$Current_pincode_ID)
sum(is.na(test$Employment.Type))
test$MobileNo_Avl_Flag<-as.factor(test$MobileNo_Avl_Flag)
test$Aadhar_flag<-as.factor(test$Aadhar_flag)
test$PAN_flag<-as.factor(test$PAN_flag)
test$VoterID_flag<-as.factor(test$VoterID_flag)
test$Driving_flag<-as.factor(test$Driving_flag)
test$Passport_flag<-as.factor(test$Passport_flag)

# Data Transformation - TRAIN

train$Scaled_Disbursed<-log(train$disbursed_amount)
train$Scaled_AssetCost<-log(train$asset_cost)
train$ScaledLTV<-train$ltv/10
train$Scaled_Primary_Num_Accts<-sqrt(train$PRI.NO.OF.ACCTS)
train$Scaled_Primary_Active_Accts<-sqrt(train$PRI.ACTIVE.ACCTS)
train$Scaled_Primary_Overdue_Accts<-sqrt(train$PRI.OVERDUE.ACCTS)
train$Scaled_Primary_Curr_Bal<-(train$PRI.CURRENT.BALANCE)+1
train$New_Scaled_Primary_Curr_Bal<-log(train$Scaled_Primary_Curr_Bal)
train$Scaled_Primary_Sanct_Amt<-(train$PRI.SANCTIONED.AMOUNT)+1
train$New_Scaled_Primary_Sanct_Amt<-log(train$Scaled_Primary_Sanct_Amt)
train$Scaled_Primary_Disbursed_Amt<-(train$PRI.DISBURSED.AMOUNT)+1
train$New_Scaled_Primary_Disbursed_Amt<-log(train$Scaled_Primary_Disbursed_Amt)
train$Scaled_Secondary_Num_Accts<-sqrt(train$SEC.NO.OF.ACCTS)
train$Scaled_Secondary_Active_Accts<-sqrt(train$SEC.ACTIVE.ACCTS)
train$Scaled_Secondary_Overdue_Accts<-sqrt(train$SEC.OVERDUE.ACCTS)
train$Scaled_Secondary_Curr_Bal<-(train$SEC.CURRENT.BALANCE)+1
train$New_Scaled_Secondary_Curr_Bal<-log(train$Scaled_Secondary_Curr_Bal)
train$Scaled_Secondary_Sanct_Amt<-(train$SEC.SANCTIONED.AMOUNT)+1
train$New_Scaled_Secondary_Sanct_Amt<-log(train$Scaled_Secondary_Sanct_Amt)
train$Scaled_Secondary_Disbursed_Amt<-(train$SEC.DISBURSED.AMOUNT)+1
train$New_Scaled_Secondary_Disbursed_Amt<-log(train$Scaled_Secondary_Disbursed_Amt)
train$Scaled_Primary_Installment_Amount<-(train$PRIMARY.INSTAL.AMT)+1
train$New_Scaled_Primary_Installment_Amount<-log(train$Scaled_Primary_Installment_Amount)
train$Scaled_Secondary_Installment_Amount<-(train$SEC.INSTAL.AMT)+1
train$New_Scaled_Secondary_Installment_Amount<-log(train$Scaled_Secondary_Installment_Amount)
train$Scaled_New_Accts_in_6_Mo<-sqrt(train$NEW.ACCTS.IN.LAST.SIX.MONTHS)
train$Scaled_Delinquent_Accts_in_7_Mo<-sqrt(train$DELINQUENT.ACCTS.IN.LAST.SIX.MONTHS)
sum(is.na(train$New_Scaled_Primary_Curr_Bal))
train$New_Scaled_Primary_Curr_Bal<-ifelse(is.na(train$New_Scaled_Primary_Curr_Bal),0,train$New_Scaled_Primary_Curr_Bal)
sum(is.na(train$New_Scaled_Secondary_Curr_Bal))
train$New_Scaled_Secondary_Curr_Bal<-ifelse(is.na(train$New_Scaled_Secondary_Curr_Bal),0,train$New_Scaled_Secondary_Curr_Bal)
write.csv(train, file="Train_interim.csv")

# Data Transformation - TEST

test$Scaled_Disbursed<-log(test$disbursed_amount)
test$Scaled_AssetCost<-log(test$asset_cost)
test$ScaledLTV<-test$ltv/10
test$Scaled_Primary_Num_Accts<-sqrt(test$PRI.NO.OF.ACCTS)
test$Scaled_Primary_Active_Accts<-sqrt(test$PRI.ACTIVE.ACCTS)
test$Scaled_Primary_Overdue_Accts<-sqrt(test$PRI.OVERDUE.ACCTS)
test$Scaled_Primary_Curr_Bal<-(test$PRI.CURRENT.BALANCE)+1
test$New_Scaled_Primary_Curr_Bal<-log(test$Scaled_Primary_Curr_Bal)
test$Scaled_Primary_Sanct_Amt<-(test$PRI.SANCTIONED.AMOUNT)+1
test$New_Scaled_Primary_Sanct_Amt<-log(test$Scaled_Primary_Sanct_Amt)
test$Scaled_Primary_Disbursed_Amt<-(test$PRI.DISBURSED.AMOUNT)+1
test$New_Scaled_Primary_Disbursed_Amt<-log(test$Scaled_Primary_Disbursed_Amt)
test$Scaled_Secondary_Num_Accts<-sqrt(test$SEC.NO.OF.ACCTS)
test$Scaled_Secondary_Active_Accts<-sqrt(test$SEC.ACTIVE.ACCTS)
test$Scaled_Secondary_Overdue_Accts<-sqrt(test$SEC.OVERDUE.ACCTS)
test$Scaled_Secondary_Curr_Bal<-(test$SEC.CURRENT.BALANCE)+1
test$New_Scaled_Secondary_Curr_Bal<-log(test$Scaled_Secondary_Curr_Bal)
test$Scaled_Secondary_Sanct_Amt<-(test$SEC.SANCTIONED.AMOUNT)+1
test$New_Scaled_Secondary_Sanct_Amt<-log(test$Scaled_Secondary_Sanct_Amt)
test$Scaled_Secondary_Disbursed_Amt<-(test$SEC.DISBURSED.AMOUNT)+1
test$New_Scaled_Secondary_Disbursed_Amt<-log(test$Scaled_Secondary_Disbursed_Amt)
test$Scaled_Primary_Installment_Amount<-(test$PRIMARY.INSTAL.AMT)+1
test$New_Scaled_Primary_Installment_Amount<-log(test$Scaled_Primary_Installment_Amount)
test$Scaled_Secondary_Installment_Amount<-(test$SEC.INSTAL.AMT)+1
test$New_Scaled_Secondary_Installment_Amount<-log(test$Scaled_Secondary_Installment_Amount)
test$Scaled_New_Accts_in_6_Mo<-sqrt(test$NEW.ACCTS.IN.LAST.SIX.MONTHS)
test$Scaled_Delinquent_Accts_in_7_Mo<-sqrt(test$DELINQUENT.ACCTS.IN.LAST.SIX.MONTHS)
sum(is.na(test$New_Scaled_Primary_Curr_Bal))
test$New_Scaled_Primary_Curr_Bal<-ifelse(is.na(test$New_Scaled_Primary_Curr_Bal),0,test$New_Scaled_Primary_Curr_Bal)
sum(is.na(test$New_Scaled_Secondary_Curr_Bal))
test$New_Scaled_Secondary_Curr_Bal<-ifelse(is.na(test$New_Scaled_Secondary_Curr_Bal),0,test$New_Scaled_Secondary_Curr_Bal)
sum(is.na(test$New_Scaled_Primary_Sanct_Amt))
test$New_Scaled_Primary_Sanct_Amt<-ifelse(is.na(test$New_Scaled_Primary_Sanct_Amt),0,test$New_Scaled_Primary_Sanct_Amt)

sum(is.na(train$Scaled_New_Primary_Curr_Bal))
names(train)
train$Scaled_New_Primary_Curr_Bal<-ifelse(is.na(train$Scaled_New_Primary_Curr_Bal),0,train$Scaled_New_Primary_Curr_Bal)
sum(is.na(train$New_Scaled_Secondary_Curr_Bal))

# /* MASTER DATA PREP END */

# Check for Significant Variables by running GLM - 78.2%

LogReg<-glm(loan_default~Scaled_Disbursed+Scaled_AssetCost+ScaledLTV+Scaled_Primary_Num_Accts+
              Scaled_Primary_Active_Accts+Scaled_Primary_Overdue_Accts+
              New_Scaled_Primary_Sanct_Amt+New_Scaled_Primary_Disbursed_Amt+Scaled_Secondary_Num_Accts+
              Scaled_Secondary_Active_Accts+Scaled_Secondary_Overdue_Accts+
              New_Scaled_Secondary_Sanct_Amt+New_Scaled_Secondary_Disbursed_Amt+New_Scaled_Primary_Installment_Amount+
              New_Scaled_Secondary_Installment_Amount+Age+Employment.Type+State_ID+MobileNo_Avl_Flag+Aadhar_flag+
              PAN_flag+VoterID_flag+Driving_flag+Passport_flag+PERFORM_CNS.SCORE+Acct.Age.Num+Credit.History.Length.Num+
              NO.OF_INQUIRIES+NEW.ACCTS.IN.LAST.SIX.MONTHS+DELINQUENT.ACCTS.IN.LAST.SIX.MONTHS,data=train,family='binomial')
plot(LogReg)

train$YPredict<-predict.glm(LogReg,train,type='response')
View(train)
train$Loan_Status_Predicted<-ifelse(train$YPredict>=0.5,1,0)
table(train$Loan_Status_Predicted)

#Confusion Matrix - GLM - 78.2%

table(train$Loan_Status_Predicted,train$loan_default)

library(e1071)
SVcL <- svm(loan_default~Scaled_Disbursed+Scaled_AssetCost+ScaledLTV+Scaled_Primary_Num_Accts+
             Scaled_Primary_Active_Accts+Scaled_Primary_Overdue_Accts+
             New_Scaled_Primary_Sanct_Amt+New_Scaled_Primary_Disbursed_Amt+Scaled_Secondary_Num_Accts+
             Scaled_Secondary_Active_Accts+Scaled_Secondary_Overdue_Accts+
             New_Scaled_Secondary_Sanct_Amt+New_Scaled_Secondary_Disbursed_Amt+New_Scaled_Primary_Installment_Amount+
             New_Scaled_Secondary_Installment_Amount+Age+Employment.Type+State_ID+MobileNo_Avl_Flag+Aadhar_flag+
             PAN_flag+VoterID_flag+Driving_flag+Passport_flag+PERFORM_CNS.SCORE+Acct.Age.Num+Credit.History.Length.Num+
             NO.OF_INQUIRIES+NEW.ACCTS.IN.LAST.SIX.MONTHS+DELINQUENT.ACCTS.IN.LAST.SIX.MONTHS,data=train,kernel=("radial"))

			 train$svmradialPreds <- predict(SVcL,train)
cm_SVcL <- table(train$svmradialPreds, train$loan_default)
Accuracy_svmRadial_train <- sum(diag(cm_SVcL))/sum(cm_SVcL)
Accuracy_svmRadial_train #1 for Trial on 180320192311
sensitivity_svmRadial_train <- cm_SVcL[1,1] / (cm_SVcL[1,1] + cm_SVcL[2,1])
sensitivity_svmRadial_train #1 for Trial on 180320192311
Specificity_svmRadial_train <- cm_SVcL[2,2] / (cm_SVcL[2,2] + cm_SVcL[1,2])
Specificity_svmRadial_train #1 for Trial on 180320192311

#Juxtapose on Test

test$Predict_SVC_Loan_Default<-predict(SVcL,test)
write.csv(test, file ="Final_Test_Preds.csv")


# boxplot generation

> library(RCurl)
> source.url <- c("https://raw.githubusercontent.com/cordphelps/bison/master/bison.csv")
> bison.df <- read.csv(text=getURLContent(source.url), header=TRUE, row.names=NULL)
> boxplot(percent.total.aesthetics ~ just.checking, data=bison.df, ylab="total: biodiversity + aesthetics", ylim=c(0,1), xlab="aesthetic keywords", las=1, col="powderblue")
> abline (h=.223, col="blue", lty=4, lwd=4)
> summary(bison.df$percent.total.aesthetics)


# simulate endemic component
set.seed(1)
data("population_per_postcode_with_coordinates")

idx = sort(sample(NROW(postcode.data), 10000))
postcode.data. = postcode.data[idx,]

sample.population = postcode.data.[,'Total']
names(sample.population)<-postcode.data.$postcode
rm(postcode.data.)

time.factor = lambda(0:99, c(34, 16, 55,  0), names=T)
total.average = 5000
simulation = Simulate(sample.population, time.factor, total.average, save.baseline.matrix=T)
baseline_for_sim=attributes(simulation)$baseline.matrix
save(baseline_for_sim, file = "data/baseline_for_sim.RData")

simulation_data = as.data.frame(which(simulation == 1, arr.ind = TRUE))
simulation_data$postcode = rownames(simulation)[simulation_data$row]
for (i in 2:max(unlist(simulation))){
  simulation_data.tmp = as.data.frame(which(simulation == i, arr.ind = TRUE))
  simulation_data.tmp$postcode = rownames(simulation)[simulation_data.tmp$row]
  simulation_data = rbind(simulation_data, simulation_data.tmp[rep(seq_len(NROW(simulation_data.tmp)), i),])
}
simulation_data$col = simulation_data$col - 2
# subtract 2 because the first two columns of baseline.matrix correspond c(NA, 0).

simulation_data = cbind(simulation_data, sample.population[simulation_data[,'row']])
names(simulation_data) = c('row','week', 'postcode', 'population')
simulation_data$sim='end.'

# simulate epidemic component
set.seed(1)
idx1 = grepl('AL1', names(sample.population), fixed=T)
idx1 = idx1 | grepl('AL2', names(sample.population), fixed=T)
epi = rpois(n = sum(idx1) * 20, lambda=rep(dnorm(-9:10, sd = 4) * 4, rep(sum(idx1), 20)))
epi.matrix = matrix(epi, ncol = 20)
rownames(epi.matrix) = row.names(simulation)[1:sum(idx1)]
colnames(epi.matrix) = 40:59

new.simulation_data = as.data.frame(which(epi.matrix == 1, arr.ind = TRUE))
new.simulation_data$postcode = rownames(epi.matrix)[new.simulation_data$row]
for (i in 2:max(unlist(epi.matrix))){
  simulation_data.tmp = as.data.frame(which(epi.matrix == i, arr.ind = TRUE))
  simulation_data.tmp$postcode = rownames(epi.matrix)[simulation_data.tmp$row]
  new.simulation_data = rbind(new.simulation_data, simulation_data.tmp[rep(seq_len(NROW(simulation_data.tmp)), i),])
}
rm(simulation_data.tmp)
new.simulation_data$col = new.simulation_data$col + 39
new.simulation_data = cbind(new.simulation_data, sample.population[new.simulation_data[,'row']])
names(new.simulation_data) = c('row','week', 'postcode', 'population')
new.simulation_data$sim = 'epi.'

simulation_data = rbind(simulation_data, new.simulation_data)
rm(new.simulation_data)

# simulate serotypes
simulation_data$type = '1'
simulation_data$type[sample(1:NROW(simulation_data),  round(0.2 * NROW(simulation_data)))] = '2'

simulation_data = merge(simulation_data[,-1], postcode.data, by = 'postcode')
simulation_data[, c('y','x')] = vlatlong2km(simulation_data[,c('latitude', 'longitude')])
simulation_data$Males =NULL
simulation_data$Females=NULL
simulation_data$Occupied_Households=NULL

#write.table(simulation_data, file = 'data/simulation_data.csv', sep=';', row.names = FALSE)
save(simulation_data, file = "data/simulation_data.RData")


#Series temporais e analises preditivas - Fernando Amaral

#pacotes essencias utilizados durante o curso
install.packages("forecast")
install.packages("ggplot2")
install.packages("urca")
install.packages("lmtest")
install.packages("seasonal")
install.packages("seasonalview")

#cria uma serie temporal normalmente distribuida
myts = rnorm(60)
myts = ts(myts,start = c(2012,1), end=c(2016,12), frequency=12)
plot(myts)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/1.3.Criando uma serie temporal.r


# Extracting as interaction matrix
prediction_matrix <- function(S1, predictions, predict.only = FALSE, empirical.only = FALSE) {
    # predict.only: only predictions will be used to recreate the prediction matrix
    # empirical.only: only empirical data will be used to recreate the prediction matrix, corresponding to the contribution of the interaction catalog
    # rownames need to be taxa names
    predict.matrix <- matrix(nrow = length(S1), ncol = length(S1), data = 0, dimnames = list(S1,S1))

    for(i in 1:length(S1)) {
        predict <- unlist(strsplit(predictions[i, 'resource_predictions'], " \\|\\ ")) # list of resource predicted for consumer i
        empirical <- unlist(strsplit(predictions[i, 'resource_empirical'], " \\|\\ ")) # list of resource observed for consumer i

        if(length(predict) == 0) {
          NULL
        } else {
            for(j in 1:length(predict)) {
                if(empirical.only == TRUE) {
                    break
                } else { # empirical.only == FALSE
                    predict.matrix[predict[j],i] <- 1
                } #if
            }#j
        }#if

        if(length(empirical) == 0) {
          NULL
        } else {
            for(j in 1:length(empirical)) {
                if(predict.only == TRUE) {
                    break
                } else { # predict.only == FALSE
                    predict.matrix[empirical[j],i] <- 1
                } #if
            }#j
        }#if
    }#i
    return(predict.matrix)
}#prediction_matrix function end


 ZTPRFS Example Program Results

 Solution(s)
                    1                 2
 1  (-5.0000,-2.0000) ( 1.0000, 5.0000)
 2  (-3.0000,-1.0000) (-2.0000,-2.0000)
 3  ( 2.0000, 1.0000) ( 3.0000, 4.0000)
 4  ( 4.0000, 3.0000) ( 4.0000,-3.0000)

 Backward errors (machine-dependent)
         1.2E-16           5.5E-17
 Estimated forward error bounds (machine-dependent)
         3.0E-14           3.3E-14


#Sergio Antonio Alcala Corona

# Primero hay que cargar los archivos csv a una tabla de R con su encabezado y todo

args <- commandArgs(trailingOnly = TRUE);

DATA = args[1];

# X=read.table("Archivo.csv", header=TRUE, sep =",")
X=read.table(DATA, header=TRUE, sep ="\t");

# Luego hay que definir la columna de nombres (columna 1 de su csv cargado en el objeto X) en un objeto que llamaré RN (de row names)

RN=X[,1];
END = length(X[0,]) - 2;

# Los datos numéricos de su matríz están en las columnas 2 a la 31, carguenlos en un objeto Y

# Y = X[,2:31]
Y=X[,2:END];

Y = as.matrix(Y);

# Pero en su excel pusieron p-values y nosotros queremos que a mayor significancia más intensidad de color, eso se logra con el -log10(p-value)

Z=-log10(Y);

# Para hacer el heatmap deberán tener cargada la libraría (gplots) en [R]

library(gplots);

# Es buena idea definir una paleta de colores, n es el número de intervalos de color

x = strsplit(DATA, "_")
y <- as.character(x[[1]])
z = strsplit(y[length(y)], ".csv")

if (z[1] == 'CC') {
  my_palette <- colorRampPalette(c("white", "violet", "darkviolet", "midnightblue"))(n = 1000);
} else if (z[1] == 'BP') {
  my_palette <- colorRampPalette(c("white", "greenyellow", "limegreen", "darkgreen"))(n = 1000);
} else if (z[1] == 'MF') {
  my_palette <- colorRampPalette(c("white", "lightsalmon", "orangered", "darkred"))(n = 1000);
} else if (z[1] == 'kegg') {
  my_palette <- colorRampPalette(c("white", "lightskyblue", "steelblue", "darkblue"))(n = 1000);
} else {
  my_palette <- colorRampPalette(c("white", "lightcoral", "firebrick", "red"))(n = 1000);
}

# El heatmap se hace con el código siguiente:

# heatmap.2(Z, trace="none", col=my_palette, scale="row", labCol=colnames(Z), labRow=RN)

# Si lo quieren guardar en PDF entonces antes de la instrucción anterior "abren la imagen" con PDF("imagen.pdf") y la cierran con dev.off() de manera que el código queda:

# pdf("heatmap1.pdf")
s = strsplit(DATA,".csv");
out = paste(s,".pdf",sep="");
pdf(out, paper="USr");

# heatmap.2(Z, trace="none", col=my_palette, scale="row", labCol=colnames(Z), labRow=RN);
heatmap.2(Z, trace="none", col=my_palette, labRow=RN, labCol=colnames(Z), margins = c(5, 11.5), cexCol = 0.6, cexRow = 0.3);

dev.off();


#' Generic M-step function to re-estimate the paramters of an emission probability distribution.
#'
#' @param x numeric matrix, size T x p, where T is the number of observations, p the dimension of the obs data
#' @param wt weight matrix
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return the five types of M-step results
#' @description Re-estimate the parameters of an emission distribution as part of the EM algorithm for HMM.
#'    This is called by the hext function.
#' @usage mstep.generic(x, wt, model)
#' @details see example code for usage
#' @author Horace W Tso
#' @export
mstep.generic = function(x, wt, model) {
  # type codes (mtype):
  #   discrete/binomial = 1
  #   multivariate normal = 2
  #   gamma = 3
  #   beta = 4
  #   gaussian mixture = 5
  D = model$D
  mtype = model$mtype
  ix1 = which(mtype == 1)
  if ( length(ix1) == 1 ) {
    # if there is only one column in obs, then no need to use ix1
    if ( length(mtype) == 1 ) {
      M1 = mstep.disc(x, wt, D)
    } else {
      # this is the case where there is only one discrete column
      # and one or more other types of observation, thus need ix1.
      M1 = mstep.disc(x[,ix1, drop=FALSE], wt, D)
    }
  } else if ( length(ix1) > 1 ) {
    M1 = mstep.mvdisc(x[,ix1], wt, D)
  } else {
    M1 = list(prob.l=list(), labels=NULL)
  }

  ix2 = which(mtype == 2)
  if ( length(ix2) == 1 ) {
    M2 = mstep.norm.hext(x[,ix2, drop=FALSE], wt)
  } else if ( length(ix2) > 1 ) {
    # =================================
    M2 = mstep.mvnorm.wish(x[,ix2], wt)
    # =================================
  } else {
    M2 = list(mu.l=list(), sigma.l=list())
  }

  ix3 = which(mtype == 3)
  if ( length(ix3) == 1 ) {
    M3 = mstep.gamma(x[,ix3, drop=FALSE], wt)
  } else if ( length(ix3) > 1 ) {
    M3 = mstep.mvgamma(x[,ix3], wt)
  } else {
    M3 = list(shape.l=list(), scale.l=list())
  }

  ix4 = which(mtype == 4)
  if ( length(ix4) == 1 ) {
    M4 = mstep.beta(x[,ix4, drop=FALSE], wt)
  } else if ( length(ix4) > 1 ) {
    M4 = mstep.mvbeta(x[,ix4], wt)
  } else {
    M4 = list(shape1.l=list(), shape2.l=list())
  }

  ix5 = which(mtype == 5)
  if ( length(ix5) > 0 ) {
    #cat("ix5:", ix5, "\n")
    # ====================================================================
    M5 = mstep.gaussian.mix(x[,ix5, drop=FALSE], wt, model)
    # ====================================================================
  } else {
    M5 = list(c.l=list(), mu.ll=rep(list(list()),K), sigma.ll=rep(list(list()),K))
  }
  return(list(M1=M1, M2=M2, M3=M3, M4=M4, M5=M5))
}

#' M-step re-estimation function for Gaussian Mixture emission distribution with inverse Wishart regularizer
#'
#' @param x numeric matrix, size T x p, where T is the number of observations, p the dimension of the obs data
#' @param w weight matrix, gamma from EStep C function
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return emission slot of Hext object
#' @description Re-estimates the parameters of the gaussian mixture emission distribution as part of the EM algorithm for HMM.
#' @details Ref : Snoussi, Mohammad-Djafari (2005), Degeneracy and likelihood penalization
#'      in multivariate gaussian mixture models, preprint.
#'      NOTE : gam.jk is *not* in log domain.
#' @author Horace W Tso
#' @export
mstep.gaussian.mix = function (x, w, model) {
    idx = apply(is.na(x), 1, any)
    x = x[!idx, , drop = FALSE]
    w = w[!idx, , drop = FALSE]
    K = ncol(w)  # should agree with model$K
    Ttot = NROW(x) # = sum(model$TT)
    p = NCOL(x)  # = model$p
    M = model$M
    wdf = model$wdf

    if ( any(is.na(w)) | any(is.infinite(w))) {
      stop("na/infty found in w[].")
    }
    if ( all(w < 1e-100) == TRUE ) {
      stop("all w[] are near zero.")
    }
    w.tot = colSums(w)  # denominator for the reestimation equations, 1 x K

    emission = list(c.l=list(), mu.ll=rep(list(list()),K), sigma.ll=rep(list(list()),K))
    for ( i in 1:K ) {
      emission$c.l[[i]] = rep(NA, M)
    }

    gam.jk = array(NA, dim=c(Ttot, K, M))
    for ( i in 1:K )  {
       mu.l = model$parms.emission$M5$mu.ll[[i]]
       #if ( length(mu.l) != M ) cat("length of mu.l <> M\n")
       sigma.l = model$parms.emission$M5$sigma.ll[[i]]
       #if ( any(is.na(sigma.l))) {
        # stop("na in sigma.l:")
       #}
       #if ( length(sigma.l) != M ) cat("length of sigma.l <> M\n")
       c.v = model$parms.emission$M5$c.l[[i]]  # c.v is a vector of length M
       #if ( length(c.v) != M ) cat("length of c.v <> M\n")
       # Compute the conditional probabilities of the gaussian components in log domain :
       logbb = matrix(NA, nrow=Ttot, ncol=M)
       for ( m in 1:M ) {
         logbb[,m] = log(c.v[m]) + Dmvnorm(x, mean=mu.l[[m]], sigma=sigma.l[[m]], log=TRUE)
       }
       # Sum the contribution from the individual gaussian components
       # <==> sum by rows ==> a vector of length Ttot
       denom = double(Ttot)
       for ( tt in 1:Ttot) {
         denom[tt] = Elnsum.vec(logbb[tt,]) # in the non-log version: denom = rowSums(bb)
       }
       for ( m in 1:M ) {
          tmp = logbb[,m] + log(w[,i]) - denom
          gam.jk[,i,m] = exp(tmp)
       }
       if ( any(is.na(gam.jk[,i,m])) | any(is.infinite(gam.jk[,i,m]))) {
         cat("na/inf in gam.jk: i, m ", i, m)
         stop("...")
       }
    }

    for ( i in 1:K ) {
      # sum over mixture state k and time t, for every state i
      denom.j = sum(gam.jk[,i,])  # sum over mixture and sum over time, a scalar
      # cat("denom.j:", denom.j, "\n")
      for ( k in 1:M ) {
        if ( all(gam.jk[,i,k] < 1e-100) == FALSE ) {
          # c_jk =======================================================================
          emission$c.l[[i]][k] = sum(gam.jk[,i,k]) / denom.j  # sum over t; scalar / scalar = scalar
          #if ( any(is.na(emission$c.l[[i]][k])) ) {
          #  warning("na in c.l at m-step.")
          #}
          # mu_jk ====================================================================================

          xx = gam.jk[,i,k] * x   # (1 x T) (*) (T x p) = T x p, component by component multiplication
          denom.jk = sum(gam.jk[,i,k])  # summing over t for every i and k, result is a scalar
          mu.bar = colSums(xx) / denom.jk  # (1 x p) / scalar = 1 x p
          #if ( any(is.na(mu.bar)) ) {
          #  warning("na in mu.bar at m-step.")
          #}
          emission$mu.ll[[i]][[k]] = mu.bar

          # sigma_jk =============================================================================================
          x.centered = sweep(x, 2, mu.bar)  # T x p, 'sweep'' subtracts mu.bar ( 1 x p vector) from each row of x,
                                            # in effect, it is subtracting the mean from each column of
                                            # the multivariate observation vector (matrix), or (O_t - mu_jk)
          mat.sum = matrix(0, nrow=p, ncol=p)
          for ( tt in 1:Ttot ) {
            crossp = x.centered[tt,] %*% t(x.centered[tt,]) # x %*% t(x) = p x p matrix
            mat.w = crossp * gam.jk[tt,i,k]  # p x p matrix * scalar = p x p
            mat.sum = mat.sum + mat.w   # element by element addition : p x p
          }
          # Regularization with Inverse Wishart distribution ======================
          # Fraser, p. 55, regularized covariance matrix.
          # see p. 8 of Snoussi(2005), where nu = p + wdf, in numerator
          # nu + n + 1 = (p + wdf) + p + 1 = wdf + 2*p + 1, in denominator
          cov.mat = ( mat.sum + (p + wdf)*diag(p) ) / ( denom.jk + wdf + 2*p + 1 )
          # =======================================================================
          # cat("na in cov.mat:", sum(is.na(cov.mat)), "\n")
          # =============================================================
          # matrix's columns and rows must have the same names, otherwise
          # isSymmetric in dmvnorm complains
          rownames(cov.mat) = paste("X", 1:p, sep="")
          colnames(cov.mat) = rownames(cov.mat)
          #if ( any(is.na(cov.mat)) ) {
          #  warning("na in cov.mat at m-step.")
          #}
          emission$sigma.ll[[i]][[k]] = cov.mat
        } else {
          emission$c.l[[i]][k] = 0
          emission$mu.ll[[i]][[k]] = rep(0, p)
          emission$sigma.ll[[i]][[k]] = diag(p)
        }
      }
    }
    emission
}

#' M-step re-estimation function for multivariate gaussian emission distribution with inverse Wishart regularizer
#'
#' @param x numeric matrix, size T x p, where T is the number of observations, p the dimension of the obs data (columns are features)
#' @param w weight matrix, size T x K, where each row is the weight for a time step, and columns are states.
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return emission slot of Hext object
#' @description Re-estimates the parameters of the multivariate normal emission distribution with inverse Wishart regularization.
#' @details Ref : Snoussi, Mohammad-Djafari (2005), Degeneracy and likelihood penalization
#'      in multivariate gaussian mixture models, preprint.
#'      wdf : Wishart degree of freedom, i.e. wishart df = wdf + p, where p is the dimension of the data. Thus, wdf > -1.
#' @author Horace W Tso
#' @export
mstep.mvnorm.wish = function (x, w, wdf=1) {
    ix = apply(is.na(x), 1, any)
    x = x[!ix, , drop = FALSE]
    w = w[!ix, , drop = FALSE]
    K = ncol(w)
    TT = NROW(x)
    p = NCOL(x)

    w.tot = colSums(w)  # denominator for the reestimation equations, 1 x K
    #if ( any(w.tot < 1e-100) ) {
      # cat("w.tot :", w.tot, "\n")
      #stop("w.tot too small!")
    #}
    emission = list(mu.l=list(), sigma.l=list())
    mat.sum = matrix(0, nrow=p, ncol=p)
    for ( i in 1:K ) {
        xx = w[,i] * x   # (1 x T) x (T x p) = T x p
        mu.bar = colSums(xx) / w.tot[i]  # (1 x p) x scalar = 1 x p
        x.centered = sweep(x, 2, mu.bar)  # T x p
        for ( tt in 1:TT ) {
          crossp = x.centered[tt,] %*% t(x.centered[tt,])
          mat.w = crossp * w[tt, i]  # p x p matrix times a scalar  = p x p
          mat.sum = mat.sum + mat.w   # element by element addition : p x p
        }
        # Regularization using the Inverse Wishart distribution ==============
        # Ref : Snoussi (2005), p. 8, where the inverse scale matrix is to be taken
        # as a diagonal matrix, wish.df is nu, the degree of freedom, p is the
        # dimension of the data n.
        cov.mat = (mat.sum + (p + wdf)*diag(p)) / ( w.tot[i] + wdf + 2*p + 1 )
        # ====================================================================
        # matrix's columns and rows must have the same names, otherwise
        # isSymmetric() complains
        rownames(cov.mat) = paste("X", 1:p, sep="")
        colnames(cov.mat) = rownames(cov.mat)
        emission$mu.l[[i]] = mu.bar
        emission$sigma.l[[i]] = cov.mat
    }
    emission
}

#' M-step re-estimation function for multivariate gaussian emission distribution, no regularization
#'
#' @param x numeric matrix, size T x p, where T is the number of observations, p the dimension of the obs data
#' @param w weight matrix, gamma from EStep C function
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return emission slot of Hext object
#' @description Re-estimates the parameters of the multivariate gaussian emission distribution as part of the EM algorithm for HMM. No regularizer is used.
#' @author Horace W Tso
#' @export
mstep.mvnorm.hext = function (x, wt) {
    ix = apply(is.na(x), 1, any)
    x = x[!ix, , drop = FALSE]
    wt = wt[!ix, , drop = FALSE]
    emission = list(mu.l=list(), sigma.l=list())
    for (i in 1:ncol(wt)) {
        tmp <- cov.wt(x, wt[,i])
        emission$mu.l[[i]] <- tmp$center
        emission$sigma.l[[i]] <- tmp$cov
    }
    emission
}

#' M-step re-estimation function for univarite gaussian emission distribution, no regularization
#'
#' @param x numeric matrix, size T x p, where T is the number of observations, p the dimension of the obs data
#' @param w weight matrix, gamma from EStep C function
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return emission slot of Hext object
#' @description Re-estimates the parameters of the univariate gaussian emission distribution as part of the EM algorithm for HMM. No regularizer is used.
#' @author Horace W Tso
#' @export
mstep.norm.hext = function (x, wt) {
    k = ncol(wt)
    mu = numeric(k)
    sigma = numeric(k)
    for (i in 1:k) {
        tmp = cov.wt(data.frame(x[!is.na(x)]), wt[!is.na(x),i])
        mu[i] = tmp$center
        sigma[i] = tmp$cov
    }
    list(mu.l = mu, sigma.l = sigma)
}

#' M-step re-estimation function for univariate discrete emission distribution
#'
#' @param x numeric matrix, size sum(T) x 1. All sequences stacked onto one column
#' @param w weight matrix, size sum(T) x K, gamma(i, t)
#' @param D number of alphabets in x
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return emission slot of Hext object
#' @description Re-estimates the parameters of discrete emission distribution as part of the EM algorithm for HMM. No regularizer is used.
#' @author Horace W Tso
#' @export
mstep.disc = function(x, w, D) {
  K = NCOL(wt)
  TT = NROW(x)
  w.sum = colSums(w)  # a vector of length K
  if ( length(which(w.sum < 1e-300)) > 0 ) {
    stop("some of the wt column sums are too close to zero.")
  }
  # prob.l is a list of matrices
  prob.l = list()
  # In this univariate case, b.vec is really just a vector; but to be consistent with
  # the usage in generic.density, i have to make it a single column matrix.
  b.vec = matrix(0, nrow=D, ncol=1)
  for ( j in 1:K ) {
    for ( fa in 1:D ) {
      ix = which( x == fa )
      b.vec[fa, 1] = sum(w[ix, j])
    }
    prob.l[[j]] = b.vec / w.sum[j]
  }
  list(prob.l=prob.l, labels=NULL)
}

#' M-step re-estimation function for multivariate discrete emission distribution
#'
#' @param x numeric matrix, size sum(T) x p
#' @param w weight matrix, size T x K
#' @param D number of alphabets in x, a vector of length equal to ncol(x)
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return emission slot of Hext object
#' @description Re-estimates the parameters of discrete emission distribution as part of the EM algorithm for HMM. No regularizer is used.
#' @author Horace W Tso
#' @export
mstep.mvdisc = function(x, w, D)  {
  K = NCOL(wt)
  TT = NROW(x)
  p = NCOL(x)
  wt.sum = colSums(wt)  # a vector of length K
  if ( length(which(wt.sum < 1e-300)) > 0 ) {
    stop("some of the wt column sums are too close to zero.")
  }
  prob.l = list()
  lookup.mat = matrix(0, nrow=max(D), ncol=p)
  for ( j in 1:K ) {
    for ( k in 1:p ) {
      for ( fa in 1:D[k] ) {
        # IMPORTANT NOTE : here i assume the discrete obs take on numeric value
        # from 1 to D[k] for column k of the obs. The next line looks for all
        # occurences of the factor (fa) in obs x[,k],
        ix = which( x[,k] == fa )
        # then sum up the soft weights, i.e. probability of the occurence of fa
        # in x for state j.
        lookup.mat[fa, k] = sum(wt[ix, j])
        # RECALL : wt = P( x_t=fa | s_t=j )
        # it has as many rows as x and as many columns as the no of states
      }
    }
    prob.l[[j]] = lookup.mat / wt.sum[j]
  }
  list(prob.l=prob.l, labels=NULL)
}

#' M-step re-estimation function for univariate beta emission distribution
#'
#' @param x numeric matrix, size sum(T) x p
#' @param w weight matrix, size T x K
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return emission slot of Hext object
#' @description Re-estimates the parameters of univariate beta emission distribution as part of the EM algorithm for HMM. No regularizer is used.
#' @details Needs the solnp function in the Rsolnp package.
#' @author Horace W Tso
#' @export
mstep.beta = function(x, w) {
  require(Rsolnp)
  ix = which(is.na(x))
  if ( length(ix) > 0 ) {
    x = x[!ix]
    w = w[!ix, ,drop = FALSE]
  }
  para.start = c(runif(1,min=0.5,max=7), runif(1,min=0.5,max=7))   # c(shape1, shape2)
  lower.b = c(0.01, 0.01)
  upper.b = c(Inf, Inf)
  K = ncol(wt)
  Shape1 = list()
  Shape2 = list()
  i = 1
  nfail = 0
  while ( i <= K ) {
    sol = try(solnp(para.start, Qaux.beta, x=x, wt=w[,i],
             LB=lower.b, UB=upper.b,
             control=list(trace=FALSE, inner.iter=1000, outer.iter=1000,
             tol=1e-13, delta=1e-13)), FALSE)
    if ( !inherits(sol, "try-error") ) {
      Shape1[[i]] = sol$par[1]
      Shape2[[i]] = sol$par[2]
      i = i + 1
    } else {
      nfail = nfail + 1
      if ( nfail >= 5 ) {
        stop("Too many problems with solnp!")
      }
    }
  }
  list(shape1.l=Shape1, shape2.l=Shape2)
}

#' M-step re-estimation function for multivariate beta emission distribution
#'
#' @param x numeric matrix, size sum(T) x p
#' @param w weight matrix, size T x K
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return emission slot of Hext object
#' @description Re-estimates the parameters of multivariate beta emission distribution as part of the EM algorithm for HMM. No regularizer is used.
#' @details Needs the solnp function in the Rsolnp package.
#' @author Horace W Tso
#' @export
mstep.mvbeta = function(x, wt) {
  require(Rsolnp)
  p = NCOL(x)
  K = NCOL(wt)
  ix = apply(is.na(x), 1, any)
  if ( length(ix) > 0 ) {
    x = x[!ix, ,drop = FALSE]
    wt = wt[!ix, ,drop = FALSE]
  }
  emission = list(shape1.l=list(), shape2.l=list())
  lower.b = c(0.01, 0.01)
  upper.b = c(Inf, Inf)
  h1.mat = matrix(NA, ncol=K, nrow=p)
  h2.mat = matrix(NA, ncol=K, nrow=p)
  for ( j in 1:p ) {
    i = 1
    nfail = 0
    while ( i <= K ) {
      para.start = c(runif(1,min=0.5,max=7), runif(1,min=0.5,max=7))
      sol <- try(solnp(para.start, Qaux.beta, x=x[,j], wt=wt[,i],
               LB=lower.b, UB=upper.b,
               control=list(trace=FALSE, inner.iter=1000, outer.iter=1000,
               tol=1e-13, delta=1e-13)), FALSE)
      if (!inherits(sol,"try-error")) {
        h1.mat[j,i] = sol$par[1]
        h2.mat[j,i] = sol$par[2]
        i = i + 1
      } else {
        nfail = nfail + 1
        if ( nfail >= 5 ) {
          stop("Too many problems with solnp!")
        }
      }
    }
  }
  for ( i in 1:K ) {
    # columns are states
    emission$shape1.l[[i]] = h1.mat[,i]
    emission$shape2.l[[i]] = h2.mat[,i]
  }
  return(emission)
}

#' M-step re-estimation function for univariate gamma emission distribution
#'
#' @param x numeric vector
#' @param w weight matrix, size T x K
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return emission slot of Hext object
#' @description Re-estimates the parameters of univariate gamma emission distribution as part of the EM algorithm for HMM. No regularizer is used.
#' @details Needs the solnp function in the Rsolnp package.
#' @author Horace W Tso
#' @export
mstep.gamma = function(x, w) {
  require(Rsolnp)
  ix = which(is.na(x))
  if ( length(ix) > 0 ) {
    x = x[!ix]
    w = w[!ix, ,drop = FALSE]
  }
  lower.b = c(0.01, 0.01)
  upper.b = c(Inf, Inf)
  K = ncol(w)
  Shape = list()
  Scale = list()
  i = 1
  nfail = 0
  while( i <= K ) {
    para.start = c(runif(1,min=0.5,max=10), runif(1,min=0.1,max=2.5))   # c(shape, scale)
    sol <- try(solnp(para.start, Qaux.gamma, x=x, wt=w[,i],
             LB=lower.b, UB=upper.b,
             control=list(trace=FALSE, inner.iter=1000, outer.iter=1000,
             tol=1e-13, delta=1e-13)), FALSE)
    if ( !inherits(sol, "try-error")) {
       Shape[[i]] = sol$par[1]
       Scale[[i]] = sol$par[2]
       i = i + 1
    } else {
      nfail = nfail + 1
      if ( nfail >= 5 ) {
        stop("Too many problems with solnp!")
      }
    }
  }
  list(shape.l=Shape, scale.l=Scale)
}

#' M-step re-estimation function for multivariate gamma emission distribution
#'
#' @param x numeric vector
#' @param w weight matrix, size T x K
#' @param model HMM model as defined in hmmspec.gen(..)
#' @return emission slot of Hext object
#' @description Re-estimates the parameters of multivariate gamma emission distribution as part of the EM algorithm for HMM. No regularizer is used.
#' @details Needs the solnp function in the Rsolnp package.
#' @author Horace W Tso
#' @export
mstep.mvgamma = function(x, w) {
  require(Rsolnp)
  p = NCOL(x)
  K = NCOL(w)
  ix = apply(is.na(x), 1, any)
  if ( length(ix) > 0 ) {
    x = x[!ix, ,drop = FALSE]
    w = w[!ix, ,drop = FALSE]
  }
  emission = list(shape.l=list(), scale.l=list())
  lower.b = c(0.01, 0.01)
  upper.b = c(Inf, Inf)
  a.mat = matrix(NA, ncol=K, nrow=p)
  s.mat = matrix(NA, ncol=K, nrow=p)
  for ( j in 1:p ) {
    i = 1
    nfail = 0
    while ( i <= K ) {
      para.start = c(runif(1,min=0.5,max=10), runif(1,min=0.1,max=2.5))
      sol <- try(solnp(para.start, Qaux.gamma, x=x[,j], wt=w[,i],
               LB=lower.b, UB=upper.b,
               control=list(trace=FALSE, inner.iter=1000, outer.iter=1000,
               tol=1e-13, delta=1e-13)), FALSE)
      if (!inherits(sol,"try-error")) {
        a.mat[j,i] = sol$par[1]
        s.mat[j,i] = sol$par[2]
        i = i + 1
      } else {
        nfail = nfail + 1
        if ( nfail >= 5 ) {
          stop("Too many problems with solnp!")
        }
      }
    }
  }
  for ( i in 1:K ) {
    # columns are states
    emission$shape.l[[i]] = a.mat[,i]
    emission$scale.l[[i]] = s.mat[,i]
  }
  return(emission)
}


source('2020-08-31-jsa-type-v2-ch3-gender/analysis1/util.r') # util functions

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - functions
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- functions"))

generate_prop_t <- function(country="All", position="All") {

    # Filtering for each country
    if (country != "All") {
        dat <- dat[Country == country]
    }

    # Filtering for position: "first"
    if (position == "First") {
        dat <- dat[auth.i %in% c("1")]
    } else if (position == "Last") {
        dat <- dat[auth.i %in% c("L")]
    } else if (position == "First_s") {
        dat <- dat[auth.i %in% c("1", "S")]
    } else if (position == "Last_s") {
        dat <- dat[auth.i %in% c("S", "L")]
    }

    # count N by gender
    prop <- dat[, .N, by=c("date.n", "describer.gender")]
    prop <- dcast(prop, date.n ~ describer.gender, value.var="N")

    if(!"F" %in% names(prop)) prop$F <- 0
    if(!"M" %in% names(prop)) prop$M <- 0

    # ensure no blank years
    prop <- merge(
        prop, data.frame(date.n=min(prop$date.n):max(prop$date.n)),
        all.x=T, all.y=T, by="date.n"
    )

    prop[is.na(prop$F)]$F <- 0
    prop[is.na(prop$M)]$M <- 0
    prop[is.na(prop$U)]$U <- 0

    # tabulate proportion
    prop$prop_F <- ifelse(prop$M + prop$F == 0, 0, prop$F / (prop$M + prop$F))
    prop$N <- prop$F + prop$M

    if (sum(prop$F) >0) {
        # filter data to year with at least 1 female
        first_year_female <- min(prop[F>0]$date, na.rm=T)
        prop <- prop[date.n>=first_year_female]
        prop$date <- prop$date.n - first_year_female

        # rename data
        names(prop)[which(names(prop) == 'F')] <- "nFemales"
        names(prop)[which(names(prop) == 'M')] <- "nMales"
        names(prop)[which(names(prop) == 'N')] <- "n"

        # include more than 0 to fit graph
        return(prop[n>0])

        # output looks like this
        #     date.n nFemales nMales U prop_F  n date
        # 1:   1996        1      1 0  0.500  2    0
        # 2:   1997        0      5 0  0.000  5    1
        # 3:   1998        1      0 0  1.000  1    2
        # 4:   1999        0      8 0  0.000  8    3
        # 5:   2000        0      8 0  0.000  8    4

    } else {
        print(paste0("No female taxonomist in dataset for ", country))
        return(NULL)
    }

}

generate_prop_t_tax <- function(country="All") {

    # Filter data by country
    if (country != "All") {
        auth_years <- auth_years[Country == country]
    }

    # Get male female taxonomist ratio
    prop <- auth_years[,
        list(N = length(full.name.of.describer)),
        by=c("years", "describer.gender")
    ]

    prop <- dcast(prop, years ~ describer.gender, value.var="N")

    prop <- data.table(merge(
        data.frame(years=min(prop$years):max(prop$years)),
        prop, by="years", all.x = T, all.y = F
    ))

    prop[is.na(prop)] <-  0
    prop <- prop[years <= 2018,]
    prop$N <- prop$F + prop$M
    prop$prop_F <- prop$F / prop$N

    if (any(names(prop) %in% "F")) {

        first_year_female <- min(prop[F > 0,]$year)
        prop <- prop[years >= first_year_female,]
        prop$date <- prop$years - first_year_female

        prop$F <- as.integer(prop$F)
        prop$M <- as.integer(prop$M)
        prop$N <- as.integer(prop$N)

        names(prop)[which(names(prop) == 'F')] <- "nFemales"
        names(prop)[which(names(prop) == 'M')] <- "nMales"
        names(prop)[which(names(prop) == 'N')] <- "n"
        names(prop)[which(names(prop) == 'years')] <- "date.n"

        # include more than 0 to fit graph
        return(prop[n>0])

        # output looks like this
        #     date.n nFemales nMales U  n    prop_F date
        # 1:   1996        1      5 0  6 0.1666667    0
        # 2:   1997        1      7 0  8 0.1250000    1
        # 3:   1998        2      7 0  9 0.2222222    2
        # 4:   1999        2      7 0  9 0.2222222    3

    } else {
        print("No female taxonomist in dataset.")
        return(NULL)
    }

}

main <- function(country="All", position="All", prop) {

    print(paste0(Sys.time(), "-- Optimizing for graphing purposes"))

    # Optimize c and t based on data
    res <- find.response.variables(prop)

    print(paste0(Sys.time(), "-- Resampling data"))

    # For generating confidence intervals
    # reshape data for sampling
    prop_p <- melt(
        prop, id.vars=c("date"), measure.vars=c("nFemales", "nMales")
    )

    names(prop_p) <- c("date", "gender", "count")

    # Get row index for resampling
    n.authors <- sum(prop_p$count)
    probabilities <- prop_p$count / n.authors
    replicates <- 1000

    resampled.data <- sample(
        1:nrow(prop_p), size = n.authors * replicates,
        replace = T,
        prob = probabilities # sampling weighted by N authors
    )

    # Get frequency (=count)
    resampled.data <- data.table(table(
        factor(resampled.data, levels = 1:nrow(prop_p)),
        rep(1:replicates, each = n.authors)
    )) # tabulated frequencies after resampling weighted by N authors

    names(resampled.data)[which(names(resampled.data)=="V1")] = "row"
    names(resampled.data)[which(names(resampled.data)=="V2")] = "replicate_id"
    names(resampled.data)[which(names(resampled.data)=="N")] = "count"
    resampled.data$row <- as.numeric(resampled.data$row)

    # Get resampled rows with associated "information" (date and gender)
    resampled.data <- data.table(data.frame(
        date = as.numeric(prop_p$date[resampled.data$row]),
        gender = prop_p$gender[resampled.data$row],
        replicate_id = as.numeric(resampled.data$replicate_id),
        count = as.numeric(resampled.data$count)
    ))

    # Summarize resampled data
    resampled.data <- dcast(
        resampled.data, date + replicate_id ~ gender, value.var="count"
    )

    resampled.data <- resampled.data[,
        list(nFemales = sum(nFemales), nMales = sum(nMales)),
        by=c("replicate_id", "date")
    ]

    resampled.data$n <- resampled.data$nFemales + resampled.data$nMales

    print(paste0(Sys.time(), "-- Generating confidence intervals"))

    # Get response variables from each replicate
    bootstrap_estimates <- rbindlist(lapply(1:replicates, function(i) {
        resampled <- resampled.data[resampled.data$replicate_id == i,]
        find.response.variables(resampled)
    }))

    check_na <- function(x) {
        table(is.na(x))
    }

    # Calculate confidence intervals
    CIs_ratio <- as.numeric(quantile(
        bootstrap_estimates$gender.ratio.at.present,
        probs = c(0.025 , 0.975)
    ))

    CIs_dt <- as.numeric(quantile(
        bootstrap_estimates$current.rate.of.change,
        probs = c(0.025, 0.975)
    ))

    # Tabulate parity year
    baseline_yr <- min(prop$date.n)

    if(is.numeric(bootstrap_estimates$parity.year)) {

        parity.years <- as.numeric(bootstrap_estimates$parity.year)
        # may generate some NAs

        parity.years <- parity.years[!is.na(parity.years)]

        parity.year <- # ignore text with na.rm=T
            median(parity.years, na.rm=T) + baseline_yr - CURRENT_YEAR

        CIs_yr <- quantile(parity.years, probs = c(0.025, 0.975))
        CIs_yr <- CIs_yr + baseline_yr - CURRENT_YEAR
        parity.year[parity.year < 0] <- 0; CIs_yr[CIs_yr < 0] <- 0

    } else {

        # if not going to hit parity sometimes, pick the mode non-parity outcome
        parity.year <- Mode(bootstrap_estimates$parity.year)
        CIs_yr <- c(NA, NA)

    }

    gender.ratio.at.present <- bootstrap_estimates$gender.ratio.at.present
    current.rate.of.change <- bootstrap_estimates$current.rate.of.change

    summary <- data.frame(
        country = country, position = position, n.authors = n.authors,

        gender.ratio.at.present = median(gender.ratio.at.present),
        low.CI.1 = CIs_ratio[1], up.CI.1 = CIs_ratio[2],

        current.rate.of.change = median(current.rate.of.change),
        low.CI.2 = CIs_dt[1], up.CI.2 = CIs_dt[2],

        years.to.parity = parity.year,
        low.CI.3 = CIs_yr[1], up.CI.3 = CIs_yr[2],

        r=res$r, c=res$c, stringsAsFactors = F
    )

    return(list(summary=summary, bootstrap_estimates=bootstrap_estimates))
}

save_graph <- function(
    dir_output, country, position, prop, r, c, parity.year, type
) {

    print(paste0(Sys.time(), "-- Plotting data"))
    baseline_yr <- min(prop$date.n)
    max_y <- 70

    # determine x-axis max value
    max_predict_year <- as.integer((max(prop$date.n) - min(prop$date.n)) * 1.75)
    is_parity_year_numeric <- !is.na(as.numeric(parity.year))

    if (is_parity_year_numeric) {

        # normalise to baseline
        parity.year <- as.numeric(parity.year) + CURRENT_YEAR - baseline_yr

        max_predict_year <- ifelse(
            parity.year > max_predict_year,
            parity.year, max_predict_year
        )

    }

    # get confidence intervals
    cols <- c('date.n', 'prop_F', 'n', 'nFemales', 'nMales')
    prop_overlay <- cbind(prop, get.CIs(prop$nFemales, prop$nMales))

    # merge to template (there will be NAs)
    prop_template <- data.frame(
        yrs_fr_baseline = 0:max_predict_year + baseline_yr,
        predicted = sapply(0:max_predict_year, pfunc, r=r, c=c)
    )

    prop_overlay <- merge(
        prop_template, prop_overlay,
        by.x="yrs_fr_baseline", by.y="date.n",
        all.x=T, all.y=F
    )

    prop_overlay$predicted <- round(prop_overlay$predicted*100, 5)
    prop_overlay$prop_F <- round(prop_overlay$prop_F*100, 5)

    # y axis title
    if(type=="pub"){

        y_main <- "Proportion of female-authored species (%),\n"

        y_axis_title <- ifelse(country=="All",
            paste0(y_main, tolower(position), " authors \n"),
            paste0(y_main, tolower(position), " authors for ", country, "\n")
        )

    } else if (type=="tax"){

        y_main <- "Percentage of female describers (%)\n"

        y_axis_title <- ifelse(
            country=="All",
            paste0(y_main), paste0(y_main, "for ", country, "\n")
        )

    }

    # Plot
    p1 <- ggplot() +
        # geom_errorbar(
        #     data = prop_overlay, colour = "darkgrey", width = 0,
        #     aes(x = date.n, ymin = lowerCI, ymax = upperCI)
        # ) +

        # real data
        geom_point(data = prop_overlay, aes(x = yrs_fr_baseline, y = prop_F), size=.8) +

        # fitted data
        geom_line(data = prop_overlay, aes(x = yrs_fr_baseline, y = predicted), size=.8) +

        # thresholds
        geom_hline(yintercept = 45, linetype="dotted", size=0.8, color="red")  +
        geom_hline(yintercept = 55, linetype="dotted", size=0.8, color="red")  +

        xlab("\nYear") + ylab(y_axis_title) + ylim(c(0, max_y)) +
        theme_minimal(base_size = 10)

    # Plot parity year if it exists
    if (is_parity_year_numeric) { # plot numeric value

        parity_annotation <- toString(parity.year + baseline_yr)

        p1 <- p1 + geom_vline(
            xintercept= parity.year + baseline_yr, linetype="dashed",
            size=.8, color="black"
        ) +
        # annotate(
        #     "text", x=parity.year + baseline_yr, y = 10, label=parity_annotation
        # ) +
        geom_label(
            aes(
                x = parity.year + baseline_yr, y = 10, label = parity_annotation
            ), fill = "white", label.size=0
        )

    } else { # else plot text

        print(parity.year)

        p1 <- p1 + geom_label(
            aes(
                x = max(prop_overlay$yrs_fr_baseline),
                y = max_y, label = parity.year
            ), fill = "white", label.size=0, vjust="inward", hjust="inward"
        )

    }

    # save graph
    plot_filepath <- paste0(dir_output, country, "-", position, ".png")

    ggsave(
        plot_filepath, plot=p1, width = 14, height = 7, dpi = 300,
        units = "cm", device='png'
    )

}

run_specific_scenario <- function(
    country="All", position="All", dir_output, type="pub"
) {

    print("#################################")
    print(paste0(
        "Running for '", country,
        "' at position '", position, "' (", type, ")."
    ))

    tryCatch ({

        if (type=="pub") { # for publication (species description)
            prop_t  <- generate_prop_t(country=country, position=position)
        } else if (type=="tax") { # for taxonomists
            prop_t <- generate_prop_t_tax(country=country)
        }

        if (!is.null(prop_t)) {
            output <- main(country = country, position = position, prop_t)

            save_graph(
                dir_output, country=country, position=position, prop_t,
                output$summary$r, output$summary$c,
                output$summary$years.to.parity, type
            )

            output
        }

    }, error = function(e) {print(e)})
}


library(raster)
library(virtualspecies)
library(xgboost)
library(dismo)
library(randomForest)
library(dplyr)
library(tidyr)
library(purrr)
library(mlr)
library(sf)
predict = stats::predict
extract = raster::extract
select = dplyr::select

# making a function for coordinates() w/in a pipe
coordinates_iP = function(df, crs_in){
  coordinates(df) = ~x+y
  sp::proj4string(df) = crs_in
  return(df)
}

#----Environmental covariate data----
worldclim = getData("worldclim", var = "bio", res = 10) %>%
  .[[c("bio1", "bio12")]]

wc = cbind(coordinates(worldclim), values(worldclim)) %>%
  as.data.frame() %>%
  coordinates_iP(df = ., crs_in = CRS(st_crs(4326)$proj4string))

#----Response functions----
params = formatFunctions(
  bio1 = c(fun = 'dnorm', mean = 250, sd = 50),
  bio12 = c(fun = 'dnorm', mean = 4000, sd = 2000)
)

#----Virtual species----
vsp = generateSpFromFun(
  raster.stack = worldclim,
  parameters = params,
  plot = TRUE
)

#----Presence-absence distribution----
pa = convertToPA(vsp, species.prevalence = 0.05, plot = TRUE)

#----Presence-absence sampling----
pa.pts = sampleOccurrences(
  pa,
  n = 250,
  sample.prevalence = 0.5,
  type = "presence-absence"
)

pa.pts.sp = pa.pts %>%
  .["sample.points"] %>%
  as.data.frame() %>%
  .[,c(1,2)] %>%
  select(x = 1, y=2) %>%
  SpatialPoints(., proj4string = crs(wc))

#----Extract enviornmental covariates----
lc = raster::extract(worldclim, pa.pts.sp@coords, sp = T) %>%
  as.data.frame() %>%
  mutate(x = pa.pts.sp@coords[,1]) %>%
  mutate(y = pa.pts.sp@coords[,2] ) %>%
  select(3, 4, 1, 2)

#----Assosciate covariates----
df = cbind(lc[,c(1,2)], occupied = as.factor(pa.pts$sample.points[,c(4)]), lc[,c(3,4)])

#----Split train/test----
# Random 60/40 split
samp = sample(nrow(df), round(0.6 * nrow(df)))
df$data = "train"
df[-samp,"data"] = "test"

train = df[df$data == "train", names(df) != "data"]
test = df[df$data == "test", names(df) != "data"]

#----XGBoost in MLR----
trainTask = makeClassifTask(data = train, target = "occupied", positive = 1)
testTask = makeClassifTask(data = test, target = "occupied")

set.seed(1)
# Create an xgboost learner that is classification-based and outputs labels (as opposed to probabilities)
xgb_learner <- makeLearner(
  "classif.xgboost",
  predict.type = "prob",
  par.vals = list(
    objective = "binary:logistic",
    eval_metric = "error",
    nrounds = 200
  )
)

# Create a model
xgb_model = train(xgb_learner, task = trainTask)

# Global prediction
newdata.xgb = as.data.frame(wc)
result = stats::predict(xgb_model, newdata = newdata.xgb)

# convert prediction to raster
xgb.pred.raster = worldclim$bio1
values(xgb.pred.raster) = result$data$response
values(xgb.pred.raster)[is.na(values(worldclim$bio1))] = NA

#-----Plotting the model----
image(xgb.pred.raster, main = "True vs Modeled",
      col = c("gray90", "red"),
      xaxs = "i", xaxt = 'n', yaxt = 'n', ylab = "", xlab = "",
      ann = T, asp = 1, axes = FALSE)
image(pa$pa.raster, main = "True vs Modeled",
      col = "#00A600FF", zlim = c(1,2), add=T,
      xaxs = "i", xaxt = 'n', yaxt = 'n', ylab = "", xlab = "",
      ann = T, asp = 1, axes = FALSE)

#----compare similarlities----
v_true = na.omit(as.numeric(values(pa$pa.raster)))
v_mod = na.omit(as.numeric(values(xgb.pred.raster)))

vtab = table(v_true, v_mod)
(vgood = (vtab[1,1] + vtab[2,2])/sum(vtab))

#----AUC score----
pred1 = predict(xgb_model, testTask)
perfMes = generateThreshVsPerfData(pred1, measures = list(fpr, tpr, mmce))
plotROCCurves(perfMes)

mlr::performance(pred1, mlr::auc)