## Starting

# Clean environment
rm(list=ls())
gc()
# Disable scientific notation
options(scipen=999)
# Change prompt
options(prompt="CHURN_TC> ", continue=" ")

# Load utilities functions (change wd, auxiliary scripts...)
source("Scripts/utiles.R")
set_environment()

library(Matrix)
library(rsample)
library(breakDown)
library(cowplot)
library(scales)
library(MASS)
library(stringi)

# library(randomForest)
# h2o.no_progress()
h2o.init()

master_path <- "data/master"
models_path <- "modelos"

train_months <- c("2018-07-01", "2018-10-01")
dev_month <- c("2018-11-01", "2018-12-01")
test_month <- c("2019-01-01")

# set random seed for reproducibility
set.seed(5)

##### model meta datos ####
print("Making model's fold")
gc()
model_alias_modeling <-
  paste0("churn_v1_", today() %>% format(., "%Y%m%d"))
# model product folder
model_alias_modeling <-
  os.path.join(models_path, model_alias_modeling)
dir.create(model_alias_modeling)

# models folder
models_folder <-
  os.path.join(model_alias_modeling, "models_library")
dir.create(models_folder)

# plots folder
plots_folder <- os.path.join(model_alias_modeling, "plots")
dir.create(plots_folder)

##### load datos ####
master_files <- list.files(master_path, full.names = T)
datos_list <- list()
for(i in 1:length(master_files)){
  print(paste("Loading datos from", master_files[i]))
  datos_list[[i]] <- readRDS(master_files[i])
}

datos <- rbindlist(datos_list, use.names = T, fill = T)
rm(datos_list)
gc()

###### Ultima limpieza previa######

print(nrow(datos))
datos <- datos[!is.na(crm_antiguedad)]
datos <- datos[!is.na(antiguedad)]
print(nrow(datos))

# datos[, crm_estrato := factor(crm_estrato, levels = c("1","2","3","4","5","6"))]

datos[, crm_estrato := paste0("estr_", crm_estrato)]
datos[, crm_estrato := order(crm_estrato, levels = c(paste0("estr_", 1:6)))]

datos[, target := ifelse(churn_voluntario_futuro == "STOCK", 0, 1)]
datos[, churn_voluntario_futuro := NULL]

datos[, ciclo := NULL]
data <- copy(datos)
datos <- copy(data)

#Sample
index <- sample(1:nrow(datos), .N*(0.2))
datos <- datos[index]
rm(index)
gc()

#Verificación de NA's
gg_miss_fct(datos, periodo)

# divinding master table
dev <- datos[periodo >=  dev_month[1] & periodo <=  dev_month[2]]
master <- datos[periodo >= train_months[1] &
                 periodo <= train_months[2] ]
test <- datos[periodo == test_month]

cores <- parallel::detectCores() - 1

##### Plots maker ####
datos_plot <- copy(datos)
datos_plot[, target := factor(target)]
print(" making products plots")
name_f <- "per_target"
p <- datos_plot %>%
  dplyr::group_by(target) %>%
  dplyr::summarise(Count = n()) %>%
  dplyr::mutate(percent = prop.table(Count) * 100) %>%
  ggplot(aes(reorder(target,-percent), percent), fill = target) +
  geom_col(fill = c("#FC4E07", "#E7B800")) +
  geom_text(
    aes(label = sprintf("%.2f%%", percent)),
    hjust = 0.01,
    vjust = -0.5,
    size = 3
  ) +
  theme_bw() +
  xlab(" Tarjetas canceladas voluntariamente") +
  ylab("Porcentaje") +
  ggtitle(paste("Porcentaje agregado de tarjeta de crédito  \n con cancelación voluntaria a dos meses"))
ggsave(plot = p,
       file = os.path.join(plots_folder, paste0(name_f, ".png")))

name_f <- "per_target_mes"
plot_base <- datos_plot %>%
  dplyr::group_by(periodo, target) %>%
  dplyr::summarise(Count = n())%>%
  dplyr::mutate(percent = prop.table(Count)*100) %>% data.table()

p <-
  ggplot(plot_base[target == 1], aes(periodo, percent), fill = periodo) +
  geom_col(fill = "#FC4E07") +
  geom_text(
    aes(label = sprintf("%.2f%%", percent)),
    hjust = 0.5,
    vjust = 1,
    size = 3,
    angle = -45
  ) +

  theme_bw() +
  xlab("Meses") +
  ylab("Porcentaje") +
  ggtitle("Porcentaje agregado de tarjeta de crédito  \n con cancelación voluntaria a dos meses por mes")
ggsave(plot = p,
       file = os.path.join(plots_folder, paste0( name_f, ".png")))

name_f <- "sexo"
x_lab <- "Sexo"
p <- datos_plot %>%
  dplyr::group_by(crm_genero, target) %>%
  dplyr::summarise(Count = n()) %>%
  dplyr::mutate(percent = prop.table(Count) * 100) %>% data.table()
p <- p[target == 1] %>%
  ggplot(aes(x = crm_genero, y = percent, fill = target)) +
  geom_bar(stat = "identity") + geom_text(aes(
    x = crm_genero,
    y = percent,
    label = paste0(round(percent, 2), "%")
  ), size = 4) + theme_bw() +
  xlab(x_lab) +
  ylab("Porcentaje") +
  ggtitle(paste("Porcentaje de tarjetas canceladas voluntariamente  por", tolower(x_lab)))

ggsave(plot = p,
       file = os.path.join(plots_folder, paste0(name_f, ".png")))

name_f <- "cuo_mano"
y_lab <- "Cuota de manejo"

p <-
  ggplot(datos_plot, aes(y = cuomano, x = "", fill = target)) +
  geom_boxplot() +
  theme_bw() +
  xlab(" ") +
  ylab(y_lab) +
  scale_y_continuous(labels = comma, limits = quantile(datos_plot[, get("cuomano")], c(0.1, 0.9))) +
  ggtitle(paste("Porcentaje de tarjetas canceladas voluntariamente por", tolower(y_lab)))

ggsave(plot = p,
       file = os.path.join(plots_folder, paste0(name_f, ".png")))

rm(datos_plot)
gc()

##### model fase #####
### separating variabbles ###

id_variables <-
  c("cod_int", "nro_id" , "periodo", "target")

crm_vars <-
  names(master)[names(master) %!in% c(id_variables)]
crm_vars <- grep("crm_", crm_vars, value = T)

tc_vars <- names(master)[names(master) %!in% c(id_variables, crm_vars)]

categorical_cols <-
  c(crm_vars[sapply(master[, mget(crm_vars)], is.factor)],
    tc_vars[sapply(master[, mget(tc_vars)], is.factor)])

numeric_cols <- names(master)[names(master) %!in% c(id_variables, categorical_cols)]

print("One hot encoding")
# one-hot encode the categorical features
final_cols <- c("target",categorical_cols, numeric_cols)

#### making xgb data ####
master_dmatrix <- master[, mget(final_cols)]
master_dmatrix <-
  sparse.model.matrix(target ~ . - 1, data = master_dmatrix)

dev_dmatrix <- dev[, mget(final_cols)]
dev_dmatrix <-
  sparse.model.matrix(target ~ . - 1, data = dev_dmatrix)

model_cols <- master_dmatrix@Dimnames[[2]]

model_cols <- tolower(model_cols)
model_cols <-
  stri_trans_general(model_cols,"Latin-ASCII")
model_cols <- tm::removePunctuation(model_cols)
model_cols <- gsub(" ", "", model_cols, fixed = TRUE)

master_dmatrix@Dimnames[[2]] <- model_cols
dev_dmatrix@Dimnames[[2]] <- model_cols

# separate target
target_train_dmatrix <-
  as(data.matrix(master$target), 'dgCMatrix')
target_dev_dmatrix <-
  as(data.matrix(dev$target), 'dgCMatrix')

dtrain <-
  xgb.DMatrix(data = master_dmatrix, label = target_train_dmatrix)
ddev <- xgb.DMatrix(data = dev_dmatrix, label = target_dev_dmatrix)

gc()
rm(target_dev_dmatrix, target_train_dmatrix)
watchlist <- list(train = dtrain, test = ddev)
# # set random seed for reproducibility
set.seed(1104)

##### training xgboost model ####
# there are two ways of trainging xgboost models for a binary clasification
# problems: using AUC of precision-recall curve or AUC of ROC. The firsth is
# more usefull for unbalance classes as capture a the clients whose getting
# financial product month through month.

#### xgboost maximizing Precision and recall AUC ####
print("Training xgboost model using precision-recall curve")
xgb.parameters <- list(booster = "gbtree",
                       objective = "binary:logistic",
                       eval_metric = "aucpr",
                       early_stoping_round = 30,
                       nrounds = 500)

model_xgb_pr <- xgb.train(
  data = dtrain,
  nround = xgb.parameters$nrounds,
  params = xgb.parameters,
  early_stopping_rounds = xgb.parameters$early_stoping_round,
  verbose = 1 ,
  nthread = cores,
  watchlist = watchlist

)
xgb.save(model_xgb_pr, os.path.join(models_folder, "xgb_pr.model"))

# xgboost maximizing AUC of ROC

print("Training xgboost model using ROC curve")

xgb.parameters <- list(booster = "gbtree",
                       objective = "binary:logistic",
                       eval_metric = "auc",
                       early_stoping_round = 30,
                       nrounds = 500)

model_xgb_auc <- xgb.train(
  data = dtrain,
  nround = xgb.parameters$nrounds,
  params = xgb.parameters,
  early_stopping_rounds = xgb.parameters$early_stoping_round,
  verbose = 1 ,
  nthread = cores,
  watchlist = watchlist)

xgb.save(model_xgb_auc, os.path.join(models_folder, "xgb_auc.model"))

data_id <- data.table(var = c("model_alias",
                              "model_type",
                              "train_months_since",
                              "train_months_to",
                              "dev_month",
                              "test_month"),
                      value = c(model_alias_modeling,
                                model_type_modeling,
                                train_months[1],
                                train_months[2],
                                dev_month,
                                test_month)
)

fwrite(data_id, os.path.join(model_alias_modeling, "model_id.csv"))

save(
  final_cols,
  model_cols,
  master_dmatrix,
  dev_dmatrix,
  master,
  dev,
  file = os.path.join(model_alias_modeling, paste0(products[i], "_xgb_objects.RData"))
)

##### data preparation for other models ####

#### convert to h2o object ####
# class(master$target)
#
# master_h2o <-
#   model.matrix(target ~ . - 1, data = master[, mget(final_cols)])
#
# dev_h2o <-
#   model.matrix(target ~ . - 1, data = dev[, mget(final_cols)])
#
# master_h2o <- data.table(target = master$target, master_h2o)
# dev_h2o <- data.table(data.table(target = dev$target, dev_h2o))
#
# names(master_h2o) <- tolower(names(master_h2o))
# names(master_h2o) <-
#   stri_trans_general(names(master_h2o),"Latin-ASCII")
# names(master_h2o) <- tm::removePunctuation(names(master_h2o))
# names(master_h2o) <- gsub(" ", "", names(master_h2o), fixed = TRUE)
# names(dev_h2o) <- names(master_h2o)

master[, target := as.factor(target)]
master_h2o <- as.h2o(master)
dev_h2o <- as.h2o(dev)
test_h2o <- as.h2o(test)
y <- "target"
x <- setdiff(names(master_h2o), y)

##### Training h2o regression  ####

print("Trainig h2o models")
# elastic net model
glm <- h2o.glm(
  x = x,
  y = y,
  training_frame = master_h2o,
  validation_frame = dev_h2o,
  family = "binomial",
  seed = 123
)

h2o.saveModel(object = glm, path = models_folder, force = TRUE)
h2o.saveModelDetails(object = glm,
                     path = models_folder,
                     force = TRUE)

# random forest model
rf <- h2o.randomForest(
  x = x,
  y = y,
  training_frame = master_h2o,
  validation_frame = dev_h2o,
  ntrees = 500,
  stopping_metric = "AUC",
  stopping_rounds = 10,
  stopping_tolerance = 0.005,
  seed = 123
)

h2o.saveModel(object = rf, path = models_folder, force = TRUE)
h2o.saveModelDetails(object = rf,
                     path = models_folder, force = TRUE)

# # gradient boosting machine model
gbm <-  h2o.gbm(
  x = x,
  y = y,
  training_frame = master_h2o,
  validation_frame = dev_h2o,
  ntrees = 1000,
  stopping_metric = "AUC",
  stopping_rounds = 10,
  stopping_tolerance = 0.005,
  seed = 123
)

h2o.saveModel(object = gbm, path = models_folder, force = TRUE)
h2o.saveModelDetails(object = gbm,
                     path = models_folder, force = TRUE)

# model performance
h2o.auc(glm, valid = TRUE)
#[1] 0.6913626
h2o.auc(rf, valid = TRUE)
#[1] 0.6550603
h2o.auc(gbm, valid = TRUE)
#[1] 0.7076738

source("Scripts/performance.R")

pgorro <- predict(glm, type = "response", newdata = test_h2o)
ROC(pgorro = pgorro, master_test = test)
Grafica_uplift(pgorro = pgorro, master_test = test_h2o)
Grafica_recall(pgorro = pgorro, master_test = test_h2o)
Grafica_precision(pgorro = pgorro, master_test = test_h2o)

##### Predicciones ####
# xgb_auc_preds_master <-  predict(model_xgb_auc, master_dmatrix)
# xgb_auc_preds_dev <-  predict(model_xgb_auc, dev_dmatrix)
#
# xgb_pr_preds_master <-  predict(model_xgb_pr, master_dmatrix)
# xgb_pr_preds_dev <-  predict(model_xgb_pr, dev_dmatrix)

glm_preds_master <- h2o.predict(glm, master_h2o) %>% as.data.frame()
glm_preds_dev <- h2o.predict(glm, dev_h2o) %>% as.data.frame()

rf_preds_master <- h2o.predict(rf, master_h2o) %>% as.data.frame()
rf_preds_dev <- h2o.predict(rf, dev_h2o) %>% as.data.frame()

gbm_preds_master <- h2o.predict(gbm, master_h2o) %>% as.data.frame()
gbm_preds_dev <- h2o.predict(gbm, dev_h2o) %>% as.data.frame()

glm_performance_master <- h2o.performance(glm)
glm_performance_dev <- h2o.performance(glm, dev_h2o)

rf_performance_master <- h2o.performance(rf)
rf_performance_dev <- h2o.performance(rf, dev_h2o)

gbm_performance_master <- h2o.performance(gbm)
gbm_performance_dev <- h2o.performance(gbm, dev_h2o)

save(
  glm_performance_master,
  rf_performance_master,
  gbm_performance_master,
  glm_performance_dev,
  rf_performance_dev,
  gbm_performance_dev,
  file = os.path.join(model_alias_modeling, paste0 ("_performance.RData"))
)
rm(
  glm_performance_master,
  rf_performance_master,
  gbm_performance_master,
  glm_performance_dev,
  rf_performance_dev,
  gbm_performance_dev
)
gc()
# exportar probabilidades
master[, ':=' (
  glm_pred = glm_preds_master$p1,
  rf_pred = rf_preds_master$p1,
  gbm_pred = gbm_preds_master$p1
  #xgb_auc_pred = xgb_auc_preds_master,
  #xgb_pr_pred = xgb_pr_preds_master
)
]

dev[, ':=' (
  glm_pred = glm_preds_master$p1,
  rf_pred = rf_preds_master$p1,
  gbm_pred = gbm_preds_master$p1
  #xgb_auc_pred = xgb_auc_preds_master,
  #xgb_pr_pred = xgb_pr_preds_master
)]

fwrite(master[, .(llave, periodo, target, xgb_auc_pred, xgb_pr_pred,
                  glm_pred, rf_pred, gbm_pred)],
       os.path.join(model_alias_modeling, "pred_train.csv"))
fwrite(dev[, .(llave, periodo, target, xgb_auc_pred, xgb_pr_pred,
               glm_pred, rf_pred, gbm_pred)],
       os.path.join(model_alias_modeling, "pred_dev.csv"))

rm(
  glm_preds_master,
  rf_preds_master,
  gbm_preds_master,
  xgb_auc_preds_master,
  xgb_pr_preds_master,
  glm_preds_dev,
  gbm_preds_dev,
  rf_preds_dev,
  xgb_auc_preds_dev,
  xgb_pr_preds_dev
  )

gc()
# Important variables
# importance_matrix <-
#   xgb.importance(feature_names =  model_cols, model = model_xgb_auc)
# fwrite(importance_matrix,
#        os.path.join(
#          model_alias_modeling,"xgb_auc_important_variables.csv"
#        ))

# importance_matrix <-
#   xgb.importance(feature_names =  model_cols, model = model_xgb_pr)
# fwrite(importance_matrix,
#        os.path.join(
#          model_alias_modeling,"xgb_pr_important_variables.csv"
#        ))

variable_importance_rf <- h2o.varimp(rf)
variable_importance_rf <- data.table(variable_importance_rf)
fwrite(variable_importance_rf,
       os.path.join(
         model_alias_modeling,"rf_important_variables.csv"
       ))

# build explainers on dev data

# create custom predict function
pred <- function(model, newdata)  {
  results <- as.data.frame(h2o.predict(model, as.h2o(newdata)))
  return(results[[2L]])
}
# elastic net explainer
explainer_glm <- explain(
  model = glm,
  data = as.data.frame(dev_h2o)[, -1],
  y = as.vector(as.numeric(dev$target)),
  predict_function = pred,
  label = "h2o glm"
)

# random forest explainer
explainer_rf <- explain(
  model = rf,
  data = as.data.frame(dev_h2o)[, -1],
  y = as.vector(as.numeric(dev$target)),
  predict_function = pred,
  label = "h2o rf"
)

# GBM explainer
explainer_gbm <- explain(
  model = gbm,
  data = as.data.frame(dev_h2o)[, -1],
  y = as.vector(as.numeric(dev$target)),
  predict_function = pred,
  label = "h2o gbm"
)

explainer_xgb_auc <- explain(
  model_xgb_auc,
  data = dev_dmatrix,
  y = dev$target == 1,
  label = "xgboost auc"
)
explainer_xgb_pr <- explain(
  model_xgb_pr,
  data = dev_dmatrix,
  y = dev$target == 1,
  label = "xgboost pr"
)

save(
  explainer_glm,
  explainer_rf,
  explainer_gbm,
  explainer_xgb_auc,
  explainer_xgb_pr,
  file = os.path.join(model_alias_modeling, paste0(products[i], "_explainers.RData"))
)

rm(
  master,
  master_dmatrix,
  master_h2o
)
gc()
##### residual analysis ####
resids_glm <- model_performance(explainer_glm)
resids_rf  <- model_performance(explainer_rf)
resids_gbm <- model_performance(explainer_gbm)
resids_xgb_auc <- model_performance(explainer_xgb_auc)
resids_xgb_pr <- model_performance(explainer_xgb_pr)

save(
  resids_glm,
  resids_rf,
  resids_gbm,
  resids_xgb_auc,
  resids_xgb_pr,
  file = os.path.join(model_alias_modeling, paste0(products[i], "_resids.RData"))
)
rm(
  resids_glm,
  resids_rf,
  resids_gbm,
  resids_xgb_auc,
  resids_xgb_pr
)
rm(
  explainer_glm,
  explainer_rf,
  explainer_gbm,
  explainer_xgb_auc,
  explainer_xgb_pr
)
gc()
## remake explainers using p1 probability
# create custom predict function
pred <- function(model, newdata)  {
  results <- as.data.frame(h2o.predict(model, as.h2o(newdata)))
  return(results[[3L]])
}
# elastic net explainer
# random forest explainer
explainer_rf <- explain(
  model = rf,
  data = as.data.frame(dev_h2o)[, -1],
  y = as.vector(as.numeric(dev$target)),
  predict_function = pred,
  label = "h2o rf"
)

explainer_xgb_auc <- explain(
  model_xgb_auc,
  data = dev_dmatrix,
  y = dev$target == 1,
  label = "xgboost auc"
)

unique(datos$crm_estrato
       )


library(cellrangerRkit)
context('Concatenation')

pipestance_path <- system.file("extdata", "test_pipestance", package="cellrangerRkit")

filt_gbm <- load_cellranger_matrix(pipestance_path, barcode_filtered=T)

print("loaded")
gbm1 <- filt_gbm[,1:30]
gbm2 <- filt_gbm[,31:60]
gbm3 <- filt_gbm[,61:114]

big_gbm <- concatenate_gene_bc_matrices(list(gbm1, gbm2, gbm3))

test_that("concatenated gbm has correct content", {
  expect_true(nrow(big_gbm) == nrow(filt_gbm))
  expect_true(all(fData(big_gbm) == fData(filt_gbm)))
  expect_true(ncol(big_gbm) == ncol(gbm1) + ncol(gbm2) + ncol(gbm3))
  expect_true(sum(big_gbm) == sum(gbm1) + sum(gbm2) + sum(gbm3))
})

test_that("can't concat different gene sets", {
  expect_error(concatenate_gene_bc_matrices(list(gbm1, gbm1[1:100,])))
})

gbm4 <- filt_gbm[,1:50]
test_that("can concatenate intersecting barcode sets", {
  expect_error(big_gbm <- concatenate_gene_bc_matrices(list(gbm1, gbm4), NA))

  # TODO For whatever reason, these subsetted matrices have diff sample names now
  # Not sure why, but the sample names are same length, but differ between exprs
  # and phenoData during this call between gbm1 and gbm4
  # I think the reason may have to do with fact that barcodes should actually be
  # the columns in an expression dataset typically, but are rep as rows here
  expect_true(ncol(concatenate_gene_bc_matrices(list(gbm1, gbm4))) == ncol(gbm1) + ncol(gbm4))
})


# GetShockSpan2Server4Seg4Data.r
source("../common/DataUtil.r")
library(ggplot2)
source("../common/PlotUtil.r")

# P A R A M S
nShockspan <- 2
nServerDefaultLife <- 4
nSegments <- 4

# S T A N D A R D   S H O C K   F O R M A T T I N G
sPlotFile <- (  sprintf("shockspan%d",nShockspan)
            %+% sprintf("server%d",nServerDefaultLife)
            %+% sprintf("seg%d",nSegments)
            %+% ".png"
            )
fnGroupBy <- function(dfIn) {group_by(dfIn, copies, lifem
                                    , serverdefaultlife
                                    , shockfreq, shockspan, shockimpact
                                    , auditfrequency, auditsegments
                                    )}
fnSubset <- function(dfIn)  {subset(dfIn,
                                      serverdefaultlife==nServerDefaultLife * 10000
                                    & shockspan==nShockspan
                                    & copies>=5
                                    & auditfrequency==10000
                                    & auditsegments==nSegments
                                    )}
want.varnames <- c("copies","lifem","lost","docstotal","serverdefaultlife"
                ,"shockfreq","shockimpact","shockspan","shockmaxlife"
                ,"auditfrequency","audittype","auditsegments"
                ,"deadserversactive","deadserversall")
fnNarrow <- function(dfIn)  {dfIn[want.varnames]}

# G E T   D A T A
# Get the data into the right form for these plots.
alldat.df <- fndfGetGiantDataRaw("")
allnewdat <- alldat.df %>% fnNarrow() %>% fnGroupBy() %>%
summarize(losspct=round(mean(lost/docstotal)*100.0, 2), n=n())
newdat <- fnSubset(allnewdat)
trows <- newdat

source("../common/shocktitles.r")
# ************ Also change summarize function and ggplot(color=...).
# E N D   O F   S T A N D A R D   F O R M A T T I N G

# P L O T   D A T A
gp <- ggplot(data=trows
            , aes(x=shockfreq,y=safe(losspct), color=factor(copies))
            )
gp <- gp + labs(color=sLegendLabel)

gp <- fnPlotLogScales(gp, y="YES"
#                ,xbreaks=c(50,67,75,80,90,100)
                ,xbreaks=c(5000,10000,15000,20000,25000,30000,40000,50000)
                ,ybreaks=c(0.01,0.10,1.00,10,100)
                )
#gp <- gp + scale_x_reverse(breaks=c(50,67,75,80,90,100))
gp <- gp + geom_line(
                  size=3
                , show.legend=TRUE
                )
gp <- gp + geom_point(data=trows
                , size=6
                , show.legend=TRUE
                , color="black"
                )

gp <- gp + theme(legend.position=c(0.15,0.3))
gp <- gp + theme(legend.background=element_rect(fill="lightgray",
                                  size=0.5, linetype="solid"))
gp <- gp + theme(legend.key.size=unit(0.3, "in"))
gp <- gp + theme(legend.key.width=unit(0.6, "in"))
gp <- gp + theme(legend.text=element_text(size=16))
gp <- gp + theme(legend.title=element_text(size=14))
gp <- gp + scale_color_discrete(labels=lLegendItemLabels)

gp <- fnPlotTitles(gp
            , titleline=sTitleLine
            , xlabel=sXLabel
            , ylabel=sYLabel
        )
# Label the percentage lines out on the right side.
xlabelposition <- log10(800)
gp <- fnPlotPercentLine(gp, xloc=xlabelposition)
gp <- fnPlotMilleLine(gp, xloc=xlabelposition)
gp <- fnPlotSubMilleLine(gp, xloc=xlabelposition)

plot(gp)
fnPlotMakeFile(gp, sPlotFile)

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}


setwd("P:/2019 0970 151 000/User Data/Faraz-Export IDAVE folders")
library(tidyverse)
library(h2o)
tabna <- function(x){table(x, useNA = "ifany")}
##adding cihi vars
df <- readRDS("./Cihi-only Models/cihi_cln.rds")
##adding ed data set
dfx <- readRDS("./Models2.0/dfx_2.0.rds")
setwd("P:/2019 0970 151 000/User Data/Faraz-Export IDAVE folders/Models2.5")

###PATSERV feature engineering
pat <- df %>%
group_by(patserv
 )%>%
summarise(count = n(),
alc_perc = mean(as.numeric(as.character(alc_status))) * 100) %>%
filter(count > 1000 & !patserv == 99) %>%  ##99 is ALC as main service
arrange(desc(alc_perc))

###TOP 5 ALC and TOP LOW ALC are flagged for prediction
pat_values <- c(head(pat) %>% .$patserv %>% as.character%>% as.numeric,
tail(pat) %>% .$patserv %>% as.character%>%as.numeric)

##Create flags using mutate
for (v in pat_values){
var_name <- paste0("patserv_", v)
df <- df %>% mutate(!!var_name := ifelse(patserv == v, 1, 0) %>% factor)
}

names(df)
 # [1] "ID"                 "days_to_lefteddate" "indexfyear"         "dischdisp"
 # [5] "rural"              "instability_q_da"   "dependency_q_da"    "ethniccon_q_da"
 # [9] "incquint"           "age_group"          "female_flag"        "acutelos"
# [13] "prior_hosp_90d"     "prior_hosp_365d"    "readm_90d"          "flag_cardiovers"
# [17] "flag_cell_saver"    "flag_chemother"     "flag_dialysis"      "flag_feeding_tb"
# [21] "flag_heart_resu"    "flag_intv"          "flag_mvent_ge96"    "flag_mvent_lt96"
# [25] "flag_pa_nutrit"     "flag_paracent"      "flag_pleurocent"    "flag_radiother"
# [29] "flag_tracheost"     "flag_vasc_accdv"    "scu"                "patserv"
# [33] "alc_status"         "age_grp"            "dementia_comorb"    "dementia_main"
# [37] "diabetes_comp"      "cerebvsclr"         "paralysis"          "weightloss"
# [41] "psychoses"          "charl_index_grp"    "main_PhysInj_1L"    "main_MentBehav_1L"
# [45] "main_Zfactors_1L"   "main_MusclSkelt_1L" "patserv_34"         "patserv_72"
# [49] "patserv_38"         "patserv_17"         "patserv_19"         "patserv_64"
# [53] "patserv_35"         "patserv_39"         "patserv_55"         "patserv_12"
# [57] "patserv_15"         "patserv_36"

names(dfx)
# "IDm"                "age_grp"            "age_group"          "female_flag"
 # [5] "rural"              "dependency_q_da"    "deprivation_q_da"   "ethniccon_q_da"
 # [9] "instability_q_da"   "incquint"           "triage"             "btany"
# [13] "clidecunitflag"     "admambul"           "cacsanetech"        "cacsit1_grp"
# [17] "cacsit1_grp2"       "cacsit1_grp3"       "cacsitcnt1"         "cacsitcnt"
# [21] "cacspartition"      "glscoma"            "glscoma_bin"        "prv_grp"
# [25] "prv_orthop"         "X30day_ed_revisit"  "charl_index"        "charl_index_bin"
# [29] "frailty_score"      "frail_grp"          "main_PhysInj_1L"    "main_MentBehav_1L"
# [33] "main_Zfactors_1L"   "main_MusclSkelt_1L" "all_Cachx_3L"       "trg_to_ass"
# [37] "time1_grp"          "ass_to_lef"         "time2_grp"          "alc_status"

df <- df %>%
mutate(IDm = paste0(ID, "_", days_to_lefteddate))
#ONLY select the ED vars
dfx <- dfx %>%
 select(IDm, triage:X30day_ed_revisit, frailty_score, frail_grp, all_Cachx_3L:time2_grp)

dfx <- left_join(dfx, df, by = "IDm")

dfx <- dfx %>% select(-IDm, -patserv, -age_group, -cacsit1_grp, -cacsit1_grp2,
-glscoma, -trg_to_ass, -ass_to_left, -frailty_score)
##sort them out
dfx <- dfx %>% select(ID:female_flag, age_grp, triage:time2_grp,
acutelos:scu, dementia_comorb:ncol(dfx), alc_status )
############
str(dfx)
library(infotheo)
X <- dfx %>% select(-c(1:4), - alc_status)
res <- X %>% sapply(function(x){
mutinformation(x, dfx$alc_status, method = "emp") / sqrt(entropy(x) * entropy(df$alc_status)) })

write.csv(res[order(-res)], "./mutualInfo_features.csv")
feat_rank <- res[order(-res)] %>% as.data.frame()

sel_feat <- rownames(feat_rank)[1:40]
#################
# X <- X %>% select(-charl_index_grp) %>%
# mutate_if(is.factor(),~as.numeric(as.character(.)))
chisq.test(dfx$flag_cardiovers %>% as.numeric, dfx$flag_cell_saver %>% as.numeric(), correct = FALSE)
cor(dfx$flag_cardiovers %>% as.numeric, dfx$flag_cell_saver %>% as.numeric())

#################

saveRDS(dfx, "./dfx_v2.5.rds")

#################

dfx %>% select(33:60) %>% sapply(tabna)


# import of individual & population table (reduced from STUCTURE results):
# -> import format struct: "individual_index;Label;cluster1;cluster2;cluster3;cluster4
# -> pop format: pop_index;cluster1;cluster2;cluster3;cluster4;n_cluster

setwd('~/Desktop/')

struct <- read.table("k4.csv", sep = ' ')
pop <- read.table("pop.txt", sep = ';')

library(ggplot2)
library(reshape2)

# reordering of tabels ()

strm <- melt(struct[,c('V1','V3','V4','V5','V6')],id.vars = 1)
popm <- melt(pop[,c('V1','V2','V3','V4','V5')],id.vars = 1)

# k = 2
strm <- melt(struct[,c('V1','V3','V4')],id.vars = 1)
vals =  c('V2','V3','V4')
cols = c(rgb(0,0,.4),rgb(0.9,0,0))

# k = 3
strm <- melt(struct[,c('V1','V3','V4','V5')],id.vars = 1)
vals =  c('V2','V3','V4')
cols = c(rgb(0,.6,0),rgb(0.9,0,0),rgb(0,0,.4))

# k = 4
strm <- melt(struct[,c('V1','V3','V4','V5','V6')],id.vars = 1)
vals =  c('V2','V3','V4','V5')
cols = c(rgb(0.9,0,0),rgb(0,.6,0),rgb(.9,.6,0),rgb(0,0,.4))

# get groupsize from pop-tabel (pop$V6)
grpSize <- c(32,32,32,50,30,30,30,30,48,30,40,27,35)
grpSize_half <- grpSize/2
# calculate starting index for each group
grpInd_end <- cumsum(grpSize)
grpInd <- round(grpInd_end - grpSize_half)

# define group labels
sites <-  c('WFE1','WFE2','BR','MG','LS','RB','BS','SP','IR','QS','SM','CL','LP')
cols_label = c(rep(rgb(.9,.6,0),3),rep(rgb(0.9,0,0),3),rgb(.4,0,.4),rep(rgb(0,0,.4),4),rep(rgb(0,.6,0),2))
# ------ structure plot -----------------

pdf(file="~/Desktop/Structurek2.pdf",width=15,height=3.5,pointsize=12, bg = 'transparent')
# (yvalues normalized to 1 (minimal variance in pure sum of clusters))
ggplot(strm,aes(x= V1,y = value/(rep(tapply(strm$value,strm$V1,sum),2)), fill = variable))+
  # the actual STRUCTURE plot
  geom_bar(stat = 'identity', width=1)+
  geom_vline(xintercept= rep(grpInd_end,each=2), col = rgb(0,0,0,.9),lwd = .8)+
  # add frame
  #geom_polygon(aes(x= c(0.5,446.5,446.5,0.5), y = c(0,0,1,1)),fill=NA,colour ='black')+
  # define manual colors
  scale_fill_manual(name = 'K = 4',
                    values = cols,
                    breaks = vals)+
  # custom axes
  scale_y_continuous(expand = c(0,.001),breaks = (0:4)/4)+
  scale_x_continuous(expand = c(0.01,0.01),
                   breaks = grpInd,
                   labels = sites)+
  # general layout issues
  theme_bw()+
  theme(panel.border = element_blank(),
        panel.grid = element_blank(),
        panel.background = element_rect(fill = NA,colour = NA),
        axis.line = element_blank(),
        axis.title = element_blank(),
        axis.text.y=element_text(size = 20),
        axis.text.x=element_text(angle = 90,vjust = 0.5,size = 22,color =cols_label))+
  guides(fill=FALSE)
dev.off()

# ----------------------------------------
# (older versions)

# population overview
ggplot(popm,aes(x= V1,y = value/(rep(tapply(popm$value,popm$V1,sum),4)), fill = variable))+
  geom_bar(stat = 'identity', width=1)+
  scale_fill_manual(values=c(rgb(.9,.6,0),rgb(0.9,0,0),rgb(0,0,.4),rgb(0,.6,0)),
                    breaks=c('V2','V3','V4','V5'))

# ------ basic structure -----------------
ggplot(strm,aes(x= V1,y = value/(rep(tapply(strm$value,strm$V1,sum),4)), fill = variable))+
  geom_bar(stat = 'identity', width=1)+
  geom_vline(xintercept= rep(grpInd,each=2), col = rgb(1,1,1,.8),lwd = .8)+
  geom_polygon(aes(x= c(0,446,446,0), y = c(0,0,1,1)),fill=NA,colour ='black')+
  scale_fill_manual(name = 'K = 4',
                    values=c(rgb(.9,.6,0),rgb(0.9,0,0),rgb(0,0,.4),rgb(0,.6,0)),
                    breaks=c('V2','V3','V4','V5'),
                    labels = c(expression('k'[1]),
                               expression('k'[2]),
                               expression('k'[3]),
                               expression('k'[4])))+
  scale_y_continuous(expand = c(0,.01),breaks = (0:4)/4)+
  scale_x_discrete(expand = c(0.01,0.01),breaks = 100*(0:4))+
  theme_bw()+
  theme(panel.border = element_blank(),
        panel.grid = element_blank(),
        axis.line = element_blank(),axis.title = element_blank(),
        axis.text=element_text(size=18,face = "bold"),
        legend.text=element_text(size=18,face = "bold"),legend.title=element_text(size=18))


# R version 3.3.2 (2016-10-31)
library(robustbase) #colmedians
library(stringr) #str_match
library(randomForest)
library(R.matlab) #readMat

artificial <- readRDS("landscape_features/processed/artificial.RDS")
coco <- readRDS("landscape_features/processed/coco.RDS")

X_temp <- rbind(artificial, coco)

#shuffle rows
X_temp <- X_temp[sample(nrow(X_temp)),]
number_of_splits <- 10
folds <- 1:nrow(X_temp)
folds <- split(folds,cut(seq_along(folds),number_of_splits,labels = FALSE))
X_temp$func <- NULL

NUMBER_OF_ALGORITHMS = 1
TRIALS_PER_ALGORITHM = 2
NUMBER_OF_FOLDS = 10
NUMBER_OF_COLUMNS = NUMBER_OF_ALGORITHMS * TRIALS_PER_ALGORITHM
results_matrix = matrix(nrow=NUMBER_OF_FOLDS, ncol = NUMBER_OF_COLUMNS)
full_results <- list()
matrix_index <- 1
all_results <- list()
for (fold in folds){
  print(matrix_index)
  train_rows <- setdiff(1:nrow(X_temp), fold)
  test_rows <- fold

  train <- X_temp[train_rows,]

  test <- X_temp[test_rows,]

  columns <- intersect(colnames(train), columns)
  columns <- c(columns, "class")
  columns <- setdiff(columns, "class.1")

  trainCols <- train[columns]
  train_data <- c()
  train_data$all <- train
  train_data$Cols <- trainCols

  #define models here
  rf_functional = train_ml(function(x){randomForest(class ~ ., data=x, ntree=1000)}, train_data)
  rf_results = test_ml(rf_functional, test, test, "rf", train_data)

  resultsRow <- c(rf_results)
  results_matrix[matrix_index, ] <- resultsRow$accuracy
  full_results[[matrix_index]] <- rf_results
  matrix_index <- matrix_index + 1

}

final_results <- colMeans(results_matrix) #accuracy
other_results <- calculate_accuracy_values(full_results) #f1, precision, and recall


#############################################################################################################################
dev.off()
rm(list=ls())
library(tidyverse)
library(dplyr)
library(eurostat)

######IMPORTANT! files from van raalte include life expectancy conditional on survival to 35, marked as ".van"

data.dir <- "C:\\Users\\Magdalena\\demography\\education\\data\\LE"
data.out <- "C:\\Users\\Magdalena\\demography\\education\\data\\ready"
setwd(data.dir)

###LE data
murtin <- read.table(file="oecdwp.txt", sep=",") # LE at 25
colnames(murtin) <- c("country","year","source", paste("men", c("low","lowci","middle","middleci","high","highci"), sep=""),
                    paste("fem", c("low","lowci","middle","middleci","high","highci"),sep=""))
murtinLE <- murtin %>%
  filter(source=="OECD") %>%
  dplyr::select(country,year,menlow,menmiddle,menhigh,femlow,femmiddle,femhigh) %>%
  pivot_longer(cols=menlow:femhigh,names_to = "edu", values_to="LE") %>%
  mutate(sex=substr(edu,1,1),
         edu=substring(edu,4),
         edu=recode(edu,"low"="1","middle"="2","high"="3"))

vanraalte2 <- read.table(file="vanraalte.txt", sep=",", header=TRUE)
vanraalte <- vanraalte2 %>%
  pivot_longer(cols=-country,names_to = "sexedu", values_to="LE") %>%
  mutate(sex=substr(sexedu,1,1)) %>%
  mutate(edu=substring(sexedu,5)) %>%
  filter(sexedu!="men_Total" & sexedu!="fem_Total") %>%
  mutate(edu=recode(edu, "low"="1","lower_sec"="2a", "upper_sec"="2b","tert"="3"))

nemeth <- read.table(file="nemeth.txt", sep="\t", header=TRUE)
nemeth <- nemeth %>%
  dplyr::select(Country,Period,Sex,Education,AgeGrp,ex) %>%
  filter(AgeGrp=="30-34" | AgeGrp=="50-54" | AgeGrp=="65-69") %>%
  mutate(edu=recode(Education, "High"="3","Low"="1","Middle"="2")) %>%
  rename_with(tolower) %>%
  dplyr::rename(age=agegrp,LE=ex) %>%
  mutate(sex=recode(sex, "Female"="f", "Male"="m"))

austria <- read.table(file="austriaklotz.txt", sep=",", header=TRUE)
austriaLE <- austria %>%
  dplyr::select(Educational,m1981,m1991,m2001,m2006,f1981,f1991,f2001,f2006) %>%
  filter(Educational!="Total") %>%
  pivot_longer(cols=m1981:f2006,names_to = "edu", values_to="LE") %>%
  mutate(sex=substr(edu,1,1)) %>%
  mutate(year=substring(edu,2))

belgium <- read.table(file="belgium11.txt", sep=",", header=TRUE)
belgiumLE11 <- belgium %>%
  pivot_longer(cols=Low:Missing,names_to = "edu", values_to="LE") %>%
  filter(edu!="Missing") %>%
  mutate(sex=substr(sexage,1,1),
         age=substring(sexage,2),
         edu=recode(edu,"Low"="1","Mid"="2","High"="3"))

belgium <- read.table(file="belgium9101.txt", sep=",", header=TRUE)
belgiumLE01 <- belgium %>%
  dplyr::select(education,men,women) %>%
  pivot_longer(cols=men:women,names_to = "sex", values_to="LE") %>%
  filter(education!="all")

pernmayer <- read.table(file="spaineduLE.txt", sep=",", header=TRUE)
spain <- pernmayer %>%
  pivot_longer(cols=low:high,names_to = "edu", values_to="LE") %>%
  mutate(edu=recode(edu,"low"="0","primary"="1","secondary"="2", high="3"),
         sex=substr(sex,1,1))

luy <- read.table(file="luydata.csv",sep="\t",header=TRUE) %>%
  dplyr::select(Country:Age, ex_Low:ex_High) %>%
  pivot_longer(ex_Low:ex_High,names_to = "edu",
               values_to = "LE") %>%
  mutate(edu, edu=recode(edu,"ex_Low"="1","ex_Medium"="2","ex_High"="3"),
         Sex=tolower(substr(Sex,1,1))) %>%
  rename_with(tolower)

###read-in population
setwd(data.out)
popall <- read.table(file="popedu.csv",sep=",",header=TRUE)
popall2 <- read.table(file="popedu2mid.csv", sep=",", header=TRUE)
popall912 <- read.table(file="popedu2mid91.csv", sep=",", header=TRUE)
popspain <- read.table(file="spain.csv", sep=",", header=TRUE)
popdenmark <- read.table(file="denmarkpop0910.csv", sep=",",header=TRUE)
popaustralia <-read.table(file="australia11.csv", sep=",",header=TRUE)

popall <- popall %>%
  mutate(age=recode(age,"From 25 to 29 years"="25-29", "From 30 to 34 years"="30-34","From 35 to 39 years"="35-39",
           "From 40 to 44 years"="40-44", "From 45 to 49 years"="45-49", "From 50 to 54 years"="50-54",
           "From 55 to 59 years"="55-59", "From 60 to 64 years"="60-64", "From 65 to 69 years"="65-69"),
       year=as.character(year), edu=as.character(edu))

popall2 <- popall2 %>%
  mutate(age=recode(age,"From 25 to 29 years"="25-29", "From 30 to 34 years"="30-34","From 35 to 39 years"="35-39",
                    "From 40 to 44 years"="40-44", "From 45 to 49 years"="45-49", "From 50 to 54 years"="50-54",
                    "From 55 to 59 years"="55-59", "From 60 to 64 years"="60-64", "From 65 to 69 years"="65-69"),
         year=as.character(year), edu=as.character(edu))
popall912 <- popall912 %>%
  mutate(age=recode(age,"From 25 to 29 years"="25-29", "From 30 to 34 years"="30-34","From 35 to 39 years"="35-39",
                    "From 40 to 44 years"="40-44", "From 45 to 49 years"="45-49", "From 50 to 54 years"="50-54",
                    "From 55 to 59 years"="55-59", "From 60 to 64 years"="60-64", "From 65 to 69 years"="65-69"),
         year=as.character(year), edu=as.character(edu))

##########################################################################################################################
##########new and old LE
#Austria & 2011 & 25 & \citet{murtin17} \\
australia <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="AUS") %>%
  left_join(popaustralia%>%
              mutate(edu=as.character(edu), sex=substr(sex,1,1)),
            by=c("sex","edu"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(year="2011",LEnew=sum(LEprev)) %>%
  mutate(age="25-29", country="Australia")

# Austria & 1981,1991,2001 & 25 & \citet{klotz10} &  1981,1991, 2001 & 25-29 & \citet{IPUMS0322} \\
# & 2011 & 25 & \citet{murtin17} & 2011 & 25-29 &  \citet{Eurostatcensus}\\

austria8101 <- austriaLE %>%
  mutate(edu=recode(Educational,"High"="3","Medium"="2","Low"="1")) %>%
  filter(year<2006) %>%
  left_join(popall %>% filter(country=="AT", age=="25-29", source=="IPUMS")%>%
              mutate(year=as.character(year), edu=as.character(edu)),
            by=c("year","sex","edu"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(year,sex) %>%
  dplyr::summarise(LEnew=sum(LEprev))

austria <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="AUT") %>%
  left_join(popall %>% filter(country=="Austria", age=="25-29", year=="2011"),
            by=c("sex","edu"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(year="2012",LEnew=sum(LEprev)) %>%
  bind_rows(austria8101) %>%
  mutate(age="25-29", country="Austria")

# Belgium  & 2001 & 25 &\citet{deboosere09} &  &????  & \\
# & 2011 & 25, 30,50,65 &\citet{renard19} & 2011 & 25-29+  &  \citet{Eurostatcensus}\\
belgium <- belgiumLE11 %>%
  left_join(popall %>% filter(country=="Belgium", year==2011) %>%
              mutate(edu=as.character(edu),
                     age=recode(age,"25-29"="25", "30-34"="30","50-54"="50","65-69"="65")),
            by=c("sex","edu","age"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(country="Belgium")

#Canada & 2011 & 25 & \citet{murtin17} & 2011  & 25-29 & \citet{IPUMS0322}\\
canada <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="CAN", year=="2011") %>%
  left_join(popall %>% filter(country=="CA", age=="25-29", source=="IPUMS", year=="2011")%>%
              mutate(edu=as.character(edu)),
            by=c("sex","edu"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(year="2011",LEnew=sum(LEprev)) %>%
  mutate(age="25-29", country="Canada")

# Czechia &  1999-2003 & 35 & \citet{vanraalte12} & 2001 & 35-39 & \citet{Eurostatcensus}  \\
czechia <- vanraalte %>%
  filter(country=="Czech Rep.") %>%
  left_join(popall2 %>% filter(country=="Czechia", age=="35-39", year==2001),
            by=c("sex","edu")) %>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(age="35-39", country="Czechia.van", year="1999-2003")

# Denmark & 2001-2005 &  30,50,65 & \citet{nemeth21} & 2001 & 30-34+  &  \citet{Eurostatcensus}\\
# & 2011-2015 &  30,50,65  &\citet{nemeth21} &  2011 & 30-34+ & \citet{Eurostatcensus} \\
denmark0105 <-nemeth %>%
  filter(country=="Denmark", period=="2001-2005") %>%
  left_join(popall %>% filter(country=="Denmark", year==2001) %>%
              mutate(edu=as.character(edu)),
            by=c("sex","edu","age"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(country="Denmark",year="2001-2005")

denmark1 <-nemeth %>%
  filter(country=="Denmark", period=="2011-2015") %>%
  left_join(popall %>% filter(country=="Denmark", year==2011) %>%
              mutate(edu=as.character(edu)),
            by=c("sex","edu","age"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(country="Denmark", year="2011-2015") %>%
  bind_rows(denmark0105)

denmark <- luy %>%
  filter(sex!="a",country=="Denmark", (age=="30-34"|age=="50-54"|age=="65-69"), year=="2009/10") %>%
  left_join(popdenmark %>%
              mutate(edu=as.character(edu)),
            by=c("sex","edu","age"))%>%
  mutate(LEprev=as.numeric(le)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(country="Denmark", year="2009-2010") %>%
  bind_rows(denmark1)

# Estonia &  1998-2002 & 35 & \citet{vanraalte12} & 2001 & 35-39 & \citet{Eurostatcensus}\\
estonia <- vanraalte %>%
  filter(country=="Estonia") %>%
  left_join(popall2 %>% filter(country=="Estonia", age=="35-39", year==2001),
            by=c("sex","edu")) %>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(age="35-39", country="Estonia.van", year="1988-2002")

# finland &  1991-2000 & 35 & \citet{vanraalte12} & 1991, 2001 & 35-39 & \citet{Eurostatcensus}  \\
finlandpop <- popall2 %>%
  filter(country=="Finland", age=="35-39", year==2001) %>%
  mutate(edu=recode(edu,"1"="2a")) %>%
  bind_rows(switzerlandpop91 <- popall912 %>%
              filter(country=="Finland", age=="35-39") %>%
              mutate(edu=recode(edu,"1"="2a")))

finlandpop2 <- finlandpop %>%
  group_by(sex,edu)%>%
  dplyr::summarise(n=sum(n)) %>%
  left_join(finlandpop %>% group_by(sex)%>%
              dplyr::summarise(nall=sum(n)),by="sex") %>%
  mutate(prev=n/nall)

finland2 <- vanraalte %>%
  filter(country=="Finland", sexedu!="men_low", sexedu!="fem_low") %>%
  left_join(finlandpop2, by=c("sex","edu")) %>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(year="1991-2001", age="35-39", country="Finland.van")

#Finland & 2010 & 25 & \citet{murtin17} & 2011 & 25-29 & \citet{Eurostatcensus} \\
finland <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="FIN", year=="2010") %>%
  left_join(popall %>% filter(country=="Finland", age=="25-29",year=="2011"),
            by=c("sex","edu"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(year="2010", age="25-29", country="Finland") %>%
  bind_rows(finland2)

#France &  1991-1999 & 35 & \citet{vanraalte12} & 1991,2001 & 35-39 & \citet{Eurostatcensus}  \\
#& 2011 & 25 & \citet{murtin17} & 2011 & 25-29 & \citet{Eurostatcensus} \\
france2 <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="FRA") %>%
  left_join(popall %>% filter(country=="France", age=="25-29", year==2011),
            by=c("sex","edu")) %>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(year="2012",LEnew=sum(LEprev)) %>%
  mutate(age="25-29", country="France")

popfrance <- popall912 %>%
  filter(country=="France", age=="35-39", year==1991) %>%
  left_join(popall2 %>%
              filter(country=="France", age=="35-39", year==2001) %>%
              select(sex,edu,n),
            by=c("sex","edu")) %>%
  mutate(n=n.x+n.y)

france <- vanraalte %>%
  filter(country=="France") %>%
  left_join(popfrance %>%
              left_join(popfrance %>% group_by(sex) %>% dplyr::summarise(nall=sum(n)), by=c("sex")),
            by=c("sex","edu")) %>%
  mutate(prev=n/nall)%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(age="35-39", country="France.van", year="1991-1999") %>%
  bind_rows(france2)

# Israel & 2008 & 25 & \citet{murtin17} & 2008 & 25-29 &  \citet{IPUMS0322} \\
israel <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="ISR", year=="2008") %>%
  left_join(popall %>% filter(country=="IL", age=="25-29",year=="2008"),
            by=c("sex","edu"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(age="25-29", country="Israel", year="2008")

#Italy & 1991, 2011 & 30,50,65 & \citet{luy19} & 1991,2011 & 30-34+ &   \citet{Eurostatcensus}  \\
italy2 <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="ITA") %>%
  left_join(popall %>% filter(country=="Italy", age=="25-29", year==2011),
            by=c("sex","edu")) %>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(year="2012",LEnew=sum(LEprev)) %>%
  mutate(age="25-29", country="Italy")

italy <- luy %>%
  filter(sex!="a",country=="Italy", (age=="30-34"|age=="50-54"|age=="65-69")) %>%
  left_join(popall %>% filter(country=="Italy",(age=="30-34"|age=="50-54"|age=="65-69"),(year=="1991"|year=="2001"|year=="2011")),
            by=c("sex","edu","year","age"))%>%
  mutate(LEprev=as.numeric(le)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(country="Italy") %>%
  bind_rows(italy2)

# Latvia & 2011 & 25 & \citet{murtin17} & 2011 & 25-29 &  \citet{Eurostatcensus} \\
latvia <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="LVA", year=="2011") %>%
  left_join(popall %>% filter(country=="Latvia", age=="25-29",year=="2011"),
            by=c("sex","edu"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(age="25-29", country="Latvia", year="2011")

#Lithuania &  2000-2002 & 35 & \citet{vanraalte12} & 2001* & 35-39 & \citet{Eurostatcensus}\\
lithuania <- vanraalte %>%
  filter(country=="Lithuania") %>%
  left_join(popall2 %>% filter(country=="Lithuania", age=="35-39", year==2001),
            by=c("sex","edu")) %>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(year="2000-2002", age="35-39", country="Lithuania.van")

# norway &  1991-2000 & 35 & \citet{vanraalte12} & 1991, 2001 & 35-39 & \citet{Eurostatcensus}  \\
norwaypop <- popall2 %>%
  filter(country=="norway", age=="35-39", year==2001) %>%
  mutate(edu=recode(edu,"1"="2a")) %>%
  bind_rows(switzerlandpop91 <- popall912 %>%
              filter(country=="Norway", age=="35-39") %>%
              mutate(edu=recode(edu,"1"="2a")))

norwaypop2 <- norwaypop %>%
  group_by(sex,edu)%>%
  dplyr::summarise(n=sum(n)) %>%
  left_join(norwaypop %>% group_by(sex)%>%
              dplyr::summarise(nall=sum(n)),by="sex") %>%
  mutate(prev=n/nall)

norway2 <- vanraalte %>%
  filter(country=="Norway", sexedu!="men_low", sexedu!="fem_low") %>%
  left_join(norwaypop2, by=c("sex","edu")) %>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(year="1991-2001", age="35-39", country="Norway.van")

# Norway &  1991,2001,2011 & 25 & \citet{murtin17} & 1991, 2001,2011 & 25-29 & \citet{Eurostatcensus}  \\
norway <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="NOR", (year==1991|year==2001|year==2011)) %>%
  left_join(popall %>% filter(country=="Norway", age=="25-29"),
            by=c("sex","edu","year"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex,year) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(age="25-29", country="Norway") %>%
  bind_rows(norway2)

# Poland &  2001-2003 & 35 & \citet{vanraalte12} & 2001 & 35-39 & \citet{Eurostatcensus}  \\
poland <- vanraalte %>%
  filter(country=="Poland") %>%
  left_join(popall2 %>% filter(country=="Poland", age=="35-39", year==2001),
            by=c("sex","edu")) %>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(year="2001-2003", age="35-39", country="Poland.van")

# Slovenia &  2011 & 25 & \citet{murtin17} & 2011 & 25-29 & \citet{Eurostatcensus}  \\
slovenia <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="SVN", year==2011) %>%
  left_join(popall %>% filter(country=="Slovenia", age=="25-29", year=="2011"),
            by=c("sex","edu"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(year="2011", age="25-29", country="Slovenia")

# Spain & 1980-1989 & 35 &  \citet{pernmayer18} &  1981,1991 &  35-39 & \citet{IPUMS0322}\\
spain8089 <- spain %>%
  filter(year=="1980-89") %>%
  left_join(popspain %>% filter(age=="35-39", year=="1981") %>%
              mutate(edu=as.character(edu)),
            by=c("sex","edu"))%>%
  left_join(popspain %>% filter(age=="35-39", year=="1991") %>%
              mutate(edu=as.character(edu)),
            by=c("sex","edu")) %>%
  mutate(prev=(n.x+n.y)/(alln.x+alln.y)) %>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(year="1980-1989")

# & 2012-2015 & 35 &  \citet{pernmayer18} &  2011 & 35-39 & \citet{IPUMS0322} \\
spain <- spain %>%
  filter(year=="2012-15") %>%
  left_join(popspain %>% filter(age=="35-39", year=="2011") %>%
              mutate(edu=as.character(edu)),
            by=c("sex","edu"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(year="2012-2015") %>%
  bind_rows(spain8089) %>%
  mutate(age="35-39", country="Spain")

# Sweden &  2001-2005 & 30+ & \citet{nemeth21} & 2001 & 30-34+ & \citet{Eurostatcensus}  \\
sweden0105 <-nemeth %>%
  filter(country=="Sweden", period=="2001-2005") %>%
  left_join(popall %>% filter(country=="Sweden", year==2001) %>%
              mutate(edu=as.character(edu)),
            by=c("sex","edu","age"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  mutate(year=period) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev))
# &  2011-2015 &  30+ & \citet{nemeth21}  &  2011 & 30-34+ & \citet{Eurostatcensus}\\
sweden1115 <-nemeth %>%
  filter(country=="Sweden", period=="2011-2015") %>%
  left_join(popall %>% filter(country=="Sweden", year==2011) %>%
              mutate(edu=as.character(edu)),
            by=c("sex","edu","age"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  mutate(year=period) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev))

# &  2011 & 25 & \citet{murtin17} & 2011 & 25-29 & \citet{Eurostatcensus}  \\
sweden <- murtinLE %>%
  mutate(year=as.character(year), edu=as.character(edu))%>%
  filter(country=="SWE", year==2011) %>%
  left_join(popall %>% filter(country=="Sweden", age=="25-29", year=="2011"),
            by=c("sex","edu"))%>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(year="2011",age="25-29") %>%
  bind_rows(sweden0105,sweden1115) %>%
  mutate(country="Sweden")

# Switzerland &  1991-2000 & 35 & \citet{vanraalte12} & 1991, 2001 & 35-39 & \citet{Eurostatcensus}  \\
switzerlandpop <- popall2 %>%
  filter(country=="Switzerland", age=="35-39", year==2001) %>%
  mutate(edu=recode(edu,"1"="2a")) %>%
  bind_rows(switzerlandpop91 <- popall912 %>%
              filter(country=="Switzerland", age=="35-39") %>%
              mutate(edu=recode(edu,"1"="2a")))

switzerlandpop2 <- switzerlandpop %>%
  group_by(sex,edu)%>%
  dplyr::summarise(n=sum(n)) %>%
  left_join(switzerlandpop %>% group_by(sex)%>%
              dplyr::summarise(nall=sum(n)),by="sex") %>%
  mutate(prev=n/nall)

switzerland <- vanraalte %>%
  filter(country=="Switzerland", sexedu!="men_low", sexedu!="fem_low") %>%
  left_join(switzerlandpop2, by=c("sex","edu")) %>%
  mutate(LEprev=as.numeric(LE)*as.numeric(prev)) %>%
  group_by(sex) %>%
  dplyr::summarise(LEnew=sum(LEprev)) %>%
  mutate(year="1991-2001", age="35-39", country="Switzerland.van")

#US & 1990, 2010 & 30,50,65 & \citet{luy19} & 1990,2010 & 30-34+ &   \citet{Eurostatcensus}  \\
us <- luy %>%
  filter(sex!="a",country=="United", (age=="30-34"|age=="50-54"|age=="65-69")) %>%
  left_join(popall %>% filter(country=="US",(age=="30-34"|age=="50-54"|age=="65-69"),(year=="1990"|year=="2010")),
            by=c("sex","edu","year","age"))%>%
  mutate(LEprev=as.numeric(le)*as.numeric(prev)) %>%
  group_by(year,sex,age) %>%
  dplyr::summarise(LEnew=sum(LEprev))%>%
  mutate(country="US")

allLE <- australia %>%
  bind_rows(austria,belgium,canada,czechia,denmark,estonia,finland,france, israel,italy,latvia,lithuania, norway,poland,slovenia,spain,sweden,switzerland,us)

setwd(data.out)
write.table(allLE, file="allLE.csv", sep=",",row.names=FALSE)


library(RMariaDB)
library(lubridate)
library(ggplot2)
library(scales)

#Connect to database - .my.cnf has the group 6sigma for connection details
con <- dbConnect(RMariaDB::MariaDB(), group='6sigma')
app.dir = "/home/seans/GitHub/R-DummyData"
setwd(app.dir)

#Constants
data.years = 1
end.date <- ymd_hms("2018/08/3 15:00:00", tz = "GMT") # Metrics Gathered 3pm each day
#Function to calculate number of periods in single year
year_periods = function(period) {
	switch(period,
		'Daily' = 365,
		'Weekly' = 52,
		'Fortnightly' = 26,
		'Monthly' = 12,
		'Quarterly' = 4,
		'Yearly' = 1
		)
	}

# Function to write dummy data to DB
data_with_variance = function(metric) {

	if(metric[1, 'measure_freq'] == 'Each') {
	  # Each is just a count
	  total.periods = metric[1, 'yearly_quantity'] * data.years
	  freq = metric[1, 'yearly_quantity']
	} else {
	  # Calculate Time periods using year_periods
	  total.periods = year_periods(metric[1, 'measure_freq']) * data.years
	  freq = year_periods(metric[1, 'measure_freq'])
	}
  total.periods = freq * data.years
  metric.id <- as.integer(metric[1, 'id'])
  target <- metric[1, 'target']

	# Initialise DataFramemetric.measures
	metric.measures <- data.frame(
		metric_id = integer(),
    created_at = as.POSIXct(character())
    )

	#Add measure and created_at to dataframe
	for (row in 1:total.periods) {
		created.at <- end.date-row*365/freq*86400 # days decimal-min
		metric.measures[row, "metric_id"] <- metric.id
		metric.measures[row, "created_at"] <- created.at
	}

	#Create normal data vector
	measure <- rnorm(total.periods, target, 1)

	# Add measure vector to dataframe
	metric.measures['measure'] <- measure
	return(metric.measures)
}

create_plot = function(metric) {
  plot <- ggplot(metric, aes(created_at, measure)) +
    geom_line()
  ggsave(paste("plots/metric_", metric[1, 'metric_id'], ".png"), width = 10, height = 5)
}

# -- MAIN --
# Get metrics to build based on flags[is_measured=TRUE AND is_dashboard_item=TRUE]
metrics <- dbGetQuery(con,
	'SELECT id, name, unit, measure_freq, target, ntol, ptol, yearly_quantity
	FROM metrics
	WHERE is_measured IS TRUE;')

	print(paste("Number of Records:", nrow(metrics)))

# Itterate through metrics dataframe
for (row in 1:nrow(metrics)) {

	# Clear out changed metrics based on metric_id
	# This will allow us to use flags to recreate only the ones we need to
	recs <- dbExecute(con,
		paste("DELETE
		FROM metric_measures
		WHERE metric_id = ", metrics[row, 'id'], ";", sep= "")
		)

	print(paste("Records Deleted: ", recs))

	metric.data <- data_with_variance(metrics[row,])
	create_plot(metric.data)
#  print(metric.data)
	dbWriteTable(con, value = metric.data, name = "metric_measures", append = TRUE )

}

dbDisconnect(con)


# refine_spillover.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

#' Refine spillover coefficients
#'
#' Refines spillover coefficients iteratively.
#'
#' @param marker.spillover.unco.untr List of two matrices, with regressions
#'     intercepts and coefficients, resulting from the initial spillover
#'     calculation in untransformed scale.
#' @param marker.spillover.unco.tran List of two matrices, with regressions
#'     intercepts and coefficients, resulting from the initial spillover
#'     calculation in transformed scale. Optional parameter used only in
#'     scatter plots, it can be \code{NULL}.
#' @param flow.gate List of vectors with ids of gated events per sample.
#' @param flow.control List with data and metadata of a set of controls.
#' @param asp List with AutoSpill parameters.
#'
#' @return List with four elements:
#'     \itemize{
#'         \item{Spillover matrix at final step.}
#'         \item{Compensation matrix at final step.}
#'         \item{Compensation error at final step, a list with four matrices:
#'             intercepts, coefficients, slopes, and skewness.}
#'         \item{Dataframe with convergence data.}
#'     }
#'
#' @references Roca \emph{et al}:
#'     AutoSpill: A method for calculating spillover coefficients to compensate
#'     or unmix high-parameter flow cytometry data.
#'     \emph{bioRxiv} 2020.06.29.177196;
#'     \href{https://doi.org/10.1101/2020.06.29.177196}{doi:10.1101/2020.06.29.177196}
#'     (2020).
#'
#' @seealso \code{\link{get.marker.spillover}}, \code{\link{gate.flow.data}},
#'     \code{\link{read.flow.control}}, and \code{\link{get.autospill.param}}.
#'
#' @export

refine.spillover <- function( marker.spillover.unco.untr,
    marker.spillover.unco.tran, flow.gate, flow.control, asp )
{
    # set initial values for iteration variables

    rs.convergence <- FALSE
    rs.exit <- FALSE

    rs.iter <- 0
    rs.iter.last <- FALSE
    rs.iter.width <- floor( log10( asp$rs.iter.max ) ) + 1

    rs.lambda <- asp$rs.lambda.coarse

    rs.delta <- -1.0
    rs.delta.threshold <- asp$rs.delta.threshold.untr

    rs.delta.history <- rep( -1, asp$rs.delta.history.n )

    rs.scale.untransformed <- TRUE

    rs.convergence.log <- data.frame(
        iter = numeric(),
        scale = character(),
        lambda = numeric(),
        delta = numeric(),
        delta.max = numeric(),
        delta.change = numeric(),
        stringsAsFactors = FALSE
    )

    # set initial values for spillover calculation

    spillover.curr <- diag( flow.control$marker.n )
    spillover.update <- marker.spillover.unco.untr$coef -
        diag( flow.control$marker.n )

    while ( ! rs.exit )
    {
        # update spillover matrix and calculate compensation matrix

        spillover.curr <- spillover.curr + spillover.update
        spillover.curr <- sweep( spillover.curr, 1,
            diag( spillover.curr ), "/" )

        compensation.curr <- solve( spillover.curr )

        spillover.curr.original <- spillover.curr
        rownames( spillover.curr.original ) <- flow.control$marker.original
        colnames( spillover.curr.original ) <- flow.control$marker.original

        compensation.curr.original <- compensation.curr
        rownames( compensation.curr.original ) <- flow.control$marker.original
        colnames( compensation.curr.original ) <- flow.control$marker.original

        if ( ( rs.iter == 0 && asp$rs.save.table.initial ) ||
            ( asp$rs.save.table.every > 0 &&
                    rs.iter %% asp$rs.save.table.every == 0 ) ||
            rs.iter.last )
        {
            # save spillover and compensation matrices

            if( ! is.null( asp$table.spillover.dir ) )
            {
                table.spillover.file.name <- ifelse( rs.iter.last,
                    sprintf( "%s.csv", asp$spillover.file.name ),
                    sprintf( "%s_%0*d.csv", asp$spillover.file.name,
                        rs.iter.width, rs.iter ) )

                write.csv( spillover.curr.original,
                    file = file.path( asp$table.spillover.dir,
                        table.spillover.file.name ) )
            }

            if( ! is.null( asp$table.compensation.dir ) )
            {
                table.compensation.file.name <- ifelse( rs.iter.last,
                    sprintf( "%s.csv", asp$compensation.file.name ),
                    sprintf( "%s_%0*d.csv", asp$compensation.file.name,
                        rs.iter.width, rs.iter ) )

                write.csv( compensation.curr.original,
                    file = file.path( asp$table.compensation.dir,
                        table.compensation.file.name ) )
            }

            # plot spillover and compensation matrices, by rows and columns
            # respectively

            if( ! is.null( asp$figure.spillover.dir ) )
            {
                figure.spillover.file.label <- ifelse( rs.iter.last, "",
                    sprintf( "_%0*d", rs.iter.width, rs.iter ) )

                plot.matrix( spillover.curr, TRUE, asp$figure.spillover.dir,
                    figure.spillover.file.label, flow.control, asp )
            }

            if( ! is.null( asp$figure.compensation.dir ) )
            {
                figure.compensation.file.label <- ifelse( rs.iter.last, "",
                    sprintf( "_%0*d", rs.iter.width, rs.iter ) )

                plot.matrix( compensation.curr, FALSE,
                    asp$figure.compensation.dir,
                    figure.compensation.file.label, flow.control, asp )
            }
        }

        # set uncompensated expresion data and spillover

        if ( rs.scale.untransformed ) {
            expr.data.unco <- flow.control$expr.data.untr
            marker.spillover.unco <- marker.spillover.unco.untr
        }
        else {
            expr.data.unco <- flow.control$expr.data.tran
            marker.spillover.unco <- marker.spillover.unco.tran
        }

        # get compensated expression data

        flow.set.comp <- lapply( flow.control$flow.set, compensate,
            compensation( spillover.curr.original ) )

        if ( ! rs.scale.untransformed )
            flow.set.comp <- lapply( flow.set.comp, transform,
                transformList( names( flow.control$transform ),
                    flow.control$transform ) )

        expr.data.comp <- get.flow.expression.data( flow.set.comp,
            flow.control )

        check.critical(
            identical( dimnames( expr.data.comp ),
                dimnames( expr.data.unco ) ),
            "internal error: inconsistent event or dye names in compensated data"
        )

        # get compensation error in compensated data

        if ( ( rs.iter == 0 && asp$rs.plot.figure.initial ) ||
            ( asp$rs.plot.figure.every > 0 &&
                    rs.iter %% asp$rs.plot.figure.every == 0 ) ||
            rs.iter.last )
        {
            plot.scatter.figure <- TRUE
            figure.scatter.file.label <- ifelse( rs.iter.last, "final",
                sprintf( "%0*d", rs.iter.width, rs.iter ) )
        }
        else
        {
            plot.scatter.figure <- FALSE
            figure.scatter.file.label <- NULL
        }

        compensation.error <- get.compensation.error(
            expr.data.unco, expr.data.comp, marker.spillover.unco,
            rs.scale.untransformed, plot.scatter.figure,
            figure.scatter.file.label, flow.gate, flow.control, asp
        )

        # get slope error and update delta variables

        slope.error <- compensation.error$slop - diag( flow.control$marker.n )

        rs.delta.prev <- rs.delta
        rs.delta <- sd( slope.error )

        rs.delta.max <- max( abs( slope.error ) )

        if ( rs.delta.prev >= 0 )
            rs.delta.history[ rs.iter %% asp$rs.delta.history.n + 1 ] <-
            rs.delta - rs.delta.prev
        else
            rs.delta.history[ rs.iter %% asp$rs.delta.history.n + 1 ] <- -1

        rs.delta.change <- mean( rs.delta.history )

        rs.convergence.log[ rs.iter + 1, ] <- list( rs.iter,
            ifelse( rs.scale.untransformed, "linear", "bi-exp" ),
            rs.lambda, rs.delta, rs.delta.max, rs.delta.change )

        if ( asp$verbose )
        {
            cat( sprintf(
                "iter %0*d, %s scale, lambda %.1f, delta %g, delta.max %g, delta.change %g\n",
                rs.iter.width, rs.iter,
                ifelse( rs.scale.untransformed, "linear", "bi-exp" ),
                rs.lambda, rs.delta, rs.delta.max, rs.delta.change ) )
        }

        if ( ( rs.iter == 0 && asp$rs.save.table.initial ) ||
                ( asp$rs.save.table.every > 0 &&
                        rs.iter %% asp$rs.save.table.every == 0 ) ||
                rs.iter.last )
        {
            # save and plot slope error

            if( ! is.null( asp$table.slope.error.dir ) )
            {
                table.slope.error.file.name <- ifelse( rs.iter.last,
                    sprintf( "%s.csv", asp$slope.error.file.name ),
                    sprintf( "%s_%0*d.csv", asp$slope.error.file.name,
                        rs.iter.width, rs.iter ) )

                write.csv( slope.error,
                    file = file.path( asp$table.slope.error.dir,
                        table.slope.error.file.name ) )
            }

            if( ! is.null( asp$figure.slope.error.dir ) )
            {
                figure.slope.error.file.name <- sprintf( "%s%s.png",
                    asp$slope.error.file.name,
                    ifelse( rs.iter.last, "",
                        sprintf( "_%0*d", rs.iter.width, rs.iter ) ) )

                plot.density.log( slope.error, "compensation error",
                    file.path( asp$figure.slope.error.dir,
                        figure.slope.error.file.name ),
                    asp )
            }

            # save and plot skewness

            if( ! is.null( asp$table.skewness.dir ) )
            {
                table.skewness.file.name <- ifelse( rs.iter.last,
                    sprintf( "%s.csv", asp$skewness.file.name ),
                    sprintf( "%s_%0*d.csv", asp$skewness.file.name,
                        rs.iter.width, rs.iter ) )

                write.csv( compensation.error$skew,
                    file = file.path( asp$table.skewness.dir,
                        table.skewness.file.name ) )
            }

            if( ! is.null( asp$figure.skewness.dir ) )
            {
                if ( ! is.null( flow.control$autof.marker.idx ) )
                    spillover.skewness <- compensation.error$skew[
                        - flow.control$autof.marker.idx,
                        - flow.control$autof.marker.idx ]
                else
                    spillover.skewness <- compensation.error$skew

                figure.skewness.file.name <- sprintf( "%s%s.png",
                    asp$skewness.file.name,
                    ifelse( rs.iter.last, "",
                        sprintf( "_%0*d", rs.iter.width, rs.iter ) ) )

                plot.density.log( spillover.skewness, "spillover skewness",
                    file.path( asp$figure.skewness.dir,
                        figure.skewness.file.name ),
                    asp )
            }
        }

        # update iteration variables

        if( rs.scale.untransformed && rs.delta.max < rs.delta.threshold )
        {
            # switch to bi-exponential scale and reset lambda and delta history
            rs.scale.untransformed <- FALSE
            rs.delta.threshold <- asp$rs.delta.threshold.tran
            rs.lambda <- asp$rs.lambda.coarse
            rs.delta <- -1.0
            rs.delta.history <- rep( -1, asp$rs.delta.history.n )
            rs.delta.change <- -1
        }

        if ( rs.delta.change > - asp$rs.delta.threshold.change &&
                rs.lambda == asp$rs.lambda.coarse )
        {
            # reduce lambda and reset delta history
            rs.lambda <- asp$rs.lambda.fine
            rs.delta <- -1.0
            rs.delta.history <- rep( -1, asp$rs.delta.history.n )
            rs.delta.change <- -1
        }

        rs.convergence <- ! rs.scale.untransformed &&
            ( rs.delta.max < rs.delta.threshold ||
                    rs.delta.change > - asp$rs.delta.threshold.change )

        rs.exit <- ( rs.convergence && rs.iter.last ) ||
            ( rs.delta.change > - asp$rs.delta.threshold.change &&
                    rs.scale.untransformed ) ||
            ( ! rs.convergence && rs.iter == asp$rs.iter.max ) ||
            rs.iter > asp$rs.iter.max

        rs.iter.last <- rs.convergence

        rs.iter <- rs.iter + 1

        # update spillover matrix

        spillover.update <- rs.lambda * ( slope.error %*% spillover.curr )
    }

    # save and plot convergence

    if ( ! is.null( asp$table.convergence.dir ) )
        write.csv( rs.convergence.log,
            file = file.path( asp$table.convergence.dir,
                sprintf( "%s.csv", asp$convergence.file.name ) ),
            row.names = FALSE )

    if ( ! is.null( asp$figure.convergence.dir ) )
        plot_convergence( rs.convergence.log, NULL, asp )

    # check convergence

    check.critical( rs.convergence,
        "no convergence in refinement of spillover matrix" )

    list(
        spillover = spillover.curr,
        compensation = compensation.curr,
        error = compensation.error,
        convergence = rs.convergence.log
    )
}


# PAWS preprocessing - human activity
# Lily Xu
# December 2018

# libraries needed
library(rgdal)
library(raster)
library(colorspace)
#library(spatstat)

#animalDataFilename <- paste(path, outputPath, "patrolObservation_NewIDs.csv", sep="")
animalDataFilename <- paste(path, inputPath, "animals/animal_data_SWS.csv", sep="")

outFilepath  <- paste(path, outputPath, "animal_count/", sep="")

# create folder if it does not exist
if (!dir.exists(outFilepath)) {
  dir.create(outFilepath)
}

processAnimalData <- function(animalDataFilename, crs_in, crs_use) {
  data <- read.csv(animalDataFilename)

  # grid as used previously:
  coordinates(data) <- data[,c("X", "Y")] # convert to a spatialpoints* object
  proj4string(data) <- CRS(crs_in)
  data <- spTransform(data, CRS(crs_use))
  return(data)
}

# save as CSV
saveRasterAsCSV <- function(raster, outFilepath, filenamePrefix) {
  shapeCSV <- as.data.frame(raster, xy=TRUE)

  # ensure x, y values are ints, not floats
  shapeCSV["x"] <- round(shapeCSV["x"], 0)
  shapeCSV["y"] <- round(shapeCSV["y"], 0)

  shapeCSV <- na.omit(shapeCSV)
  shapeFilename <- paste(outFilepath, filenamePrefix, ".csv", sep="")
  write.csv(shapeCSV, file=shapeFilename)
}

# create visualization of all classes of illegal activities
visualizeClasses <- function(outFilepath, rast, data, boundary) {
  numCols <- ceiling(length(unique(data$importantAnimal)) / 2)

  png(file=paste(outFilepath, "plot_animals.png", sep=""), width=numCols*450, height=900)
  par(mfrow=c(2, numCols))

  animalClasses <- list()
  # add plot of all illegal activities
  for (animal in unique(data$importantAnimal)) {
    animalRast <- rasterize(data[data$importantAnimal == animal,], rast, field="importantAnimal", fun="count", na.rm=T)

    values(animalRast)[is.na(values(animalRast))] <- 0

    # convert raster to im, blur, then convert im to raster
    #animalRast <- raster(blur(as.im(animalRast), sigma=100, bleed=TRUE, normalize=TRUE))

    # convolve with a 5x5 Gaussian kernel
    filter <- c(1, 4, 6, 4, 1, 4, 16, 24, 16, 4, 6, 24, 36, 24, 6, 4, 16, 24, 16, 4, 1, 4, 6, 4, 1)
    filter = matrix(filter, nrow=5, ncol=5, byrow=TRUE)
    filter <- filter / 256

    animalRast <- focal(animalRast, w=filter)

    # mask to park boundary
    values(animalRast)[is.na(values(animalRast))] <- 0
    animalRast <- mask(animalRast, boundary)

    saveRasterAsCSV(animalRast, outFilepath, animal)

    #values(animalRast)[values(animalRast) == 0] <- NA # set '0' to NA to plot as white
    plot(animalRast, col=rev(sequential_hcl(10)))
    title(main=animal, cex.main=2)
    lines(boundary)

    animalClasses[[animal]] <- animalRast
  }
  dev.off()

  return(animalClasses)
}

# create combined visualization of all activities
visualizeAllAnimals <- function(data, rast, boundary, outFilepath) {
  # set everything outside boundary to NA
  # use the dataGridPixels as the grid
  animalsAll <- rasterize(data, rast, field="importantAnimal", fun="count", na.rm=T)
  values(animalsAll)[is.na(values(animalsAll))] <- 0

  # convolve with a 5x5 Gaussian kernel
  filter <- c(1, 4, 6, 4, 1, 4, 16, 24, 16, 4, 6, 24, 36, 24, 6, 4, 16, 24, 16, 4, 1, 4, 6, 4, 1)
  filter = matrix(filter, nrow=5, ncol=5, byrow=TRUE)
  filter <- filter / 256

  animalsAll <- focal(animalsAll, w=filter)

  # mask to park boundary
  values(animalsAll)[is.na(values(animalsAll))] <- 0
  animalsAllMasked <- mask(animalsAll, boundary)

  saveRasterAsCSV(animalsAllMasked, outFilepath, "all_animals")

  png(file=paste(outFilepath, "plot_all_animals.png", sep=""),
      width=800, height=600)
  #values(animalsAllMasked)[values(animalsAllMasked) == 0] <- NA # set '0' to NA to plot as white
  plot(animalsAllMasked, col=rev(sequential_hcl(10)))
  lines(boundary)
  title(main="All animal species", cex.main=2)
  dev.off()
}

rast <- loadGridRast(gridFilename, crs_use)

# NOTE: in this file for SWS, coordinates come in as crs_use, not crs_in
data <- processAnimalData(animalDataFilename, crs_use, crs_use)

data <- findAnimalObservations(data)
animalClasses <- visualizeClasses(outFilepath, rast, data, boundary)
visualizeAllAnimals(data, rast, boundary, outFilepath)


directory <- paste0(dirname(sys.frame(1)$ofile), '/../output/csv/')
c1 <- read.csv(file=paste0(directory, 'fetch_apple_search_ads_campaigns.csv'), sep=',', head=TRUE)
c2 <- read.csv(file=paste0(directory, 'fetch_facebook_campaigns.csv'), sep=',', head=TRUE)
c3 <- read.csv(file=paste0(directory, 'fetch_google_adwords_campaigns.csv'), sep=',', head=TRUE)
c <- merge(x=c1, y=c2, by.x='date', by.y='date_start', all=TRUE)
c <- merge(x=c, y=c3, by.x='date', by.y='day', all=TRUE)
c$spend <- with(c, localspend + spend + cost)
c <- c[c('date', 'spend')]
m <- read.csv(file=paste0(directory, 'fetch_appsflyer_data_locker.csv'), sep=',', head=TRUE)
d <- merge(x=c, y=m, by.x='date', by.y='event_date', all=TRUE)
a <- aggregate(d[c('spend', 'events', 'revenue')], by=list(date=d$date), FUN=sum)
a$cpe <- with(a, spend / events)
a$roas <- with(a, revenue / spend)
attach(mtcars)
par(mfrow=c(4,1))
plot(a$date, a$spend)
plot(a$date, a$events)
plot(a$date, a$cpe)
plot(a$date, a$roas)


#' Reorder a matrix
#'
#' This function reorders a matrix by rows of columns
#'
#' @param matrix1 a matrix (rows=genes x columns=samples) of gene expression data
#'   (e.g., scRNA-seq)
#' @param by.rows By rows (TRUE; default) or by columns
#'
#' @return a reordered matrix
#'
#' @export
reorder_matrix <- function(matrix1,
                           by.rows = TRUE) {
  if (by.rows == TRUE) {
    conf.order <- order(apply(matrix1, 1, which.max))
    matrix1.reordered <- matrix1[conf.order, ]
  } else {
    conf.order <- order(apply(matrix1, 2, which.max))
    matrix1.reordered <- matrix1[, conf.order]
  }
  matrix1.reordered
}

#' Compare two cluster sets matched to CCA
#'
#' This function takes cluster calls defined in two different data sets and then
#' determines to what extent these cluster calls match up with cluster calls from CCA.
#'
#' @param cl a matrix (rows=genes x columns=samples) of gene expression data
#'   (e.g., scRNA-seq)
#' @param by.rows By rows (TRUE; default) or by columns
#'
#' @return a reordered matrix
#'
#' @export
compareClusterCalls <- function(cl,
                                ref.cl,
                                cl.anno,
                                plot.title = NA, plot.silent = TRUE,
                                heat.colors = colorRampPalette(c("grey99", "orange", "red"))(100),
                                row.cl.num = min(length(unique(cl)), length(unique(ref.cl)))) {
  library(grid)
  library(pheatmap)
  conf1 <- table(cl, ref.cl)
  conf1 <- sweep(conf1, 1, rowSums(conf1), "/")
  conf2 <- reorder_matrix(conf1)

  # Cluster co-occurence
  cl.prop.cocl <- apply(conf1, 2, function(x) {
    grid1 <- expand.grid(x, x)
    min.prop <- apply(grid1, 1, min)
  })
  cl.prop.cocl.total <- apply(cl.prop.cocl, 1, sum)
  cl.prop.cocl.m <- matrix(cl.prop.cocl.total, nrow(conf1), nrow(conf1),
    dimnames = list(rownames(conf1), rownames(conf1))
  )

  ph1 <- pheatmap(conf2,
    cutree_rows = row.cl.num, clustering_method = "ward.D2",
    annotation_row = cl.anno, color = heat.colors, fontsize = 6,
    main = plot.title, silent = plot.silent
  )
  list(conf = conf2, cocl = cl.prop.cocl.m, ph = ph1)
}

#' Get some summary statistics
#'
#' This does the summary. For each group return a vector with N, mean, and sd.
#' This is called by qcPlot.
#'
#' @param data Annotation data frame
#' @param measurevar what variables to measure
#' @param groupvars what to group by
#' @param na.rm how to treat NA
#' @param conf.interval confidence interval (default = .95)
#' @param .drop drop something?
#' @param roundall should everything be rounded
#'
#' @return a data frame of statistics
#'
#' @export
summarySE <- function(data = NULL,
                      measurevar,
                      groupvars = NULL,
                      na.rm = FALSE,
                      conf.interval = .95,
                      .drop = TRUE,
                      roundall = F) {
  require(dplyr)
  #
  names(data)[names(data) == measurevar] <- "measurevar"

  datac <- data %>%
    select(one_of(groupvars, "measurevar")) %>%
    filter(ifelse(na.rm == T, !is.na(measurevar), T)) %>%
    mutate(measurevar = as.numeric(measurevar)) %>%
    group_by_(c(groupvars)) %>%
    summarise(
      N = n(),
      median = median(measurevar),
      mean = mean(measurevar),
      max = max(measurevar),
      sd = ifelse(N == 1, 0, sd(measurevar)),
      q25 = as.numeric(quantile(measurevar, 0.25)),
      q75 = as.numeric(quantile(measurevar, 0.75))
    ) %>%
    mutate(se = sd / sqrt(N))
  # %>% mutate(ci =  se * qt(conf.interval/2 + 0.5, N-1))

  if (roundall) {
    roundcols <- c("median", "mean", "max", "sd", "q25", "q75", "se", "ci")
    datac[roundcols] <- round(datac[roundcols], 3)
  }
  # datac <- datac %>% mutate(xpos = 1:n())

  datac
}

#' Make QC plots
#'
#' Makes QC plots
#'
#' @param anno Annotation data frame for patch-seq
#' @param dendcluster_anno what to cluster by
#' @param groupvars what to group by
#' @param scaleLimits scaleLimits
#' @param scaleBreaks scaleBreaks
#' @param scaleLabels scaleLabels
#' @param ylab ylab
#' @param fileName fileName
#'
#' @return the plot is returned
#'
#' @export
qcPlot <- function(anno,
                   dendcluster_anno,
                   name,
                   scaleLimits = c(-5000, 12000),
                   scaleBreaks = seq(0, 12000, 2000),
                   scaleLabels = seq(0, 12, 2),
                   ylab = "value",
                   fileName = gsub("\\.", "_", gsub("_label", "", name)),
                   outputFolder) {

  # dendcluster_id is the annotation for cluster ordering based on the current, bootstrapped dendrogram
  stats <- summarySE(data = anno, measurevar = name, groupvars = "dendcluster_id")

  genes_plot <- ggplot() +
    # geom_quasirandom from the ggbeeswarm package
    # makes violin-shaped jittered point plots
    geom_quasirandom(
      data = anno,
      aes(
        x = dendcluster_id,
        y = eval(parse(text = name))
      ),
      color = "skyblue",
      # Need to set position_jitter height = 0 to prevent
      # jitter on the y-axis, which changes data representation
      position = position_jitter(width = .3, height = 0), size = 0.1
    ) +
    # Errorbars built using stats values
    geom_errorbar(
      data = stats,
      aes(x = dendcluster_id, ymin = q25, ymax = q75),
      size = 0.2
    ) +
    # Median points from stats
    geom_point(
      data = stats,
      aes(x = dendcluster_id, y = median),
      color = "red",
      size = 0.5
    ) +
    # Cluster labels as text objects
    geom_text(
      data = dendcluster_anno,
      aes(
        x = dendcluster_id, y = 0, label = dendcluster_label,
        color = dendcluster_color
      ),
      angle = 90,
      hjust = 2,
      vjust = 0.3,
      size = 2 * 5 / 6
    ) +
    scale_color_identity() +
    # Expand the y scale so that the labels are visible
    scale_y_continuous(ylab,
      limits = scaleLimits,
      breaks = scaleBreaks,
      labels = scaleLabels
    ) +
    # Remove X-axis title
    scale_x_continuous("") +
    theme_bw() +
    # Theme tuning
    theme(
      axis.text.x = element_blank(),
      axis.ticks = element_blank(),
      panel.border = element_blank(),
      panel.grid.major.x = element_blank(),
      panel.grid.minor.x = element_blank()
    )

  ggsave(paste0(outputFolder, fileName, "_QC.pdf"), genes_plot, width = 8, height = 4, useDingbats = F)
  genes_plot
}


# 3. faza: Vizualizacija podatkov

# Uvozimo zemljevid.
zemljevid <- uvozi.zemljevid("https://www.naturalearthdata.com/http//www.naturalearthdata.com/download/110m/cultural/110m_cultural.zip",
                             "ne_110m_admin_0_countries", encoding="UTF-8") %>% fortify

TabelaStarost$Drzava <- gsub("United States", "United States of America", TabelaStarost$Drzava)
TabelaStarost$Drzava <- gsub("Tanzania", "United Republic of Tanzania", TabelaStarost$Drzava)
TabelaStarost$Drzava <- gsub("Czech Republic", "Czechia", TabelaStarost$Drzava)
TabelaStarost$Drzava <- gsub("Serbia", "Republic of Serbia", TabelaStarost$Drzava)

lvls <- levels(zemljevid$ADMIN)
unikat <- unique(TabelaStarost$Drzava)
unikat[!(unikat%in%lvls)]

zemljevid$ADMIN <- as.character(zemljevid$ADMIN)

zdruzitev <- left_join(zemljevid, TabelaStarost, by=c("ADMIN"="Drzava"))

slikazemljevid <- ggplot(zdruzitev) +
  geom_polygon(aes(x = long, y = lat, group = group, fill = Povprecje.let )) + xlab("") + ylab("") + ggtitle("Starost prebivalstva")
slikazemljevid <- slikazemljevid + guides(fill=guide_legend(title="Starost(leta)"))
slikazemljevid


library(ggplot2)
library(reshape2)

# 保存图片
save.plot <- function(p,
                      fn = "../out/确诊信息.png") {
    message("saving: ", fn)
    ggsave(fn, p, width = 16, height = 8, dpi = 600)
}

# 每日新增人数图
plot.new <- function(d.new = d.new) {
    p <- ggplot(d.new) +
        geom_line(aes(x = date, y = value, colour = variable)) +
        xlab("日期") +
        ylab("病例数") +
        theme(
            text = element_text(family = "Kai"),
            legend.title = element_blank(),
            legend.position = c("top")
        )
    p
}

if (FALSE) {
    d.new <- reshape2::melt(d.basic, id = "date", measure = c(
        "新增本土新冠肺炎确诊病例",
        "新增本土无症状感染者",
        "新增境外输入性新冠肺炎确诊病例",
        "新增境外输入性无症状感染者",
        "治愈出院",
        "解除医学观察无症状感染者"
    ))
    source("plot.r")
    p <- plot.new(d.new = d.new)
    save.plot(p, "../out/上海疫情趋势图.png")
}

# 非管控区域病例比例
plot.ratio <- function(d.ratio = d.basic[d.basic$非管控区域病例比例 < 100, c("date", "非管控区域病例比例")]) {
    p <- ggplot(d.ratio) +
        geom_line(aes(x = date, y = 非管控区域病例比例), color = "red") +
        labs(
            title = "非管控区域病例比例",
            x = "日期", y = "%"
        ) +
        theme(text = element_text(family = "Kai"))
    p
}

if (FALSE) {
    source("plot.r")
    p <- plot.ratio()
    save.plot(p, "../out/非管控区域病例比例.png")
}

# 按区域画每日新增人数
plot.district <- function(d.info = info$确诊信息,
                          title = "按区域分每日新增人数",
                          is.cumsum = FALSE) {
    dd <- aggregate(
        d.info$病例,
        list(日期 = d.info$日期, 地区 = d.info$地区),
        length
    )
    if (is.cumsum) {
        dd <- dd[order(dd$地区, dd$日期), ]
        dd <- dd %>% group_by(地区) %>% arrange(地区) %>% mutate(x = cumsum(x))
    }
    p <- ggplot(dd) +
        geom_line(aes(x = 日期, y = x, color = 地区)) +
        labs(
            title = title,
            x = "日期", y = "病例数"
        ) +
        theme(text = element_text(family = "Kai"))
    p
}

if (FALSE) {
    source("plot.r")
    p <- plot.district()
    save.plot(
        p,
        fn = "../out/按区域分每日新增确诊人数.png"
    )
    p <- plot.district(
        d.info = info$无症状信息,
        title = "按区域分每日新增无症状人数"
    )
    save.plot(p, "../out/按区域分每日新增无症状人数.png")
}

# 按区域/时间画每日年龄
plot.by.group <- function(d.info = info$确诊信息,
                          title = "按区域分年龄分布",
                          group = "日期") {
    d.info$日期 <- as.character(d.info$日期)
    p <- ggplot(d.info, aes(get(group), 年龄)) +
        geom_boxplot() +
        labs(
            title = title,
            x = group, y = "年龄"
        ) +
        theme(text = element_text(family = "Kai"))
    p
}

plot.by.group.all <- function(info = info,
                              groups = c("日期", "地区", "性别"),
                              dir = "../out/") {
    for (i in seq_along(groups)) {
        group <- groups[i]
        ttl <- paste0("确诊患者按", group, "分", "年龄分布")
        fn <- paste0(dir, ttl, ".png")
        p <- plot.by.group(
            d.info = info$确诊信息,
            title = ttl,
            group = group
        )
        save.plot(p, fn)
        ttl <- paste0("无症状患者按", group, "分", "年龄分布")
        fn <- paste0(dir, ttl, ".png")
        p <- plot.by.group(
            d.info = info$无症状信息,
            title = ttl,
            group = group
        )
        save.plot(p, fn)
    }
}

if (FALSE) {
    source("plot.r")
    plot.by.group.all(info = info)
}