library(tidyverse)
library(rpart)
library(woeBinning)
library(purrr)
library(tidyr)
library(ggplot2)
library(ROCR)
library(randomForest)
library(ClustOfVar)
library(gbm)
library(caret)
library(xgboost)
library(Hmisc)
install.packages("ClustOfVar")
library(ClustOfVar)
options(repos = c(CRAN = "http://cran.rstudio.com"))

set.seed(1704)

#loading data

dane_geo <- read.csv2("final_data.csv", header = T, sep = ",", dec = ".")
#filtering out the data without DefFlags

#useful variables - means, maximums and minimums for three groups of variables: DPD, NotionalOverdue, NotionalValue

dane_geo <- dane_geo %>%
  ## dpd
  mutate( mean_dpd2 = rowMeans(select(.,DPD_lag1:DPD_lag2)),
          mean_dpd3 = rowMeans(select(.,DPD_lag1:DPD_lag3)),
          mean_dpd4 = rowMeans(select(.,DPD_lag1:DPD_lag4)),
          mean_dpd5 = rowMeans(select(.,DPD_lag1:DPD_lag5)),
          mean_dpd6 = rowMeans(select(.,DPD_lag1:DPD_lag6)),
          mean_dpd7 = rowMeans(select(.,DPD_lag1:DPD_lag7)),
          mean_dpd8 = rowMeans(select(.,DPD_lag1:DPD_lag8)),
          mean_dpd9 = rowMeans(select(.,DPD_lag1:DPD_lag9)),
          mean_dpd10 = rowMeans(select(.,DPD_lag1:DPD_lag10)),
          mean_dpd11 = rowMeans(select(.,DPD_lag1:DPD_lag11)),
          mean_dpd12 = rowMeans(select(.,DPD_lag1:DPD_lag12)),
          max_dpd2 = apply(select(., DPD_lag1:DPD_lag2),1,max),
          max_dpd3 = apply(select(., DPD_lag1:DPD_lag3),1,max),
          max_dpd4 = apply(select(., DPD_lag1:DPD_lag4),1,max),
          max_dpd5 = apply(select(., DPD_lag1:DPD_lag5),1,max),
          max_dpd6 = apply(select(., DPD_lag1:DPD_lag6),1,max),
          max_dpd7 = apply(select(., DPD_lag1:DPD_lag7),1,max),
          max_dpd8 = apply(select(., DPD_lag1:DPD_lag8),1,max),
          max_dpd9 = apply(select(., DPD_lag1:DPD_lag9),1,max),
          max_dpd10 = apply(select(., DPD_lag1:DPD_lag10),1,max),
          max_dpd11 = apply(select(., DPD_lag1:DPD_lag11),1,max),
          max_dpd12 = apply(select(., DPD_lag1:DPD_lag12),1,max),
          min_dpd2 = apply(select(., DPD_lag1:DPD_lag2),1,min),
          min_dpd3 = apply(select(., DPD_lag1:DPD_lag3),1,min),
          min_dpd4 = apply(select(., DPD_lag1:DPD_lag4),1,min),
          min_dpd5 = apply(select(., DPD_lag1:DPD_lag5),1,min),
          min_dpd6 = apply(select(., DPD_lag1:DPD_lag6),1,min),
          min_dpd7 = apply(select(., DPD_lag1:DPD_lag7),1,min),
          min_dpd8 = apply(select(., DPD_lag1:DPD_lag8),1,min),
          min_dpd9 = apply(select(., DPD_lag1:DPD_lag9),1,min),
          min_dpd10 = apply(select(., DPD_lag1:DPD_lag10),1,min),
          min_dpd11 = apply(select(., DPD_lag1:DPD_lag11),1,min),
          min_dpd12 = apply(select(., DPD_lag1:DPD_lag12),1,min),
 # NotionalValue
          mean_nval2 = rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag2)),
          mean_nval3 = rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag3)),
          mean_nval4 = rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag4)),
          mean_nval5 = rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag5)),
          mean_nval6 = rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag6)),
          mean_nval7 = rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag7)),
          mean_nval8 = rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag8)),
          mean_nval9 = rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag9)),
          mean_nval10 = rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag10)),
          mean_nval11= rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag11)),
          mean_nval12 = rowMeans(select(.,NotionalValue_lag1:NotionalValue_lag12)),
          max_nval2 = apply(select(., NotionalValue_lag1:NotionalValue_lag2),1,max),
          max_nval3 = apply(select(., NotionalValue_lag1:NotionalValue_lag3),1,max),
          max_nval4 = apply(select(., NotionalValue_lag1:NotionalValue_lag4),1,max),
          max_nval5 = apply(select(., NotionalValue_lag1:NotionalValue_lag5),1,max),
          max_nval6 = apply(select(., NotionalValue_lag1:NotionalValue_lag6),1,max),
          max_nval7 = apply(select(., NotionalValue_lag1:NotionalValue_lag7),1,max),
          max_nval8 = apply(select(., NotionalValue_lag1:NotionalValue_lag8),1,max),
          max_nval9 = apply(select(., NotionalValue_lag1:NotionalValue_lag9),1,max),
          max_nval10 = apply(select(., NotionalValue_lag1:NotionalValue_lag10),1,max),
          max_nval11 = apply(select(., NotionalValue_lag1:NotionalValue_lag11),1,max),
          max_nval12 = apply(select(., NotionalValue_lag1:NotionalValue_lag12),1,max),
          min_nval2 = apply(select(., NotionalValue_lag1:NotionalValue_lag2),1,min),
          min_nval3 = apply(select(., NotionalValue_lag1:NotionalValue_lag3),1,min),
          min_nval4 = apply(select(., NotionalValue_lag1:NotionalValue_lag4),1,min),
          min_nval5 = apply(select(., NotionalValue_lag1:NotionalValue_lag5),1,min),
          min_nval6 = apply(select(., NotionalValue_lag1:NotionalValue_lag6),1,min),
          min_nval7 = apply(select(., NotionalValue_lag1:NotionalValue_lag7),1,min),
          min_nval8 = apply(select(., NotionalValue_lag1:NotionalValue_lag8),1,min),
          min_nval9 = apply(select(., NotionalValue_lag1:NotionalValue_lag9),1,min),
          min_nval10 = apply(select(., NotionalValue_lag1:NotionalValue_lag10),1,min),
          min_nval11 = apply(select(., NotionalValue_lag1:NotionalValue_lag11),1,min),
          min_nval12 = apply(select(., NotionalValue_lag1:NotionalValue_lag12),1,min),
   #NotionalOverdue
          mean_novd2 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag2)),
          mean_novd3 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag3)),
          mean_novd4 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag4)),
          mean_novd5 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag5)),
          mean_novd6 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag6)),
          mean_novd7 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag7)),
          mean_novd8 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag8)),
          mean_novd9 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag9)),
          mean_novd10 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag10)),
          mean_novd11 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag11)),
          mean_novd12 = rowMeans(select(.,NotionalOverdue_lag1:NotionalOverdue_lag12)),
          max_novd2 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag2),1,max),
          max_novd3 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag3),1,max),
          max_novd4 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag4),1,max),
          max_novd5 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag5),1,max),
          max_novd6 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag6),1,max),
          max_novd7 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag7),1,max),
          max_novd8 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag8),1,max),
          max_novd9 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag9),1,max),
          max_novd10 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag10),1,max),
          max_novd11 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag11),1,max),
          max_novd12 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag12),1,max),
          min_novd2 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag2),1,min),
          min_novd3 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag3),1,min),
          min_novd4 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag4),1,min),
          min_novd5 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag5),1,min),
          min_novd6 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag6),1,min),
          min_novd7 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag7),1,min),
          min_novd8 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag8),1,min),
          min_novd9 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag9),1,min),
          min_novd10 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag10),1,min),
          min_novd11 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag11),1,min),
          min_novd12 = apply(select(., NotionalOverdue_lag1:NotionalOverdue_lag12),1,min),
          spend_over_income = Monthly_Spendings / Monthly_Income)

dane_geo <-  dane_geo %>% select(Application_ID: DefFlag, mean_dpd3, mean_dpd6, mean_dpd9, mean_dpd12,
                         max_dpd3, max_dpd6, max_dpd9, max_dpd12,
                         min_dpd3, min_dpd6, min_dpd9, min_dpd12,
                         mean_nval3, mean_nval6,mean_nval9, mean_nval12,
                         max_nval3, max_nval6, max_nval9, max_nval12,
                         min_nval3, min_nval6, min_nval9, min_nval12,
                         mean_novd3, mean_novd6, mean_novd9, mean_novd12,
                         max_novd3, max_novd6,max_novd9, max_novd12,
                         min_novd3, min_novd6,min_novd9, min_novd12)

prog_geo <- dane_geo %>% filter(is.na(DefFlag))
dane_geo <- dane_geo %>% filter(!is.na(DefFlag))
##splitting the data into training and validation sets - respectively 70% and 30%
#we build our models on the training set and test their accuracy on validation

SplitDataSet <- function(data.set, training.fraction){
  random.numbers <- sample.int(nrow(data.set))
  quantiles <- quantile(random.numbers, probs = c(0, training.fraction, 1))
  split.labels <- cut(random.numbers, quantiles, include.lowest = T,
                      labels = c("training", "validation"))
  return(split(data.set, split.labels))
}

set_geo <- SplitDataSet(dane_geo, 0.7)

training_geo <- set_geo$training
validation_geo <- set_geo$validation

#pca is a technique meant to reduce the dimensionality of a dataset with highly correlated variables
#pca was performed on 3 groups of highly correlated variables: DPD, NationalValue, NotionalOverdue

pca_dpd <- prcomp(select(training_geo, DPD_lag1:DPD_lag12), scale = TRUE, center = TRUE)
vd_dpd_pc <- as.data.frame(predict(pca_dpd, newdata = select(validation_geo, DPD_lag1:DPD_lag12)))
prog_dpd_pc <- as.data.frame(predict(pca_dpd, newdata = select(prog_geo, DPD_lag1:DPD_lag12)))
summary(pca_dpd)

pca_nval <- prcomp(select(training_geo, NotionalValue_lag1:NotionalValue_lag12), scale = TRUE, center = TRUE)
vd_nval_pc <- as.data.frame(predict(pca_nval, newdata = select(validation_geo, NotionalValue_lag1:NotionalValue_lag12)))
prog_nval_pc <- as.data.frame(predict(pca_nval, newdata = select(prog_geo, NotionalValue_lag1:NotionalValue_lag12)))
summary(pca_nval)

pca_novd <- prcomp(select(training_geo, NotionalOverdue_lag1:NotionalOverdue_lag12), scale = TRUE, center = TRUE)
vd_novd_pc <- as.data.frame(predict(pca_novd, newdata = select(validation_geo, NotionalOverdue_lag1:NotionalOverdue_lag12)))
prog_novd_pc <- as.data.frame(predict(pca_novd, newdata = select(prog_geo, NotionalOverdue_lag1:NotionalOverdue_lag12)))
summary(pca_novd)

training_geo <- training_geo %>% cbind(pca_dpd$x[,c(1:3)]) %>% rename( dpd_pc1 = PC1, dpd_pc2 = PC2, dpd_pc3 = PC3) %>%
  cbind(pca_nval$x[,c(1,2)]) %>% select(-PC2) %>% rename(nval_pc1 = PC1)  %>%
  cbind(pca_novd$x[,c(1:4)]) %>% rename(novd_pc1 = PC1, novd_pc2 = PC2, novd_pc3 = PC3, novd_pc4 = PC4)

validation_geo <- validation_geo %>% cbind(select(vd_dpd_pc, PC1, PC2, PC3 )) %>% rename( dpd_pc1 = PC1, dpd_pc2 = PC2, dpd_pc3 = PC3) %>%
  cbind(select(vd_nval_pc,PC1)) %>% rename(nval_pc1 = PC1) %>%
  cbind(select(vd_novd_pc, PC1:PC4)) %>% rename(novd_pc1 = PC1, novd_pc2 = PC2, novd_pc3 = PC3, novd_pc4 = PC4)

prog_geo <- prog_geo %>% cbind(select(prog_dpd_pc, PC1, PC2, PC3 )) %>% rename( dpd_pc1 = PC1, dpd_pc2 = PC2, dpd_pc3 = PC3) %>%
  cbind(select(prog_nval_pc,PC1)) %>% rename(nval_pc1 = PC1) %>%
  cbind(select(prog_novd_pc, PC1:PC4)) %>% rename(novd_pc1 = PC1, novd_pc2 = PC2, novd_pc3 = PC3, novd_pc4 = PC4)

training_geo <-  training_geo %>% select(Application_ID: Unemployed_highschool_and_lower_number, DefFlag, mean_dpd3, mean_dpd6, mean_dpd9, mean_dpd12,
                                 max_dpd3, max_dpd6, max_dpd9, max_dpd12,
                                 min_dpd3, min_dpd6, min_dpd9, min_dpd12,
                                 mean_nval3, mean_nval6,mean_nval9, mean_nval12,
                                 max_nval3, max_nval6, max_nval9, max_nval12,
                                 min_nval3, min_nval6, min_nval9, min_nval12,
                                 mean_novd3, mean_novd6, mean_novd9, mean_novd12,
                                 max_novd3, max_novd6,max_novd9, max_novd12,
                                 min_novd3, min_novd6,min_novd9, min_novd12,
                                 dpd_pc1, dpd_pc2, dpd_pc3,
                                 nval_pc1,
                                 novd_pc1, novd_pc2, novd_pc3, novd_pc4,
                                 NotionalOverdue_t0, NotionalValue_t0, DPD_t0)

validation_geo <-  validation_geo %>% select(Application_ID: Unemployed_highschool_and_lower_number, DefFlag, mean_dpd3, mean_dpd6, mean_dpd9, mean_dpd12,
                                         max_dpd3, max_dpd6, max_dpd9, max_dpd12,
                                         min_dpd3, min_dpd6, min_dpd9, min_dpd12,
                                         mean_nval3, mean_nval6,mean_nval9, mean_nval12,
                                         max_nval3, max_nval6, max_nval9, max_nval12,
                                         min_nval3, min_nval6, min_nval9, min_nval12,
                                         mean_novd3, mean_novd6, mean_novd9, mean_novd12,
                                         max_novd3, max_novd6,max_novd9, max_novd12,
                                         min_novd3, min_novd6,min_novd9, min_novd12,
                                         dpd_pc1, dpd_pc2, dpd_pc3,
                                         nval_pc1,
                                         novd_pc1, novd_pc2, novd_pc3, novd_pc4,
                                         NotionalOverdue_t0, NotionalValue_t0, DPD_t0)

prog_geo <-  prog_geo %>% select(Application_ID: Unemployed_highschool_and_lower_number, DefFlag, mean_dpd3, mean_dpd6, mean_dpd9, mean_dpd12,
                                         max_dpd3, max_dpd6, max_dpd9, max_dpd12,
                                         min_dpd3, min_dpd6, min_dpd9, min_dpd12,
                                         mean_nval3, mean_nval6,mean_nval9, mean_nval12,
                                         max_nval3, max_nval6, max_nval9, max_nval12,
                                         min_nval3, min_nval6, min_nval9, min_nval12,
                                         mean_novd3, mean_novd6, mean_novd9, mean_novd12,
                                         max_novd3, max_novd6,max_novd9, max_novd12,
                                         min_novd3, min_novd6,min_novd9, min_novd12,
                                         dpd_pc1, dpd_pc2, dpd_pc3,
                                         nval_pc1,
                                         novd_pc1, novd_pc2, novd_pc3, novd_pc4,
                                         NotionalOverdue_t0, NotionalValue_t0, DPD_t0)
# functions undersample and oversample
#resampled is a set which was build using this function
UnderSample <- function(dane, target , target_prop =  0.5, replacement = F ){

dt <- split(dane, target)

unique_values <- unique(target)
start_number <- as.vector(table(target))
start_proportion <- as.vector(prop.table(table(target)))

n_cases <- start_number[2]
to_sample <- round((n_cases / target_prop) - n_cases)

rows <- sample.int(nrow(dt$`0`), to_sample, replace = replacement)

new_sample <- rbind(dt$`0`[rows,], dt$`1`)

return(new_sample)

}

resampled_geo <- UnderSample(training_geo, training_geo$DefFlag, 0.5)

#categorization of all the numeric variables
#tabulate.binning contains the categories, distributions and Woe of categorized variables

## the training.binned and validation.binned contain binned variables

binned_geo <- resampled_geo

###binning of the dataset with added geographical variables

##i added some iprovements i exclude variables for which i have calculated minimums and maximums

WoeBinning_geo <- function(target, variable, min.perc.total, min.perc.class, stop.limit, event.class){

  binning_geo <<- woe.tree.binning(binned_geo, target, variable, min.perc.total, min.perc.class, stop.limit, event.class)

  tabulate.binning.geo <<- woe.binning.table(binning_geo)

  binned_geo <<- woe.binning.deploy(binned_geo, binning_geo)

  BinPlot_geo <<-woe.binning.plot(binning_geo, multiple.plots=FALSE)

}

classes <- sapply(training_geo, class)
num_names <- names(classes[classes == "numeric" | classes == "integer"])
num_names <- num_names[num_names!= "DefFlag" & num_names != "GEO_region"]

WoeBinning_geo('DefFlag', num_names, min.perc.total=0.01, min.perc.class=0.01,
           stop.limit=0.1, event.class='bad')

training_geo.binned <- woe.binning.deploy(training_geo, binning_geo)
validation_geo.binned <- woe.binning.deploy(validation_geo, binning_geo)
prog_geo.binned <- woe.binning.deploy(prog_geo, binning_geo)

## iv contains the variable names and their information value (sorted by information value)

iv_geo <- as.data.frame(binning_geo[,c(1,3)], col.names = c("zmienna", "iv") )

best_iv_geo <- iv_geo[iv_geo$V2 > 0.02,]  %>% select(V1) %>% unlist() %>% unname()

####
tree <- ClustOfVar::hclustvar(binned_geo[,best_iv_geo])
plot(tree)

n_clus <- 20
clusters <- cutreevar(tree, n_clus, matsim = TRUE)

cluster_id <- clusters$cluster

variables <- binning_geo[,1] %>% unlist()
iv <- binning_geo[,3] %>% unlist()
iv_clust <- data.frame(variables,iv, stringsAsFactors = FALSE)
row.names(iv_clust) <- t(iv_clust[,1])
iv_clust <- iv_clust[best_iv_geo,]
iv_clust <- iv_clust %>% cbind(cluster_id)
colnames(iv_clust) <- c("var", "iv", "cluster_id")

cls <- split(iv_clust, cluster_id)
clust_best <- rep(NA, n_clus)

for(i in 1:n_clus){
  cls[[i]] <- arrange(cls[[i]], desc(cls[[i]]$iv))
  cls[[i]] <- cls[[i]] %>% head(1) %>% select(var) %>% as.character()
  clust_best[i] <- cls[[i]]
}

clust_best <- setdiff(clust_best, c("max_novd3", "mean_dpd12","NotionalOverdue_t0","min_novd9", "min_dpd3","max_dpd12"))

######

#chi2 test between all factor variables in the input dataframe and the target variable
df_chisq_test <- function(df, target_variable){
  target <- as.factor(df[,target_variable])
  var_cat <- sapply(df, class)
  nms <- names(var_cat[var_cat == "factor"])
  nms <- nms[ nms != target_variable & nms != "Application_ID"]
  chi2 <- c()
  p_value <- c()
  cramer_v <- c()
  for (i in 1:length(nms)){
    test <- chisq.test(df[,nms[i]], df[,target_variable])
    chi2 <- c(chi2, test$statistic)
    p_value <- c(p_value, test$p.value)
    x_cats <- length(levels(df[,nms[i]])) - 1
    y_cats <- length(levels(target)) - 1
    cram <- sqrt(test$statistic / length(df[,target_variable]) / min(c(x_cats,y_cats)))
    cramer_v <- c(cramer_v,cram)
  }

  results <- data.frame(nms, round(chi2,3), round(p_value,3), round(cramer_v,3))
}

#the same for the dataset with added geographical variables
df_chi2_geo <- df_chisq_test(training_geo.binned, "DefFlag")
df_chi2_geo <- df_chi2_geo[order(df_chi2_geo$round.cramer_v..3., decreasing = TRUE),]

best_20_geo <- df_chi2_geo[order(df_chi2_geo$round.cramer_v..3., decreasing = TRUE),] %>% select(nms) %>% head(20)
best_20_geo <- best_20_geo[best_20_geo != "DefFlag" & best_20_geo != "DefFlag.binned"]

korelacja <- cor(as.matrix(binned_geo[,best_iv_geo]))
## best_20 is a vector with 20 best variables
## best_20_geo contains also the geographical variables

#-----

#best_predictors_up_to_date predictors <- select(binned, best_20_iv, Job_type:Monthly_Spendings)

# best_model_up_to_date bst <- xgboost::xgb.train(data = dmodel, max.depth = 4,
#                          nrounds = 600 , eta = 0.01, subsample = 0.8, gamma = 1,colsample_bytree = 0.8, watchlist = watchlist, eval.metric = "auc", eval.metric = "rmse", verbose = F, objective = "binary:logistic")
predictors <- select(binned_geo, clust_best, Job_type:Monthly_Spendings)

#predictors <- select(binned_geo, clust_best, Job_type:Car_status)

mt <- model.matrix(~.+0, binned_geo[,c("Job_type", "Marital_status", "Home_status", "Car_status")])
nm <- names(predictors)
nm <- setdiff(nm,c("Job_type", "Marital_status", "Home_status", "Car_status") )
mt_model <- cbind(mt, binned_geo[,nm])

mt <- model.matrix(~.+0, training_geo.binned[,c("Job_type", "Marital_status", "Home_status", "Car_status")])
mt_train <- cbind(mt, training_geo.binned[,nm])

mt <- model.matrix(~.+0, validation_geo.binned[,c("Job_type", "Marital_status", "Home_status", "Car_status")])
mt_valid <- cbind(mt, validation_geo.binned[,nm])

mt <- model.matrix(~.+0, prog_geo.binned[,c("Job_type", "Marital_status", "Home_status", "Car_status")])
mt_prog <- cbind(mt, prog_geo.binned[,nm])

dtrain <- xgb.DMatrix(data = data.matrix(mt_train), label = data.matrix(training_geo.binned[,"DefFlag"]))
dtest <- xgb.DMatrix(data =  data.matrix(mt_valid), label = data.matrix(validation_geo.binned[,"DefFlag"]))

dmodel <- xgb.DMatrix(data =  data.matrix(mt_model), label = data.matrix(binned_geo[,"DefFlag"]))
watchlist = list(train = dtrain, test = dtest)

#-----
# XGBOOST with the best 20 variables

bst <- xgboost::xgb.train(data = dmodel, max.depth = 4,
                          nrounds = 1000 , eta = 0.01, subsample = 0.8, gamma = 1,colsample_bytree = 0.8, watchlist = watchlist, eval.metric = "auc", eval.metric = "rmse", verbose = F, objective = "binary:logistic")

eval_log <- bst$evaluation_log

par(mfrow = c(1,2))
plot(x = eval_log$iter, y= eval_log$test_auc, type = "l")
plot(x = eval_log$iter, y = eval_log$test_rmse, type = "l")

par(mfrow = c(1,1))
importance_matrix <- xgb.importance(model = bst)
print(importance_matrix)

top_features <- importance_matrix[c(1:11),1]
top_features <- unlist(top_features)
xgb.plot.importance(importance_matrix = importance_matrix)

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

model <- bst

in_prop <- as.vector(prop.table(table(dane_geo$DefFlag)))
rs_prop <- as.vector(prop.table(table(binned_geo$DefFlag)))

score.or.class <- gain <- lift <- roc <- auc <- prediction.object <- list()
score.or.class[[1]] <- list(training_geo.binned$DefFlag, training_geo.binned$DefFlag)

prediction_test <- predict(model, new = data.matrix(mt_train), type = "prob")
prediction_valid <- predict(model, new = data.matrix(mt_valid), type ="prob")
prediction_prog <- predict(model, new = data.matrix(mt_prog), type = "prob" )

prediction_test <- prediction_test*(in_prop[2] / rs_prop[2]) / (prediction_test*in_prop[1]/rs_prop[2] + (1 -prediction_test) *in_prop[2]/rs_prop[2])

pred_test <- data.frame(training_geo.binned$Application_ID, prediction_test)
colnames(pred_test) <- c("Application_ID", "Score")

prediction_valid <- prediction_valid*(in_prop[2] / rs_prop[2]) / (prediction_valid*in_prop[1]/rs_prop[2] + (1-prediction_valid) *in_prop[2]/rs_prop[2])

pred_val <- data.frame(validation_geo.binned$Application_ID, prediction_valid)
colnames(pred_val) <- c("Application_ID", "Score")
prediction_prog <- prediction_prog*(in_prop[2] / rs_prop[2]) / (prediction_prog*in_prop[1]/rs_prop[2] + (1-prediction_prog) *in_prop[2]/rs_prop[2])

pred_prog <- data.frame(prog_geo.binned$Application_ID, prediction_prog)
colnames(pred_prog) <- c("Application_ID", "Score")

pred <- pred_test %>% rbind(pred_val) %>% rbind(pred_prog)
#write.table(pred, "output_final.csv", sep = ";", dec = ".", row.names = FALSE)

score.or.class[[2]] <- list(as.vector(prediction_test),
                            training_geo.binned$DefFlag)
score.or.class[[3]] <- list(as.vector(prediction_valid),
                            validation_geo.binned$DefFlag)
class.average <- mean(training_geo.binned$DefFlag)
random.class <- 1
for (i in 1:(nrow(training_geo.binned) - 1)) {
  random.class <- c(random.class, mean(random.class) < class.average)
}
score.or.class[[4]] <- list(seq(0, 1, len = nrow(training_geo.binned)), random.class)

for (i in 1:length(score.or.class)) {
  prediction.object[[i]] <- prediction(score.or.class[[i]][[1]],
                                       score.or.class[[i]][[2]])
  gain[[i]] <- performance(prediction.object[[i]], "tpr", "rpp")
  lift[[i]] <- performance(prediction.object[[i]], "lift", "rpp")
  roc[[i]] <- performance(prediction.object[[i]], "tpr", "fpr")
  auc[[i]] <- performance(prediction.object[[i]], "auc")
}

LEGEND_LABELS <- c("wizard", "train", "test", "random")
ShowCurve <- function(list, name, AUC = FALSE, legend.position = "right") {
  for (i in 1:length(list)) {
    plot(list[[i]], main = paste(name, " curve"),
         col = gray((i - 1) / 4), lwd = 2, add = (i != 1), xlim = c(0, 1))
    if (AUC) {
      text(.2, 0.9 - i * 0.1, pos = 4, col = gray((i - 1) / 4), cex = .9,
           paste("AUC =", round(auc[[i]]@y.values[[1]], digit = 2)))
    }
  }
  legend(legend.position, lty = 2, lwd = 2, col = gray(0:3 / 4),
         y.intersp = .6, legend = LEGEND_LABELS, seg.len = 0.6, bty = "n")
}
par(mfrow = c(2, 2), mar = c(4, 4, 2, 1))
ShowCurve(gain, "Gain")
ShowCurve(lift, "Lift", legend.position = "topright")
ShowCurve(roc, "ROC", AUC = TRUE)

Gini_train = 2*(auc[[2]]@"y.values"[[1]] - 0.5)
Gini_test = 2*(auc[[3]]@"y.values"[[1]] - 0.5)

print(Gini_train)
print(Gini_test)

#-----

#write.csv(training.binned, "training_binned.csv")
#write.csv(validation.binned, "validation_binned.csv")
#write.csv(binned, "binned.csv")

#write.csv(training_geo.binned, "training_geo_binned.csv")
#write.csv(validation_geo.binned, "validation_geo_binned_geo.csv")
#write.csv(binned_geo[,best_20_iv_geo], "binned_geo.csv")


##  test   #########################

OPtrigger<-new("FLOPtrigger.control")
print(OPtrigger)

OPtrigger<-FLOPtrigger.control(
        first.year=2008,
        last.year=2015,
        first.VPA=17,
        no.species=10    )
print(OPtrigger)

OPtrigger<-read.FLOPtrigger.control(file=file.path(data.path,'OP_trigger.dat'),n.VPA=10,n.other.pred=16)
print(OPtrigger)

write.FLOPtrigger.control(OPtrigger,file='a.dat',nice=T)

##
OP<-new("FLOP.control")
print(OP)

OP<-FLOP.control(
        first.year=2008,
        last.year=2015,
        no.species=3,
        no.VPA.predators=1,
        no.other.predators=1,
        species.names=c('Birds','Cod','Herring')
    )
print(OP)

 OP<-read.FLOP.control(file=file.path(data.path,'OP.dat'),n.VPA=11,n.other.pred=17,n.pred=21)

OP<-FLOP.control(
        first.year=2008,
        last.year=2011,
        no.species=4,
        no.VPA.predators=1,
        no.other.predators=1,
        species.names=c('Birds','Cod','Herring','Sprat')
    )
print(OP)

write.FLOP.control(OP,file=file.path(data.path,'a.dat'),nice=T)

SMS<-read.FLSMS.control()
nsp<-SMS@no.species
n.other.pred<-sum(SMS@species.info[,'predator']==2)
n.vpa.pred<-sum(SMS@species.info[,'predator']==1)
n.vpa=nsp-n.other.pred
n.pred<-n.other.pred+n.vpa.pred
OP<-read.FLOP.control(file=file.path(data.path,'OP.dat'),n.VPA=n.vpa,n.other.pred=n.other.pred,n.pred=n.pred)
print(OP)

write.FLOP.control(OP,file='a.dat',nice=T)

###

SMS<-read.FLSMS.control()
nsp<-SMS@no.species
n.other.pred<-sum(SMS@species.info[,'predator']==2)
n.vpa.pred<-sum(SMS@species.info[,'predator']==1)
n.vpa=nsp-n.other.pred
n.pred<-n.other.pred+n.vpa.pred

OPtrigger<-read.FLOPtrigger.control(file=file.path(data.path,'OP_trigger.dat'),n.VPA=n.vpa,n.other.pred=n.other.pred)
print(OPtrigger)

write.FLOPtrigger.control(OPtrigger,file='a.dat',nice=T)

## NS initialisation
SMS<-read.FLSMS.control()

OP<-FLOP.control(
        first.year=1974,
        last.year=2016,
        no.species=SMS@no.species,
        no.VPA.predators=sum(SMS@species.info[,'predator']==1),
        no.other.predators=sum(SMS@species.info[,'predator']==2),
        species.names=SMS@species.names
    )

write.FLOP.control(OP,file='OP_new.dat',nice=T)


suppressMessages(library(craze))

x = matrix(as.double(1:30), 10)
x_fml = fmlmat(x)

test = as.matrix(t(x_fml))
truth = t(x)
stopifnot(all.equal(test, truth))


input <- readLines('stdin')
x <- as.integer(input[1])

data <- data.frame(
    "id" = c(1:10),
    "grade" = c(75, 26, 54, 90, 86, 93, 48, 71, 66, 99)
)

print(length(data$grade[data$grade>x]))

SoloLearn/R/Data Structures - Grade Analysis.r


cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), function(s) {
  paste(s[order(as.double(s))], collapse=" ")
}), sep="\n")


data<-read.csv ("histogram.csv", header=FALSE)
colnames(data)<-c("from", "to", "value")
sort.order<-order(data$from)
data<-data[sort.order,]
num.rows = nrow(data)
one.before.last.row = num.rows-1
decimal.places=4
bar.names<-paste("[", round(data$from[1:one.before.last.row], decimal.places), ", ", round (data$to[1:one.before.last.row], decimal.places), ")")
bar.names<-c(bar.names, paste("[", round (data$from[num.rows], decimal.places) , ", ", round (data$to[num.rows], decimal.places), "]"))
par (mar=c(6, 11, 2, 2))
barplot (data$value, names.arg=bar.names, las=2, horiz=TRUE)


# 3. faza: Vizualizacija podatkov

#graf za najbolj pogostih po regijah !!!!!!!!!!!!!!!!!!!!!

povprecja.5pridelkov.regije <- povprecja.pridelkov.regije[grep('(Jabolka)|(Belo zelje)|(Breskve)|(Silažna koruza)|(Krompir)',povprecja.pridelkov.regije$kmetijska.kultura),]

graf.pridelki.regije <- povprecja.5pridelkov.regije %>% ggplot(aes(x = regija, y = povprecje, color=regija)) +
   geom_point(size=2) + facet_wrap(~kmetijska.kultura, ncol = 5, labeller = label_wrap_gen(width=20)) + theme(axis.text.x = element_text(size = 6, angle = 90, vjust = 0.5, hjust=1)) +
   ggtitle('Povprečje posameznih kmetijskih pridelkov po regijah' ) + ylab('Povprečje v t/ha') + xlab('Regija')

#diagram povprečnega števila pridelkov v slo v 10 letih
graf.povprecje.pridelkov.slovenija <- ggplot(aes(x = kmetijska.kultura, y = povprecje, group=1),
                                             data = povprecje.pridelkov.slovenija) + geom_col(fill='darkseagreen3') + coord_flip() +
   ggtitle("Povprečje kmetijskih \n kultur v Sloveniji") + ylab('Povprečje v t/ha') + xlab('Kmetijska kultura')

library(scales)
#graf za najbolj pogostih po regijah
vrstice1 <- grep('(Konji)|(Koze)|(Ovce)', povprecje.zivine.regije$vrsta.zivine)
povprecje.zivine.regije1 <- povprecje.zivine.regije[vrstice1,]
graf.zivina.regije1 <- povprecje.zivine.regije1 %>% ggplot(aes(x = regija, y = povprecje, color=regija)) +
   geom_point(size = 2) + facet_wrap(~vrsta.zivine, ncol = 3) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) +
   scale_y_continuous(labels = scales::comma) + ggtitle('Povprečno število živine po regijah') + ylab('Povprečje') + xlab('Regija')
vrstice2 <- grep('(Govedo)|(Perutnina)|(Prašiči)', povprecje.zivine.regije$vrsta.zivine)
povprecje.zivine.regije2 <- povprecje.zivine.regije[vrstice2,]
graf.zivina.regije2 <- povprecje.zivine.regije2 %>% ggplot(aes(x = regija, y = povprecje, color=regija)) +
   geom_point(size = 2) + facet_wrap(~vrsta.zivine, ncol = 3) + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) +
   scale_y_continuous(labels = scales::comma) + ggtitle('Povprečno število živine po regijah') + ylab('Povprečje') + xlab('Regija')

#diagram
graf.povprecje.zivine.slovenija <- ggplot(aes(x = vrsta.zivine, y = povprecje, group=1),
   data = povprecje.zivine.slovenija) + geom_col(fill='sienna4') + ggtitle("Povprečje živine v Sloveniji") +
   scale_y_continuous(labels = scales::comma) + ylab('Povprečje') + xlab('Vrsta živine')

#zemljevid

najvec.pridelkov.regije$regija[10] <- "Notranjsko-kraška"
najvec.pridelkov.regije$regija[9] <- "Spodnjeposavska"

najvec.zivine.regije$regija[10] <- "Notranjsko-kraška"
najvec.zivine.regije$regija[9] <- "Spodnjeposavska"

zemljevid <- uvozi.zemljevid("https://biogeo.ucdavis.edu/data/gadm3.6/shp/gadm36_SVN_shp.zip", "gadm36_SVN_1", encoding = "UTF-8")
zemljevid1 <- tm_shape(merge(zemljevid, najvec.pridelkov.regije, by.x="NAME_1", by.y="regija" )) + tm_style(style= "natural", bg.color = 'grey') +
   tm_polygons("povprecje",title="Povprečje kmetijskih \n pridelkov (t/ha)") + tm_layout(title="Povprečna razširjenost kmetijskih pridelkov po regijah") + tm_text('NAME_1', size = 0.7)
zemljevid2 <- tm_shape(merge(zemljevid, najvec.zivine.regije, by.x="NAME_1", by.y="regija" ))  + tm_style(style= "natural", bg.color = 'grey') +
   tm_polygons("povprecje",title="Povprečno število \n glav živine") + tm_layout(title="Povprečna razširjenost živinoreje po regijah") + tm_text('NAME_1', size = 0.7)


######################################
### Part 5: Intro to the Tidyverse ###
######################################
##
#

# What is the tidyverse?
#
# "The tidyverse is a set of packages that work in harmony because they share common data
# representations and API design. The tidyverse package is designed to make it easy to
# install and load core packages from the tidyverse in a single command." - Hadley Wickham
#
# Tidyverse for beginners cheatsheet:
# https://datacamp-community.s3.amazonaws.com/e63a8f6b-2aa3-4006-89e0-badc294b179c
#

### dplyr for Data Manipulation ###
#
# This exercise will focus mainly on the dplyr package for data manipulation
#
# Install library if necessary
#install.packages("dplyr")

# Load library
library(dplyr)

# This package use six functions called verbs:
#  * mutate()
#  * select()
#  * filter()
#  * summarize()
#  * arrange()
#  * group_by()
#
# These verbs are separated by a pipe symbol, %>% (COMMAND + Shift + M)
#
# Each verb takes input from the verb before the preceding pipe symbol
#
# In this section, we will be looking at the gapminder dataset. gapminder contains life
# expectancy, the population size, and the GDP percapita for countries around the world. This
# data has been collected in five-year increments.

# Install library if necessary
#install.packages("gapminder")

# Load library
library(gapminder)

# Let's start by looking at the whole dataset
gapminder

# Now just the data for 2002
gapminder %>%
  filter(year == 2002)

# Now just the life expectancy of every country in 2002
gapminder %>%
  filter(year == 2002) %>%
    select(lifeExp)

# Now just the life expectancy in the United States in 2002
gapminder %>%
  filter(year == 2002, country == "United States") %>%
    select(lifeExp)

# Mean life expectancy by country in 1997
gapminder %>%
  filter(year == 1997) %>%
    group_by(country) %>%
      summarize(mean_lifeExp = mean(lifeExp))

# Mean life expectancy by continent in 1997, ordered from highest to lowest
gapminder %>%
  filter(year == 1997) %>%
  group_by(continent) %>%
  summarize(mean_lifeExp = mean(lifeExp)) %>%
  arrange(desc(mean_lifeExp))

# Mean life expectancy by continent and year
gapminder %>%
  group_by(year, continent) %>%
  summarize(mean_lifeExp = mean(lifeExp))

# Mean life expectancy by continent and year
gapminder %>%
  filter(year == 1997) %>%
  group_by(continent) %>%
  mutate(mean_lifeExp = mean(lifeExp)) %>%
    arrange(desc(mean_lifeExp))

#######################
# Complete Exercise 6 #
#######################

#######################
# Complete Exercise 7 #
#######################


library(data.table)
library(stringr)

cmd_args <- commandArgs()
CURRENTDIR <- dirname(regmatches(cmd_args, regexpr("(?<=^--file=).+", cmd_args, perl=TRUE)))
ROOTDIR <- dirname(dirname(dirname(CURRENTDIR)))
OUTDIR <- file.path(ROOTDIR, "output", "one_planet")

# OUTDIR <- "../../output/one_planet"

SUBOUTDIR <- "SMMALA"

true_param <- 3.04452

nmcmc <- 110000
nburnin <- 10000
npostburnin <- nmcmc-nburnin

ci <- 6
pi <- 2

chains <- t(fread(
  file.path(OUTDIR, SUBOUTDIR, paste("chain", str_pad(ci, 2, pad="0"), ".csv", sep="")), sep=",", header=FALSE
))

chainmean <- mean(chains[, pi])

pdf(file=file.path(OUTDIR, SUBOUTDIR, "rv_one_planet_smmala_traceplot.pdf"), width=10, height=6)

plot(
  1:npostburnin,
  chains[, pi],
  type="l",
  ylim=c(2.95, 3.15),
  col="steelblue2",
  xlab="",
  ylab="",
  cex.axis=1.8,
  cex.lab=1.7,
  yaxt="n"
)

axis(
  2,
  at=seq(2.9, 3.15, by=0.05),
  labels=seq(2.9, 3.15, by=0.05),
  cex.axis=1.8,
  las=1
)

# abline(h=true_param, lwd=2, col="black")

dev.off()


# Dual clustering of users
# author: Alberto Lumbreras
###############################
library(abind)
library(coda)
library(mixtools)

source('conditionals_dual.r')
source('ars_alpha.r')
source('ars_beta.r')

# For debugging, this is useful:
if(FALSE){
  plot(mcmc(traces.b[complete.cases(traces.b),]))
  plot(mcmc(1/traces.noise_inv[complete.cases(traces.noise_inv),]))
  plot(mcmc(1/traces.intercept[complete.cases(traces.intercept),]))
  plot(mcmc(traces.coefficients[complete.cases(traces.coefficients),1:10]))
}

PLOTS <- TRUE
PLOTS.FREQUENCY <- 10 # iterations between two plots

gibbs <- function(A, B, P, y, z_init, iters=100, DP=TRUE, views=c('both', 'features', 'behaviors')){
  # Arguments:
  #   A: matrix with user features (one column per user)
  #   B: matrix with user coefficients (one column per user and only one row)
  #   P: Participation matrix (one column per thread, one row per user)
  #   y: Thread lengths (as much as columns in P)
  #   z_init: initial assignments (one per user)

  # For a Gaussian Mixture Model with a fixed number of clusters
  # set alpha = 0 and don't sample it
  # (alpha controls the probability of opening a new cluster)

  ######################################################
  views <- match.arg(views)

  threads.idx <- order(y) # for plotting

  A <- as.matrix(A)
  B <- as.matrix(B)
  N <- dim(A)[2]

  P <- as.matrix(P)
  y <- as.matrix(y)

  B_true <- B
  # traces
  traces.z <- matrix(NA, iters, N)
  traces.coefficients <- matrix(NA, iters, N)
  traces.intercept <- matrix(NA, iters, 3)
  traces.alpha <- matrix(NA, iters, 1)
  traces.a <- matrix(NA, iters, 5)
  traces.b <- matrix(NA, iters, 5)
  traces.noise_inv <- matrix(NA, iters,1)

  colnames(traces.a) <- c("n_clusters", "mean_mu_a0", "det(R_a0)", "det(W_a0)", "beta_a")
  colnames(traces.b) <- c("n_clusters", "mean_mu_b0", "det(R_b0)", "det(W_b0)", "beta_b")
  colnames(traces.alpha) <- c("alpha")
  colnames(traces.noise_inv) <- c("noise_inv")
  colnames(traces.intercept) <- c("intercept", "mu_intercept", "s_intercept")

  # data mean and covariance
  # used to centers priors on the data
  Sigma_a <- cov(t(A))
  Lambda_a <- solve(Sigma_a)
  mu_a <- as.matrix(rowMeans(A))

  Sigma_b <- cov(t(B))
  Lambda_b <- solve(Sigma_b)
  mu_b <- as.matrix(rowMeans(B))

  variance_y <- c(var(y))
  ##########################
  # Init state
  ##########################
  # init common variables
  alpha = 2
  z <- z_init

  # init feature variables
  D <- dim(A)[1]
  mu_a0 <- mu_a
  R_a0 <- solve(Sigma_a)
  W_a0 <- Sigma_a
  beta_a0 <- dim(A)[1]
  S_ar <- array(NA, dim=c(D, D, 100))
  mu_ar <- matrix(NA, D, 100)
  for (k in 1:length(unique(z))){
    mu_ar[,k] <- rowMeans(A[,z==k, drop=FALSE])
  }

  # init behavior variables
  D <- dim(B)[1]
  intercept <- 0
  noise_inv <- 1/variance_y
  mu_b0 <- mu_b
  R_b0 <- solve(Sigma_b)
  W_b0 <- Sigma_b
  beta_b0 <- dim(B)[1]
  S_br <- array(NA, dim=c(D, D, 100))
  mu_br <- matrix(NA, D, 100)
  print(k)
  for (k in 1:length(unique(z))){
    mu_br[,k] <- rowMeans(B[,z==k, drop=FALSE])
  }
  mu_intercept <- 0

  par(mfrow=c(1,3))

  for(i in 1:iters){

    cat('\n', i)

    # Active components
    K <- length(unique(z))

    ##############################################################
    # Sample variables in features view
    ##############################################################
    if((views=='features') || (views=='both')){
      # Sample component parameters
      for (k in 1:length(unique(z))){
        mask <- (z==k)
        S_ar[,,k] <- sample_S_ar(A[,mask, drop=FALSE], mu_ar[,k, drop=FALSE], beta_a0, W_a0)
        mu_ar[,k] <- sample_mu_ar(A[,mask, drop=FALSE], S_ar[,,k], mu_a0, R_a0)
      }

      # Sample hyperpriors
      mu_a0 <- sample_mu_a0(Lambda_a, mu_a, mu_ar[,1:K, drop=FALSE], R_a0)
      R_a0 <- sample_R_a0(Sigma_a, mu_ar[,1:K, drop=FALSE], mu_a0)
      W_a0 <- sample_W_a0(Lambda_a, S_ar[,,1:K, drop=FALSE], beta_a0)
      beta_a0 <- sample_beta_a0(S_ar[,,1:K, drop=FALSE], W_a0, init=beta_a0)
      traces.a[i,] <- c(length(unique(z)), mean(mu_a0), det(R_a0), det(W_a0), beta_a0)

      if(PLOTS && (i%%PLOTS.FREQUENCY==0)){
        plot(t(A[c(1,2),]), col=palette()[z+1])
        title(paste("Features", i))
        for(k in 1:K){
          ellipse(mu=mu_a0[c(1,2)], sigma=W_a0[c(1,2),c(1,2)], alpha = .25, lwd=5, npoints = 250, col="black")
          ellipse(mu=mu_ar[c(1,2),k], sigma=solve(S_ar[c(1,2),c(1,2),k]),  alpha = .25, lwd=3, npoints = 250, col=palette()[k+1])
        }
      }
    }

    ##############################################################
    # Sample variables in behaviors view
    ##############################################################
    if((views=='behaviors') || (views=='both')){
        # Sample component parameters
        for (k in 1:length(unique(z))){
          mask <- (z==k)
          S_br[,,k] <- sample_S_ar(B[,mask, drop=FALSE], mu_br[,k, drop=FALSE], beta_b0, W_b0)
          mu_br[,k] <- sample_mu_ar(B[,mask, drop=FALSE], S_br[,,k], mu_b0, R_b0)
          #if(abs(mu_br[,k]) < 0.0001){stop("bad mu_br")}
        }
        # Intercept has its own "component" parameters
        s_intercept <- sample_S_ar(as.matrix(intercept), as.matrix(mu_intercept), 1, 1)
        mu_intercept <- sample_mu_ar(as.matrix(intercept), as.matrix(s_intercept), 0, 1)

        # Sample hyperpriors
        mu_b0 <- sample_mu_a0(Lambda_b, mu_b, mu_br[,1:K, drop=FALSE], R_b0)
        R_b0 <- sample_R_a0(Sigma_b, mu_br[,1:K, drop=FALSE], mu_b0)
        W_b0 <- as.matrix(1) #sample_W_a0(Lambda_b, S_br[,,1:K, drop=FALSE], beta_b0)
        beta_b0 <- sample_beta_a0(S_br[,,1:K, drop=FALSE], W_b0, init=beta_b0)

        # This part is the only difference between the behavior view and the feature view
        # once B is sampled, the rest of the sampler sees B as regular features
        # Sample latent coefficients
        # Sample intercept from a gaussian prior with mean 0 and flat variance
        B <- tryCatch(sample_b(P, y, z, intercept, mu_br[,1:K, drop=FALSE], S_br[,,1:K, drop=FALSE], s_y=noise_inv),
                      error=function(e){
                        cat(paste("sample_b(): ", e))
                        return(B)
                      }
            )
        intercept <- sample_intercept(P, y, z, B, mu_intercept, s_intercept, s_y=noise_inv)
        noise_inv <- sample_noise_inv(P, y, B, variance_y)
        # cat("\nintercept:", intercept, "\tnoise:", 1/noise_inv, "W_b0:", W_b0)

        traces.b[i,] <- c(length(unique(z)), mean(mu_b0), det(R_b0), det(W_b0), beta_b0)
        traces.intercept[i,] <- c(intercept, mu_intercept, s_intercept)
        traces.coefficients[i,] <- c(B)
        traces.noise_inv[i,] <- noise_inv

        if(PLOTS && (i%%PLOTS.FREQUENCY==0)){
          plot(t(B), col=palette()[z+1])
          title("Behaviors")

          plot(y[threads.idx,], type='l', col="red", lwd=3)
          lines(t(P[,threads.idx])%*%t(B)+intercept)
          title("Predictions")
        }

    }

    #############################################################
    # Sample common parameters
    #############################################################
    # Sample assignments and concentration parameter

    # a little hack. the fixed model is a DP with alpha=0
    # the probability of a new cluster is 0
    if(DP){
      alpha <- sample_alpha(K = K, U = N)
    }
    else{
      alpha <- 0
    }

    if(TRUE){
      for (n in 1:N){
        if(views=='both'){
          res <- sample_z_dual(n, A, B, alpha, z,
                          mu_ar, S_ar, mu_a0, R_a0,  beta_a0, W_a0,
                          mu_br, S_br, mu_b0, R_b0, beta_b0, W_b0)
          z <- res$z
          mu_ar <- res$mu_ar
          S_ar <- res$S_ar
          mu_br <- res$mu_br
          S_br <- res$S_br
        }
        if(views=='features'){
          res <- sample_z(n, A, alpha, z,
                          mu_ar, S_ar, mu_a0, R_a0,  beta_a0, W_a0)
          z <- res$z
          mu_ar <- res$mu_ar
          S_ar <- res$S_ar
        }
        if(views=='behaviors'){
          res <- sample_z(n, B, alpha, z,
                          mu_br, S_br, mu_b0, R_b0,  beta_b0, W_b0)
          z <- res$z
          mu_br <- res$mu_ar
          S_br <- res$S_ar
        }
      }

      traces.z[i,] <- z
      traces.alpha[i,] <- alpha

      cat('\n',tabulate(z))
    }

  }

  res <- list(traces.a=traces.a,
              traces.b=traces.b,
              traces.z=traces.z,
              traces.alpha=traces.alpha,
              traces.coefficients=traces.coefficients,
              traces.intercept=traces.intercept,
              traces.noise_inv=traces.noise_inv)
  return(res)
}

if(FALSE){
  set.seed(1)

  PLOTS <- FALSE
  PLOTS.FREQUENCY <- 10 # iterations between two plots
  data(iris)
  data(geyser)

  # Load data
  ######################################
  # Choose one of the datasers
  dataset = 'confused_features'
  dataset = 'iris'
  dataset = 'clear'
  dataset = 'agreement'

  # Number of threads used for training
  nthreads.train <- 50

  nsamples <- 1000

  # Load dataset
  data.dir <- paste0('./data/', dataset, '/')
  df <- read.table(paste0(data.dir, 'data_users_50.csv'), sep='\t', header=TRUE)
  z_init <- df$z+1

  if(dataset=='iris'){
    A <- t(df[,2:4])
  }
  else{
    A <- t(df[,2:3])
  }

  B <- t(df$b)
  y <- read.table(paste0(data.dir, 'train_lengths_50.csv'), sep='\t', header=TRUE)
  P <- read.table(paste0(data.dir, 'train_participations_50.csv'), sep='\t', header=TRUE)

  nthreads <- dim(P)[2]
  idx.train <- sample(nthreads, nthreads.train)
  y <- y[idx.train,]
  P <- P[,idx.train]

  # Initialization of cluster assignments
  ########################################
  # Non recommended.
  z_init <- rep(1, dim(B)[2])

  # Recommended (bit not a good initialization technique either!).
  z_init <- sample(10, dim(B)[2], replace = TRUE)

  # guarantees that there are no gaps!
  # http://stackoverflow.com/questions/35141155/create-n-random-integers-with-no-gaps
  tb <- table(z_init);
  z_init <- rep(seq(tb),tb)

  # run !
  #############
  #res <- gibbs(A, B, P, y, z_init=z_init, iters=nsamples, DP=F)

  z_init <- kmeans(t(A), 5)$cluster
  res <- gibbs(A, B, P, y, z_init=z_init, iters=nsamples, DP=TRUE, views='behaviors')

  # Plot traces
  #######################
  traces.a <- res$traces.a
  traces.b <- res$traces.b
  traces.z <- res$traces.z
  chains <- mcmc(traces.a)
  plot(chains)
  print(effectiveSize(chains))
  chains <- mcmc(traces.b)
  plot(chains)
  print(effectiveSize(chains))
}


source('black-scholes.r')

par(family="sans", mar=c(4,4,1,2)+0.1, mgp=c(2,1,0))

dump <- function(filename) {
  fn <- paste("images/", filename, ".pdf", sep="")
  dev.copy2pdf(file=fn, family="sans")
}

plot(function(S){bscall.value(S,100,0.5,0.05,0.20)}, 70, 130, col="#19304f", lwd=3, xlab="", ylab="")
plot(function(S){bsput.value(S,100,0.5,0.05,0.20)}, 70, 130, add=T, col="#d63d00", lwd=3)
title(main='', xlab='Stock Price', ylab='Value')
legend('topleft', c('Call', 'Put'), lwd=3, col=c("#19304f","#d63d00"), bty='n')
abline(v=100,lty=3)
dump('bs-value')

plot(function(S){bscall.delta(S,100,0.5,0.05,0.20)}, 70, 130, col="#19304f", lwd=3, xlab="", ylab="", ylim=c(-1,1))
plot(function(S){bsput.delta(S,100,0.5,0.05,0.20)}, 70, 130, add=T, col="#d63d00", lwd=3)
abline(0,0)
title('', xlab='Stock Price', ylab='Delta')
legend('topleft', c('Call', 'Put'), lwd=3, col=c("#19304f","#d63d00"), bty='n')
dump('bs-delta')

plot(function(S){bscall.delta(S,100,0.5,0.05,0.20)}, 70, 130, col="#19304f", lwd=3, xlab="", ylab="")
plot(function(S){bscall.delta(S,100,0.5,0.05,0.10)}, 70, 130, col="#d63d00", lwd=3, xlab="", ylab="", ylim=c(0,30), add=T)
plot(function(S){bscall.delta(S,100,0.5,0.05,0.05)}, 70, 130, col="#227711", lwd=3, xlab="", ylab="", ylim=c(0,30), add=T)
title('', xlab='Stock Price', ylab='Delta')
legend('topleft', c('sigma = 0.2','sigma = 0.1','sigma = 0.05'), lwd=3, col=c("#19304f","#d63d00","#227711"), bty='n')
dump('bs-delta-sigma')

plot(function(S){bscall.delta(S,100,0.5,0.05,0.20)}, 70, 130, col="#19304f", lwd=3, xlab="", ylab="")
plot(function(S){bscall.delta(S,100,0.2,0.05,0.20)}, 70, 130, col="#d63d00", lwd=3, xlab="", ylab="", ylim=c(0,30), add=T)
plot(function(S){bscall.delta(S,100,0.05,0.05,0.20)}, 70, 130, col="#227711", lwd=3, xlab="", ylab="", ylim=c(0,30), add=T)
title('', xlab='Stock Price', ylab='Delta')
legend('topleft', c('TTM = 0.5','TTM = 0.2','TTM = 0.05'), lwd=3, col=c("#19304f","#d63d00","#227711"), bty='n')
dump('bs-delta-ttm')

plot(function(S){bscall.gamma(S,100,0.5,0.05,0.20)}, 70, 130, col="#19304f", lwd=3, xlab="", ylab="", ylim=c(0,0.03))
title('', xlab='Stock Price', ylab='Gamma')
legend('topleft', c('Call Gamma'), lwd=3, col=c("#19304f","#d63d00"), bty='n')
dump('bs-gamma')

plot(function(S){bscall.value(S,100,0.5,0.05,0.20)}, 70, 130, col="#19304f", lwd=3, xlab="", ylab="")
plot(function(S){bscall.value(S,100,0.2,0.05,0.20)}, 70, 130, col="#d63d00", lwd=3, xlab="", ylab="", ylim=c(0,30), add=T)
plot(function(S){bscall.value(S,100,0.01,0.05,0.20)}, 70, 130, col="#227711", lwd=3, xlab="", ylab="", ylim=c(0,30), add=T)
title('', xlab='Stock Price', ylab='Value')
legend('topleft', c('TTM = 0.5','TTM = 0.2','TTM = 0.01'), lwd=3, col=c("#19304f","#d63d00","#227711"), bty='n')
dump('bs-value-ttm')

plot(function(S){bscall.theta(S,100,0.5,0.05,0.20)}, 70, 130, col="#19304f", lwd=3, xlab="", ylab="", ylim=c(-10,8))
plot(function(S){bsput.theta(S,100,0.5,0.05,0.20)}, 70, 130, add=T, col="#d63d00", lwd=3)
abline(0,0)
title('', xlab='Stock Price', ylab='Theta')
legend('topleft', c('Call', 'Put'), lwd=3, col=c("#19304f","#d63d00"), bty='n')
dump('bs-theta')

plot(function(S){bscall.gamma(S,100,0.5,0.05,0.20)}, 70, 130, col="#19304f", lwd=3, xlab="", ylab="", ylim=c(0,0.07))
plot(function(S){bscall.gamma(S,100,0.2,0.05,0.20)}, 70, 130, col="#d63d00", lwd=3, xlab="", ylab="", add=T)
plot(function(S){bscall.gamma(S,100,0.1,0.05,0.20)}, 70, 130, col="#227711", lwd=3, xlab="", ylab="", add=T)
title('', xlab='Stock Price', ylab='Gamma')
legend('topleft', c('TTM = 0.5','TTM = 0.2','TTM = 0.1'), lwd=3, col=c("#19304f","#d63d00","#227711"), bty='n')
dump('bs-gamma-ttm')

plot(function(S){bscall.theta(S,100,0.5,0.05,0.20)}, 70, 130, col="#19304f", lwd=3, xlab="", ylab="", ylim=c(-15,5))
plot(function(S){bscall.theta(S,100,0.2,0.05,0.20)}, 70, 130, col="#d63d00", lwd=3, xlab="", ylab="", add=T)
plot(function(S){bscall.theta(S,100,0.1,0.05,0.20)}, 70, 130, col="#227711", lwd=3, xlab="", ylab="", add=T)
abline(0,0)
title('', xlab='Stock Price', ylab='Theta')
legend('topleft', c('TTM = 0.5','TTM = 0.2','TTM = 0.1'), lwd=3, col=c("#19304f","#d63d00","#227711"), bty='n')
dump('bs-theta-ttm')

plot(function(S){bscall.vega(S,100,0.5,0.05,0.20)}, 70, 130, col="#19304f", lwd=3, xlab="", ylab="", ylim=c(0,30))
title('', xlab='Stock Price', ylab='Vega')
legend('topleft', c('Call Vega'), lwd=3, col=c("#19304f","#d63d00"), bty='n')
dump('bs-vega')


y=50
n=50
alpha=.05
# If we used the standard estimator of pie
pie=y/n
#  The point estimator would be given by
pie_adj=(n+(3/8))/(n+(3/4))
print(pie_adj)
# A 95% confidence interval for pie would be
left_i=(alpha/2)^(1/n)
right_i=1
print(left_i)
print(right_i)


# Function 'meanAndVarianceDF'
# Killian Martin--Horgassan
# 01-06-2015

# Computes the mean and variance for the supposedly normal
# log-gross returns (Black-Scholes model) from the empirical
# data on the 5 stocks

source("meanAndVariance.r")

meanAndVarianceDF <- function(df) {
	stock1 <- meanAndVariance(df$V1)
    stock2 <- meanAndVariance(df$V2)
	stock3 <- meanAndVariance(df$V3)
	stock4 <- meanAndVariance(df$V4)
	stock5 <- meanAndVariance(df$V5)

	Mean <- c(stock1[1], stock2[1], stock3[1], stock4[1], stock4[1])
	Variance <- c(stock1[2], stock2[2], stock3[2], stock4[2], stock4[2])

	output <- data.frame(Mean, Variance)
}


#' Calculate pooled dispersion via MMAD distribution or median
#'
#' \code{distE.ol} calculates the overlap of distributions given the effect size vector
#' @param x A vector of effect sizes
#' @export distE.ol

# returns the overlap of the two distributions
# calculated from effect size vector
# note that this does not use the Aitchison mean function
distE.ol <- function(x){
	e.size <- c(sum(x > 0), sum(x < 0)) + 0.5
	l.size <- log(e.size) - mean(log(e.size))
	p.size <- exp(l.size - max(l.size))
	return(min(p.size/sum(p.size)))
}


REBOL [
]

lib: do %../face-to-pdf-lib.r

fnt: make face/font [ name: "/usr/share/fonts/gnu-free/FreeSans.ttf" ]

dr1: [ font fnt text 50x10 vectorial "Rotated" box 100x60 200x160 rotate 30 100x100 box 100x60 200x160 ]
dr2: [ font fnt text 50x10 vectorial "Matrix" box 100x60 200x160  matrix [ 1 0 0.1 0.9 0 30 ] box 100x60 200x160 ]
dr3: [ font fnt text 50x10 vectorial "Scale" box 100x60 200x160  matrix [ 0.9 0 0 0.9 0 0 ] box 100x60 200x160 ]
dr4: [ font fnt box 50x10 100x72 text 50x10 vectorial "Text test" ]

dr5: [ font fnt text 50x10 vectorial "Skewed" box 100x60 200x130 skew -50 box 100x60 200x130 ]

dr6: [ font fnt text 20x0 vectorial "Invert matrix"
	line 50x50 50x150 rotate 30
	line 50x50 50x150
	]

dr: [ pen black fill-pen none line-width 1
    push dr1 translate 200x0
    push dr2 translate 200x0
    push dr3 translate 200x0
    push dr4 translate 0x100
    push dr5
    reset-matrix translate 0x200
    push dr6
]

;dr: [ pen black box 5x10 200x100 scale 0.9 1.1 line 5x10 200x100 ]

view/new  layout [ text "test av geometrier"
    f: box yellow * 1.5 900x400 effect [ draw dr ]
    key #"q" [quit]
]

write %geometries.pdf lib/face-to-pdf f

wait none


#Addition
4+4
#Substraction
52-22
#Division
15/3
#Multiplication
6*3
#Division
3^2
#Modulus
100%%10
3^2:

#Assigning values
a<-4
b<-5
a+b # Calculation


# https://www.r-spatial.org/r/2018/10/25/ggplot2-sf.html
# https://covidtracking.com/api/
# https://covid.ourworldindata.org
library(R0)
library(plotly)
library(rnaturalearth)
library(rnaturalearthdata)
library(rgeos)
library(data.table)
library(countrycode)
library(viridis)
library(gganimate)
library(gifski)
library(tidyverse)
library(lmtest)
library(WDI)
library(plotly)
library(USAboundaries)
library(sf)
library(fuzzyjoin)
library(tigris)
library(scales)
library(ggthemes)
library(usmap)
library(cowplot)
library(RcppRoll)
library(sqldf)

r0_window_size = 7
# questions to answer:
# how have case / death rates changed recently?
# how have transmission rates changes over time?
# what do we know about mortality rates?
# how many cases are missing?
# what is the geographic distribution of cases, and how does proximity affect transmission?

setwd("~/Public_Policy/Projects/COVID-19")
all_covid_data_diffs_dates = read_csv('data/us_covid_data_by_state_with_calcs.csv')
all_covid_data_diffs_dates$cum_diff_value_total_tests

filter(all_covid_data_diffs_dates, location %in% c('LA', 'WA', 'NY', 'CA', 'MI')) %>%
  ggplot(aes(date, cum_diff_value_total_deaths)) +
  facet_wrap(~location, scales = 'free_y') +
  geom_bar(stat = 'identity')

lm(cum_diff_value_tests_with_results ~ time, data = all_covid_data_diffs_dates) %>%
  summary()
filter(all_covid_data_diffs_dates, location %in% c('LA', 'WA', 'NY', 'CA', 'MI')) %>%
  ggplot(aes(date, cum_diff_value_total_tests)) +
  facet_wrap(~location, scales = 'free_y') +
  geom_area(alpha = 0.5, colour = 'black') +
  geom_point() +
  geom_area(aes(date, cum_diff_value_total_cases), fill = 'red', alpha = 0.5) +
  geom_point(aes(date, cum_diff_value_total_cases), colour = 'red')

filter(all_covid_data_diffs_dates, location == 'LA') %>%
  ggplot(aes(date, cum_diff_value_total_tests)) +
  geom_area() +
  geom_area(aes(date, cum_diff_value_total_cases), fill = 'red')

ggplot(all_covid_data_diffs_dates, aes(cum_diff_value_total_tests, cum_diff_value_total_cases)) +
  geom_point()

latest_state_data = filter(all_covid_data_diffs_dates, location != 'United States', date == max(date)) %>%
  arrange(-value_total_cases)

ggplot(selected_early_states, aes(date, r0_rolling_lead_7)) +
  facet_wrap(~location_name) +
  # geom_line(aes(y = r0_rolling)) +
  geom_point(aes(colour = weekend_ind))  +
  # stat_smooth(method = 'gam', se = F) +
  geom_line() +
  # geom_line(aes(y = r0_rolling_lead_7), colour = 'red', linetype = 'dashed') +
  geom_hline(aes(yintercept = 2.5)) +
  geom_hline(aes(yintercept = 1)) +
  geom_vline(data = us_lockdown_dates %>% filter(location_name %in% unique(selected_early_states$location_name)), aes(xintercept = lockdown_start))

# how effective are lockdowns?
lockdown_r0_stats = group_by(all_covid_data_diffs_dates, lockdown_period) %>%
  summarize(
    obs = n(),
    obs_r0_rolling = length(r0_rolling[!is.na(r0_rolling)]),
    obs_r0_rolling_lead_7 = length(r0_rolling_lead_7[!is.na(r0_rolling_lead_7)]),
    obs_effective_r0_interpolated = length(effective_r0_interpolated[!is.na(effective_r0_interpolated)]),
    obs_effective_r0_interpolated_lead_7 = length(effective_r0_interpolated_lead_7[!is.na(effective_r0_interpolated_lead_7)]),
    mean_effective_r0 = mean(effective_r0_interpolated, na.rm = T),
    median_effective_r0 = median(effective_r0_interpolated, na.rm = T),
    mean_effective_r0_interpolated_lead_7 = mean(effective_r0_interpolated_lead_7, na.rm = T),
    median_effective_r0_interpolated_lead_7 = median(effective_r0_interpolated_lead_7, na.rm = T),
    median_r0_rolling = median(r0_rolling, na.rm = T),
    mean_r0_rolling = mean(r0_rolling, na.rm = T),
    median_r0_rolling_lead_7 = median(r0_rolling_lead_7, na.rm = T),
    mean_r0_rolling_lead_7 = mean(r0_rolling_lead_7, na.rm = T)
  )

# https://www.medrxiv.org/content/10.1101/2020.04.02.20051466v1.full.pdf
# https://www.reuters.com/article/us-health-coronavirus-britain-spread/preliminary-study-finds-uk-lockdown-is-slowing-spread-of-covid-19-idUSKBN21J56W

ggplot(all_covid_data_diffs_dates, aes(lockdown_period, r0_rolling_lead_7, fill = lockdown_period))+
  geom_boxplot(weight = 0, colour = 'gray') +
  scale_y_continuous(limits = c(0, 20)) +
  theme_bw() +
  labs(x = '', y = '7-Day R0', title = 'COVID-19 Rolling 7-Day R0 by Lockdown Status',
       subtitle = sprintf('U.S. States, through %s', max(all_covid_data_diffs_dates$date) %>% format('%B %d'))
  ) +
  geom_text(data = lockdown_r0_stats, aes(y = median_r0_rolling_lead_7, label = round(median_r0_rolling_lead_7, 2)), size = 3.5, fontface = 'bold') +
  scale_fill_hue(guide = F)
ggsave('output/effective_r0_by_lockdown_status.png', height = 6, width = 6, units = 'in', dpi = 800)

latest_state_data$pre_lockdown_midpoint = with(latest_state_data, lockdown_start - as.numeric(lockdown_start - as.Date('2020-03-09'))/2)
latest_state_data$post_lockdown_midpoint = latest_state_data$lockdown_start + as.numeric(max(latest_state_data$date) - r0_window_size - r0_window_size + 3 - latest_state_data$lockdown_start)/2

# filter(all_covid_data_diffs_dates, location == 'CA') %>%
#   select(date, cum_diff_value_total_cases,r0_rolling, r0_rolling_lead_7) %>% View()

all_covid_data_diffs_dates %>% filter(location %in% c('NY', 'CA', 'WA'), !is.na(r0_rolling_lead_7), days_since_case_20 >= 5) %>%
  ggplot(aes(date, r0_rolling_lead_7)) +
  theme_bw() +
  facet_wrap(~location_name) +
  geom_vline(data = latest_state_data %>% filter(location %in% c('NY', 'CA', 'WA')), aes(xintercept = lockdown_start), size = 0.75, colour = 'gray50') +
  geom_bar(stat = 'identity', aes(alpha = cum_diff_value_total_cases, fill = weekend_ind)) +
  scale_alpha(name = 'Daily New Cases', range = c(0.4, 1)) +
  # scale_fill_viridis_d(name ='', option = 'D') +
  scale_fill_manual(name = '', values = c('Week Day' = 'steelblue', 'Weekend' = 'orange')) +
  # scale_fill_viridis(name = 'Daily New Cases', option = 'C') +
  geom_hline(aes(yintercept = 1), colour = 'red', size = 0.5) +
  geom_hline(aes(yintercept = 2.28), linetype = 'dashed', colour = 'black', size = 0.5) +
  scale_y_continuous(breaks = seq(0, 25, by = 1)) +
  # stat_smooth(method = 'gam') +
  labs(
    y = 'Estimated Seven-Day R0 of New Cases', x = '',
    title = 'COVID-19 Transmission Rates for Early U.S. States',
    subtitle = sprintf('Through %s. Dashed line shows average COVID-19 reproduction number (R0), red solid line shows R0=1, below which a pandemic slows.', max(all_covid_data_diffs_dates$date) %>% format('%B %d')) %>% str_wrap(100),
    caption = 'Chart: Taylor G. White\nData: covidtracking.com'
  ) +
  theme(
    legend.position = 'bottom',
    strip.text = element_text(face = 'bold', colour = 'white'),
    strip.background = element_rect(fill = 'black'),
    plot.subtitle = element_text(size = 11, face = 'italic'),
    plot.caption = element_text(hjust = 0, face = 'italic', size = 10),
    plot.title = element_text(size = 16),
    panel.grid.minor = element_blank()
    # plot.background = element_rect(fill = 'black'),
    # panel.background = element_rect(fill = 'black'),
    # panel.grid.minor = element_blank()
  ) +
  geom_text(data = latest_state_data %>% filter(location %in% c('NY', 'CA', 'WA')), aes(x = pre_lockdown_midpoint , y = 23, label = 'Pre-Lockdown'), fontface = 'italic', size = 3) +
  geom_text(data = latest_state_data %>% filter(location %in% c('NY', 'CA', 'WA')), aes(x = post_lockdown_midpoint , y = 23, label = 'Post-Lockdown'), fontface = 'italic', size = 3, hjust = 0.5) +
  geom_text(data = latest_state_data %>% filter(location %in% c('NY', 'CA', 'WA')), aes(x = lockdown_start, y = 15, label = format(lockdown_start, '%B %d')), fontface = 'bold', size = 3.5)
ggsave('output/rolling_ro_by_early_states.png', height = 6, width = 9, units = 'in', dpi = 800)


library(FLCore)
data(ple4)  # to get an "approved" object

summary(ple4)

##############################
SMS.dat<-read.FLSMS.control(file=file.path(data.path,'SMS.dat'))

SMS.stocks<-SMS2FLStocks(sumfile=file.path(data.path,'summary.out'),
            bio.interact=F, read.input=TRUE, read.output=TRUE,control=SMS.dat)
summary(SMS.stocks)

summary(SMS.stocks[[1]])

summary(ple4)

slotNames(SMS.stocks[[1]])
slotNames(ple4)

plot(ple4)
plot(SMS.stocks[[1]])

seasonSums(SMS.stocks[[1]]@catch)
SMS.stocks[[1]]@catch.n
SMS.stocks[[1]]@stock.n
SMS.stocks[[1]]@stock.wt
SMS.stocks[[1]]@mat

## what methods are available
showMethods(class="FLSR")
################################################################################

#create an FLSR object
ple4.sr<-as.FLSR(ple4)
summary(ple4.sr)

ms.sr<-as.FLSR(SMS.stocks[[1]])

ms.sr<-lapply(SMS.stocks,as.FLSR)
summary(ms.sr)
summary(ms.sr[[1]])

# The rec and ssb slots have now been filled
ssb(ms.sr[[1]])
rec(ms.sr[[1]])
# ssb does not work !

# do it without quarters

SMS.stocks<-lapply(SMS.stocks,function(x){ window(x, start = 1974, end = 2010)} )

sp<-2
SMS.stocks[[sp]]@range

stockDims <- FLQuant(dimnames=list(age = SMS.stocks[[sp]]@range["min"]:SMS.stocks[[sp]]@range["min"],
                                   year = SMS.stocks[[sp]]@range["minyear"]:SMS.stocks[[sp]]@range["maxyear"], unit = 'thousands',
             season = 'all', area = 'unique'))
sr <- FLSR(name =sp.names[sp], desc = "test",
            rec = stockDims)

summary(sr)
sr@rec<-SMS.stocks[[sp]]@stock.n[1,,,3,,]  #third quarter data age 0
sr@ssb<-apply(SMS.stocks[[sp]]@stock.n[,,,1,,]*SMS.stocks[[sp]]@stock.wt[,,,1,,]*SMS.stocks[[sp]]@mat[,,,1,,],2,sum)
units(sr@rec)<-  "thousands"
units(sr@ssb)<-  "tonnes"

model(sr)<-ricker()
model(sr)
summary(sr)
summary(ple4.sr)  # compare

sr<-fmle(sr)
plot(sr)

# det virker ikke med kvartals data
library(FLBRP)

## ## estimate reference points. Create the corresponding FLBRP object
# plaice example
pleBrp<-FLBRP(ple4)
summary(pleBrp)

harvest(pleBrp)

## check that it worked!
sweep(harvest(pleBrp),1,catch.sel(pleBrp),"/")
apply(harvest(pleBrp)[range(pleBrp)[["minfbar"]]:range(pleBrp)[["maxfbar"]],],2,mean)

## other estimated quantities-at-age
stock.n(pleBrp)
landings.n(pleBrp)
discards.n(pleBrp)

yield(pleBrp)
rec(pleBrp)
ssb(pleBrp)
profit(pleBrp)
pleBrp<-brp(pleBrp)
## inspect reference points
refpts(pleBrp)

# SMS
Brp<-FLBRP(SMS.stocks[[sp]])
summary(Brp)

Brp<-brp(Brp)
refpts(Brp)

## historic observations
fbar.obs(    Brp)
yield.obs(   Brp)
landings.obs(Brp)
discards.obs(Brp)
rec.obs(     Brp)
ssb.obs(     Brp)
profit.obs(  Brp)


# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

#' Estimate variance components using EMMA
#'
#' Build date: August 30, 2016
#' Last update: January 27, 2017
#'
#' @author EMMA (Kang et. al. Genetics, 2008), Modified only for speed up by Xiaolei Liu and Lilin Yin
#'
#' @param y phenotype, n * 2
#' @param X covariate matrix, the first column is 1s
#' @param K Kinship matrix
#' @param ngrids parameters for estimating vg and ve
#' @param llim parameters for estimating vg and ve
#' @param ulim parameters for estimating vg and ve
#' @param esp parameters for estimating vg and ve
#'
#' @return
#' Output: REML - maximum log likelihood
#' Output: delta - exp(root)
#' Output: ve - residual variance
#' Output: vg - genetic variance
#'
#' @export
#'
#' @examples
#' phePath <- system.file("extdata", "07_other", "mvp.phe", package = "rMVP")
#' phenotype <- read.table(phePath, header=TRUE)
#' print(dim(phenotype))
#' genoPath <- system.file("extdata", "06_mvp-impute", "mvp.imp.geno.desc", package = "rMVP")
#' genotype <- attach.big.matrix(genoPath)
#' print(dim(genotype))
#'
#' K <- MVP.K.VanRaden(genotype)
#' vc <- MVP.EMMA.Vg.Ve(y=phenotype[,2], X=matrix(1, nrow(phenotype)), K=K)
#' print(vc)
#'
MVP.EMMA.Vg.Ve <-
function(y, X, K, ngrids=100, llim=-10, ulim=10, esp=1e-10) {
    # NA in phenotype
    idx <- !is.na(y)
    y <- y[idx]
    X <- as.matrix(X[idx, ])
    K <- K[idx, idx]

    if(!is.numeric(y))	y <- as.numeric(as.character(y))
    emma.delta.REML.LL.wo.Z <- function(logdelta, lambda, etas)
    {
        nq <- length(etas)
        delta <-  exp(logdelta)
        return( 0.5 * (nq * (log(nq/(2 * pi))-1-log(sum(etas * etas/(lambda + delta))))-sum(log(lambda + delta))) )
    }
    emma.eigen.R.wo.Z=function(K, X) {
        n <- nrow(X)
        q <- ncol(X)

        XX <- crossprod(X)
        iXX <- try(solve(XX), silent = TRUE)
        if(inherits(iXX, "try-error")){
            #library(MASS)
            iXX <- ginv(XX)
        }

        SS1 <- X %*% iXX
        SS2 <- tcrossprod(SS1, X)
        S <- diag(n)-SS2

        eig <- eigen(S %*% (K + diag(1, n)) %*% S, symmetric=TRUE)#S4 error here

        stopifnot(!is.complex(eig$values))
        return(list(values=eig$values[1:(n-q)]-1, vectors=eig$vectors[, 1:(n-q)]))
    }
    eig.R=emma.eigen.R.wo.Z(K=K, X=X)
    n <- length(y)
    t <- nrow(K)
    q <- ncol(X)

    stopifnot(ncol(K) == t)
    stopifnot(nrow(X) == n)

    etas <- crossprod(eig.R$vectors, y)

    logdelta <- (0:ngrids)/ngrids * (ulim-llim) + llim
    m <- length(logdelta)
    delta <- exp(logdelta)
    Lambdas <- matrix(eig.R$values, n-q, m) + matrix(delta, n-q, m, byrow=TRUE)
    Etasq <- matrix(etas * etas, n-q, m)
    LL <- 0.5 * ((n-q) * (log((n-q)/(2 * pi))-1-log(colSums(Etasq/Lambdas)))-colSums(log(Lambdas)))
    dLL <- 0.5 * delta * ((n-q) * colSums(Etasq/(Lambdas * Lambdas))/colSums(Etasq/Lambdas)-colSums(1/Lambdas))
    optlogdelta <- vector(length=0)
    optLL <- vector(length=0)
    if( dLL[1] < esp ) {
        optlogdelta <- append(optlogdelta, llim)
        optLL <- append(optLL, emma.delta.REML.LL.wo.Z(llim, eig.R$values, etas))
    }
    if( dLL[m-1] > 0-esp ) {
        optlogdelta <- append(optlogdelta, ulim)
        optLL <- append(optLL, emma.delta.REML.LL.wo.Z(ulim, eig.R$values, etas))
    }
    for(i in 1:(m-1) ){
        if( ( dLL[i] * dLL[i + 1] < 0 ) && ( dLL[i] > 0 ) && ( dLL[i + 1] < 0 ) ) {
            emma.delta.REML.dLL.wo.Z <- function(logdelta, lambda, etas) {
                nq <- length(etas)
                delta <- exp(logdelta)
                etasq <- etas * etas
                ldelta <- lambda + delta
                return( 0.5 * (nq * sum(etasq/(ldelta * ldelta))/sum(etasq/ldelta)-sum(1/ldelta)) )
            }
            r <- uniroot(emma.delta.REML.dLL.wo.Z, lower=logdelta[i], upper=logdelta[i + 1], lambda=eig.R$values, etas=etas)
            optlogdelta <- append(optlogdelta, r$root)
            emma.delta.REML.LL.wo.Z <- function(logdelta, lambda, etas) {
                nq <- length(etas)
                delta <-  exp(logdelta)
                return( 0.5 * (nq * (log(nq/(2 * pi))-1-log(sum(etas * etas/(lambda + delta))))-sum(log(lambda + delta))) )
            }
            optLL <- append(optLL, emma.delta.REML.LL.wo.Z(r$root, eig.R$values, etas))
        }
    }
    maxdelta <- exp(optlogdelta[which.max(optLL)])
    #handler of grids with NaN log
    replaceNaN<-function(LL) {
        index=(LL == "NaN")
        if(length(index)>0) theMin=min(LL[!index])
        if(length(index)<1) theMin="NaN"
        LL[index]=theMin
        return(LL)
    }
    optLL=replaceNaN(optLL)
    maxLL <- max(optLL)
    maxva <- sum(etas * etas/(eig.R$values + maxdelta))/(n-q)
    maxve <- maxva * maxdelta
    return (list(REML=maxLL, delta=maxdelta, ve=maxve, vg=maxva))
}# end of MVP.EMMA.Vg.Ve function


# Import libraries
library(ggplot2)

# Load training dataset
print("Loading training dataset")
train_data <- read.csv("data/train.csv")
print("Done.")

# Print summary of input datasets
print("Summary of training dataset:")

print("Columns:")
names(train_data)

print(paste("No. of training instances:", nrow(train_data)))
print(paste("% positive class (Survived):", sum(train_data$Survived == 1) / nrow(train_data) * 100))
print(paste("% negative class (Not-survived):", sum(train_data$Survived == 0) / nrow(train_data) * 100))

summary(train_data)

print(paste("Data type:", class(train_data$Pclass)))
print("Summary:")
summary(train_data$Pclass)
options(repr.plot.width=3, repr.plot.height=3)
qplot(train_data$Pclass, bins=3, asp=1)

features <- data.frame(Pclass=as.integer(train_data$Pclass))
summary(features)

print(paste("Data type:", class(train_data$Name)))
print(paste("No. of unique namess:", length(levels(train_data$Name))))
print(paste("Missing Data:", any(is.na(train_data$Name)) || is.null(train_data$Name)))
print("Samnple:")
print(as.character(train_data$Name[1:5]))

NameSplit <- strsplit(as.character(train_data$Name),", ")

LastName <- sapply(NameSplit, function(x) return(x[1]))
print(paste("No. of unique last names:", length(unique(LastName))))

NameSplit <- sapply(NameSplit, function(x) return(x[2]))
NameSplit <- strsplit(NameSplit,". ")

NameTitle <- as.factor(sapply(NameSplit, function(x) return(x[1])))
print("Summary of name titles:")
summary(NameTitle)

features$LastName <- as.factor(LastName)
features$NameTitle <- as.factor(NameTitle)
summary(features)

print(paste("Data type:", class(train_data$Sex)))
print("Summary:")
summary(train_data$Sex)

features$Sex <- train_data$Sex
summary(features)

print(paste("Data type:", class(train_data$Age)))
print("Summary:")
summary(train_data$Age)

print(paste("% Missing data:", sum(is.na(train_data$Age), na.rm=TRUE)/length(train_data$Age)*100))
print(paste("% Missing data (Survived):", sum(train_data$Survived[is.na(train_data$Age)])
                                                    /sum(is.na(train_data$Age))*100))
print(paste("% Missing data (Not Survived):", sum(train_data$Survived[is.na(train_data$Age)]==0)
                                                    /sum(is.na(train_data$Age))*100))

print(paste("Median Age:", median(train_data$Age, na.rm=TRUE)))
print(paste("Median Age (Survived):", median(train_data$Age[train_data$Survived == 1], na.rm=TRUE)))
print(paste("Median Age (Not Survived):", median(train_data$Age[train_data$Survived == 0], na.rm=TRUE)))

print(paste("% kids (<18 yrs):", length(train_data$Age[train_data$Age < 18])/length(train_data$Age)*100))
print(paste("% elders (>60 yrs):", length(train_data$Age[train_data$Age > 60])/length(train_data$Age)*100))

options(repr.plot.width=4, repr.plot.height=3)
qplot(train_data$Age[!is.na(train_data$Age)], bins=30)

Age <- train_data$Age
Age[is.na(train_data$Age) & train_data$Survived == 1] <- median(train_data$Age[train_data$Survived == 1], na.rm=TRUE)
Age[is.na(train_data$Age) & train_data$Survived == 0] <- median(train_data$Age[train_data$Survived == 0], na.rm=TRUE)
features$Age <- as.integer(Age)
summary(features)

print(paste("Data type:", class(train_data$SibSp)))
print("Summary:")
summary(train_data$SibSp)
print(paste("% Passengers with Siblings/ Spouses:", nrow(train_data[train_data$SibSp > 0,]) / nrow(train_data) * 100))

features$SibSp <- train_data$SibSp
summary(features)

print(paste("Data type:", class(train_data$Parch)))
print("Summary:")
summary(train_data$Parch)
print(paste("% Passengers with Parents/ Children:", nrow(train_data[train_data$Parch > 0,]) / nrow(train_data) * 100))

features$Parch <- train_data$Parch
summary(features)

print(paste("Data type:", class(train_data$Ticket)))
print(paste("No. of levels:", length(levels(train_data$Ticket))))
print("Sample:")
train_data$Ticket[1:10]

TktSplit <- strsplit(as.character(train_data$Ticket), " ")

oldw <- getOption("warn")
options(warn=-1)
TktNum <- sapply(TktSplit, function(x) {
                                        if(!is.na(as.integer(x[length(x)])))
                                            return(x[length(x)])
                                        else
                                            return(NA)
                                    })
options(warn=oldw)

TktNum <- as.integer(TktNum)
print(paste("No. of missing data in TktNum:", sum(is.na(TktNum))))

TktStr <- gsub("[ ]*[0-9]*$", "", as.character(train_data$Ticket))
TktStr[TktStr == ""] <- NA
TktStr <- as.factor(TktStr)

print("Summary of TktStr:")
summary(TktStr)

TktStr <- as.factor(toupper(gsub("[^A-Za-z0-9]", "", as.character(TktStr))))
summary(TktStr)

features$TktStr <- TktStr
features$TktNum <- TktNum
summary(features)

print(paste("Data type:", class(train_data$Fare)))
print("Summary:")
summary(train_data$Fare)

features$Fare <- train_data$Fare
summary(features)

print(paste("Data type:", class(train_data$Cabin)))
print(paste("No. of levels:", length(levels(train_data$Cabin))))
print(paste("% Data Missing:", sum(train_data$Cabin == "") / length(train_data$Cabin) * 100))
print(paste("% Data Missing (Survived):", sum(train_data$Cabin == "" & train_data$Survived == 1)
                                            / sum(train_data$Survived == 1) * 100))
print(paste("% Data Missing (Not Survived):", sum(train_data$Cabin == "" & train_data$Survived == 0)
                                            / sum(train_data$Survived == 0) * 100))
print("Data:")
as.character(train_data$Cabin)

CabinSplit <- strsplit(as.character(train_data$Cabin), " ")
CabinSplitFirst <- sapply(CabinSplit, function(x) return(x[1]))
CabinStr <- as.factor(gsub("[0-9]*$", "", CabinSplitFirst)    )
CabinNum <- as.integer(gsub("^[^0-9]*([0-9]*$)", "\\1", CabinSplitFirst))
print("Summary of CabinStr:")
summary(CabinStr)
print("Summary of CabinNum:")
summary(CabinNum)

features$CabinStr <- CabinStr
features$CabinNum <- CabinNum
summary(features)

print(paste("Data type:", class(train_data$Embarked)))
print(paste("No. of levels:", length(levels(train_data$Embarked))))
summary(train_data$Embarked)

Embarked <- as.character(train_data$Embarked)
Embarked[Embarked != 'C' & Embarked != 'Q' & Embarked != 'S'] <- NA
Embarked <- as.factor(Embarked)
print("Summary:")
summary(Embarked)

features$Embarked <- Embarked
summary(features)

train_processed <- features
survived <- train_data$Survived
survived[survived == 1] <- "Yes"
survived[survived == 0] <- "No"
train_processed$Survived <- as.factor(survived)
summary(train_processed)
train_processed

write.csv(train_processed, file="data/processed_train.csv")


#' scale
#'
#' Center/scale a float vector/matrix.
#'
#' @details
#' Only logical \code{center} and \code{scale} parameters are accepted at this
#' time.
#'
#' @param x
#' A float vector/matrix.
#' @param center,scale
#' Logical
#'
#' @return
#' A float matrix.
#'
#' @examples
#' library(float)
#'
#' s = flrunif(10, 3)
#' scale(s)
#'
#' @useDynLib float R_scale_spm
#' @name scale
#' @rdname scale
NULL

scale_float32 = function(x, center=TRUE, scale=TRUE)
{
  if (is.na(center) || is.na(scale))
    stop("missing value where TRUE/FALSE needed")

  if (!is.logical(center))
  {
    if (length(center) != ncol(x))
      stop("length of 'center' must equal the number of columns of 'x'")

    x = sweep(x, MARGIN=2, STATS=center, FUN="-")
    center = FALSE
  }
  if (!is.logical(scale))
  {
    if (length(scale) != ncol(x))
      stop("length of 'scale' must equal the number of columns of 'x'")

    x = sweep(x, MARGIN=2, STATS=scale, FUN="-")
    scale = FALSE
  }

  if (!isTRUE(center) && !isTRUE(scale))
    return(x)

  .Call(R_scale_spm, DATA(x), as.integer(center), as.integer(scale))
}

#' @rdname scale
#' @export
setMethod("scale", signature(x="float32"), scale_float32)


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#criado:     28.06.2017
#modificado: 28.06.2017

#1. FUNCTIONS
source("misc_v2.2.r")

#2. READ DATA
f1 = "../data/lmktattract.csv"
f2 = "../data/lmktmobil.csv"
x_all = read.table(file=f1,header=TRUE,sep=",",dec=".",row.names=1)
y_all = read.table(file=f2,header=TRUE,sep=",",dec=".",row.names=1)
dim(x_all)
dim(y_all)
#str(x_all)
#str(y_all)
#summary(x_all)
#summary(y_all)

# 3. ANALYSE DATA
main1 = "Labour market attractiveness"  #title for plots
col1 = c(rbind(hsv(h=seq(0,1,len=8),s=1/3,v=5/5)[1:7],  #very light
               hsv(h=seq(0,1,len=8),s=2/3,v=5/5)[1:7],  #light
               hsv(h=seq(0,1,len=8),s=3/3,v=5/5)[1:7],  #normal
               hsv(h=seq(0,1,len=8),s=3/3,v=4/5)[1:7])) #dark
names(col1) = rownames(x_all)           #colours for EU28

#normalize and scale data
w_all = c(1,rep(1/5,5),1,1,1,1,1,rep(1/6,6),rep(1/2,2),rep(1/3,3),rep(1/20,20),
  rep(1/2,2),1,1,1,1,rep(1/27,27),1)
x_norm = t(apply(scale(x_all),1,function(x){x*w_all}))

#calculate distances
#from help(dist): "Missing values are allowed, and are excluded from all
#  computations involving the rows within which they occur. If some columns are
#  excluded in calculating a [...] distance, the sum is scaled up proportionally
#  to the number of columns used."
x_dist = dist(x_norm,method="euclidean")

#perform Social Network Analysis
f1 = "../results/lmktattract_1/net"
plot_sna_v2(x_dist,col1=col1,edge_thr=0.65,f1=f1,main=main1)
analyse_net(x_dist,f1=f1)

#perform Partition Around Medoids analysis
f1 = "../results/lmktattract_1/pam"
plot_pam_v2(x_dist,col1=col1,f1=f1,main=main1)
kbest = 10
f1 = paste("../results/lmktattract_1/pam_grps",kbest,sep="")
plot_pam_v2(x_dist,kbest=kbest,col1=col1,f1=f1,main=main1)


#' Rescale the size of a node to make it relative to the aspectt ratio of the device
#' @param size Numeric vector. Size of the node (radious).
#' @param rel Numeric vector of length 3. Relative size for the minimum and maximum
#' of the plot, and curvature of the scale. The third number is used as `size^rel[3]`.
#'
#' @details
#' This function is to be called after [plot.new], as it takes the parameter `usr`
#' from the
#' @noRd
rescale_size <- function(size, rel=c(.01, .05, 1)) {

  # Checking the rel size
  if (length(rel) == 2)
    rel <- c(rel, 1)
  else if (length(rel) > 3) {
    warning("`rel` has more than 3 elements. Only the first 3 will be used.")
  } else if (length(rel) < 2) {
    stop("`rel` must be at least of length 2 and at most of length 3.")
  }

  # Creating curvature
  size <- size^rel[3]

  # Rescaling to be between range[1], range[2]
  sran <- range(size, na.rm=TRUE)

  if ((sran[2] - sran[1]) > 1e-5)
    size <- (size - sran[1])/(sran[2] - sran[1]) # 0-1
  else
    size <- size/sran[1]

  size * (rel[2] - rel[1]) + rel[1]

}

#' Adjust coordinates to fit aspectt ratio of the device
#' @param coords Two column numeric matrix. Vertices coordinates.
#' @details
#' It first adjusts `coords` to range between `-1,1`, and then, using
#' `graphics::par("pin")`, it rescales the second column of it (`y`) to adjust
#' for the device's aspect ratio.
#' @param adj Numeric vector of length 2.
#' @noRd
# @export
fit_coords_to_dev <- function(coords, adj = grDevices::dev.size()) {

  # Making it -1 to 1
  yran <- range(coords[,2], na.rm = TRUE)
  xran <- range(coords[,1], na.rm = TRUE)

  coords[,1] <- (coords[,1] - xran[1])/(xran[2] - xran[1])*2 - 1
  coords[,2] <- (coords[,2] - yran[1])/(yran[2] - yran[1])*2 - 1

  # Adjusting aspectt ratio according to the ploting area
  coords[,2] <- coords[,2]*adj[2]/adj[1]

  # Returning new coordinates
  coords

}

#' Rotation of polygon
#' @param mat Two-column numeric matrix. Coordinates of the polygon.
#' @param origin Numeric vector of length two. Origin.
#' @param alpha Numeric scalar. Rotation degree in radians.
#' @noRd
# @export
rotate <- function(mat, origin, alpha) {
  R <- matrix(
    c(cos(alpha), -sin(alpha), sin(alpha), cos(alpha)),
    nrow = 2, byrow = TRUE)

  origin <- matrix(c(origin[1], origin[2]), ncol=2, nrow = nrow(mat), byrow = TRUE)
  t(R %*% t(mat - origin)) + origin
}

#' Arc between two nodes
#'
#' @param p0,p1 Numeric vector of length 2. Center coordinates
#' @param alpha Numeric scalar. Arc angle in radians.
#' @param n Integer scalar. Number of segments to approximate the arc.
#' @param radii Numeric vector of length 2. Radious
#' @noRd
# @export
#'
arc <- function(
  p0,
  p1,
  alpha = pi/3,
  n     = 10L,
  radii = c(0, 0)
) {

  # If no curve, nothing to do (old fashioned straight line)
  if (alpha == 0 | n == 1) {
    alpha <- 1e-5
  }

  elevation <- atan2(p1[2]-p0[2], p1[1] - p0[1])

  # Constants
  d <- sqrt(sum((p0 - p1)^2))

  # If overlapping, then fix the radius to be the average
  if ((d - sum(radii)) < 0) {
    r <- mean(radii)
    alpha <- 2*pi - asin(d/2/r)*2
  } else {
    r <- d/2/(sin(alpha/2))
  }

  # Angles
  alpha0 <- asin(radii[1]/2/r)*2
  alpha1 <- asin(radii[2]/2/r)*2

  # Angle range
  alpha_i <- seq(
    pi/2 + (alpha/2 - alpha0) ,
    pi/2 - (alpha/2 - alpha1),
    length.out = n + 1
  )

  # Middle point
  M <- c(
    p0[1] + d/2,
    p0[2] - cos(alpha/2)*r
  )

  ans <- cbind(
    M[1] + cos(alpha_i)*r,
    M[2] + sin(alpha_i)*r
  )

  # Rotation and return
  ans <- rotate(ans, p0, elevation)

  # Separating the segments
  ans <- cbind(
    as.vector(t(cbind(ans[-(n + 1),1], ans[-1,1]))),
    as.vector(t(cbind(ans[-(n + 1),2], ans[-1,2])))
  )

  structure(
    ans,
    alpha0 = atan2(ans[1,2] - p0[2], ans[1,1] - p0[1]),
    alpha1 = atan2(p1[2] - ans[n*2,2], p1[1] - ans[n*2,1]),
    midpoint = ans[ceiling(n/2),]
  )

}

#' Arrow polygon.
#'
#' @param x Numeric vector of length 2. Coordinates of the tip
#' @param alpha,l,a,b Numeric scalars
#' @noRd
# @export
arrow_fancy <- function(x, alpha = 0, l=.25, a=pi/6, b = pi/1.5) {

  p_left  <- x + c(-cos(a), sin(a))*l

  base <- l*sin(a)
  base2 <- base * cos(pi - b)/sin(pi - b)
  p_mid   <- p_left + c(base2, -base)

  p_right <- x - c(cos(a), sin(a))*l

  ans <- rbind(x, p_left, p_mid, p_right)

  # Rotation

  rotate(ans, x, alpha = alpha)

}


REBOL [
    Title: "Triangulator"
    Date: 29-Dec-2013/16:35:22+1:00
    Author: "Oldes"
	require: [
		rs-project %stream-io
	]
]

ctx-triangulator: context [
	out: make stream-io [] ;Holds output stream
	;#CURVE RELATED FUNCTIONS
	;used to convert Bazier curve to lines
	_terms: none
	_subSteps: 0
	_bezierError: 0.75
	_minLineWidth: 20 ;in TWIPS!! so 40 = 2px

	_curveOutput: copy []

	vertice-struct: make struct! [
		x [float]
		y [float]
		r [float]
		g [float]
		b [float]
		a [float]
	] none

	quadraticCurve: func[
		a1x   [number!]
		a1y   [number!]
		cx    [number!]
		cy    [number!]
		a2x   [number!]
		a2y   [number!]
		;error [decimal!]
	][
		_subSteps: 0
		;_bezierError: error
		_terms: reduce [a1x a1y cx cy a2x a2y]

		clear _curveOutput

		subdivide 0.0 0.5 0 :quadratic _curveOutput
		subdivide 0.5 1.0 0 :quadratic _curveOutput

		;print _subSteps
		head _curveOutput
	]
	quadratic: func[t axis][
		oneMinusT: 1.0 - t
		a1: _terms/(1 + axis)
		c:  _terms/(3 + axis)
		a2: _terms/(5 + axis)
		(oneMinusT * oneMinusT * a1) + (2.0 * oneMinusT * t * c) + (t * t * a2)
	]
	subdivide: func[
		t0 t1 depth equation _curveOutput
		/local quadX quadY x0 y0 x1 y1 midX midY dx dy error2
	][
		quadX: equation (t0 + t1) * 0.5 0
		quadY: equation (t0 + t1) * 0.5 1

		x0: equation t0 0
		y0: equation t0 1
		x1: equation t1 0
		y1: equation t1 1

		midX: ( x0 + x1 ) * 0.5;
		midY: ( y0 + y1 ) * 0.5;

		dx:  quadX - midX;
		dy:  quadY - midY;

		error2: (dx * dx) + (dy * dy)

		either error2 > (_bezierError * _bezierError) [
			subdivide  t0 (t0 + t1) * 0.5 depth + 1 :equation _curveOutput
			subdivide (t0 + t1) * 0.5 t1  depth + 1 :equation _curveOutput
		][
			_subSteps: _subSteps + 1
			repend _curveOutput [x1 y1]
		]
	]
	;END OF CURVE RELATED FUNCTIONS

	penPosX: penPosY: 0

	strokeDefinition: copy []
	vertexBuffers:    copy []
	indexBuffers:     copy []
	vertices:         make binary! 70000 ;-- array of vertices in binary format
	indices:          copy [] ;-- array of indexes pointing to vertices
	newIndices:       copy [] ;-- this is used as a temp holder, when buffer is full
	vertToIndHash:    make hash! 65535
	numVertices: 0
	ind0: ind1: ind2: ind3: 0
	idx: 0

	lineWidth: 1
	lineColor: 255.255.255.255

	stroke-to-polyline: func[
		/local
		v0x v0y v1x v1y v2x v2y
		d0 d1 d0x d0y d1x d1y
		n0x n0y n1x n1y cnx cny c
		c1xPos c1yPos c1xNeg c1yNeg
		elbowThickness dot
		clrR clrG clrB clrA
		pos isFirst? isLast?

	][
		strokeDefinition: head strokeDefinition
		;prin "stroke-to-polyline" probe strokeDefinition
		v0x: v0y:  none
		parse strokeDefinition [
			any [
				'width set lineWidth number!
				|
				'color set lineColor tuple! (
					clrR: lineColor/1 / 255
					clrG: lineColor/2 / 255
					clrB: lineColor/3 / 255
					clrA: lineColor/4 / 255
				)
				|
				set v1x number!
				set v1y number!
				pos: (
					if isFirst?: none? v0x [
						v0x: v1x
						v0y: v1y
					]
					if isLast?: not parse pos [
						opt ['width number!]
						opt ['color tuple!]
						set v2x number!
						set v2y number!
						to end
					][
						v2x: v1x
						v2y: v1y
					]

					d0x: v1x - v0x
					d0y: v1y - v0y
					d1x: v2x - v1x
					d1y: v2y - v1y

					if isLast? [
						v2x: v2x + d0x
						v2y: v2y + d0y
						d1x: v2x - v1x
						d1y: v2y - v1y
					]
					if isFirst? [
						v0x: v0x - d1x
						v0y: v0y - d1y
						d0x: v1x - v0x
						d0y: v1y - v0y
					]
					d0: square-root (d0x * d0x) + (d0y * d0y)
					d1: square-root (d1x * d1x) + (d1y * d1y)

					elbowThickness: lineWidth * 0.5

					unless any [isFirst? isLast?][
						;// Thanks to Tom Clapham for spotting this relationship.
						dot: ((d0x * d1x) + (d0y * d1y)) / (d0 * d1)
						either error? try [
							elbowThickness: elbowThickness / sine/radians ((PI - arccosine/radians dot) * 0.5)
						][
							elbowThickness: lineWidth * 0.5
						][
							if elbowThickness > (lineWidth * 4) [
								elbowThickness: lineWidth * 4
							]
						]
					]

					n0y:  d0x / d0
					n1x: - d1y / d1
					n0x: - d0y / d0
					n1y:  d1x / d1

					cnx: n0x + n1x
					cny: n0y + n1y
					error? try [
						c:   (1 / square-root( (cnx * cnx) + (cny * cny) )) * elbowThickness
						cnx: cnx * c
						cny: cny * c
					]

					v1xPos: v1x + cnx
					v1yPos: v1y + cny
					v1xNeg: v1x - cnx
					v1yNeg: v1y - cny

					vertice-struct/x: v1xPos
					vertice-struct/y: v1yPos
					vertice-struct/r: clrR
					vertice-struct/g: clrG
					vertice-struct/b: clrB
					vertice-struct/a: clrA

					vertBin: third vertice-struct
					unless ind2: select vertToIndHash vertBin [
						ind2: numVertices
						insert vertToIndHash reduce [copy vertBin ind2]
						insert tail vertices vertBin
						numVertices: numVertices + 1
					]

					vertice-struct/x: v1xNeg
					vertice-struct/y: v1yNeg
					vertice-struct/r: clrR
					vertice-struct/g: clrG
					vertice-struct/b: clrB
					vertice-struct/a: clrA

					vertBin: third vertice-struct
					unless ind3: select vertToIndHash vertBin [
						ind3: numVertices
						insert vertToIndHash reduce [copy vertBin ind3]
						insert tail vertices vertBin
						numVertices: numVertices + 1
					]
					unless isFirst? [
						repend indices [ind0 ind2 ind1 ind1 ind2 ind3]
					]
					ind0: ind2
					ind1: ind3

					;store current point for future use
					v0x: v1x
					v0y: v1y
				)
			]
		]
		strokeDefinition: clear head strokeDefinition
	]

	set 'triangulate-shape func[
		data
		/local
			lineWidth lineColor lineData curveData err
			penPosX penPosY
			startIdx newHash vertBin
	][
		;print ["triangulate-shape" mold copy/part data 10 "..."]
		startIdx: length? indices
		startVert: numVertices

		parse/all data [
			any [
				'lineStyle
					set lineWidth integer! (
						if lineWidth < _minLineWidth [lineWidth: _minLineWidth]
						strokeDefinition: insert strokeDefinition reduce ['width lineWidth: lineWidth * 0.05]
					)
					opt [set lineColor tuple! (
						strokeDefinition: insert strokeDefinition reduce ['color lineColor]
					)]
				|
				'moveTo (stroke-to-polyline) set penPosX number! set penPosY number! (
					penPosX: penPosX * 0.05
					penPosY: penPosY * 0.05
					strokeDefinition: insert strokeDefinition reduce ['width lineWidth 'color lineColor penPosX penPosY]
				)
				|
				'line set lineData block! (
					if none? penPosX [
						penPosX: 0
						penPosY: 0
						strokeDefinition: insert strokeDefinition reduce ['width lineWidth 'color lineColor penPosX penPosY]
					]
					foreach [dx dy] lineData [
						strokeDefinition: insert strokeDefinition reduce [
							penPosX: penPosX + (dx * 0.05)
							penPosY: penPosY + (dy * 0.05)
						]
					]
				)
				|
				'curve set curveData block! (
					if none? penPosX [
						penPosX: 0
						penPosY: 0
						strokeDefinition: insert strokeDefinition reduce ['width lineWidth 'color lineColor penPosX penPosY]
					]
					foreach [cx cy dx dy] curveData [
						strokeDefinition: insert strokeDefinition quadraticCurve
							penPosX penPosY
							penPosX: penPosX + (cx * 0.05)
							penPosY: penPosY + (cy * 0.05)
							penPosX: penPosX + (dx * 0.05)
							penPosY: penPosY + (dy * 0.05)

					]
				)
				| copy err 1 skip (
					ask reform ["Invalid shape definition:" mold err]
				)
			]
			(stroke-to-polyline)
		]
		;print ["vertices: " numVertices]
		;probe new-line/skip to block! vertToIndHash true 2
		if numVertices > 65535 [;65535
			print ["BufferFull" length? vertices "startIdx: " startIdx " triangles: " ((length? indices) - startIdx) / 3 ]

			append/only indexBuffers  copy/part indices startIdx
			append/only vertexBuffers copy/part vertices (startVert * 24)

			indices: skip indices startIdx
			clear vertices

			newHash: make hash! 20000
			numVertices: startIdx: startVert: 0
			;probe new-line/skip to block! vertToIndHash true 2
			foreach ind indices [
				vertBin: first back find vertToIndHash ind
				unless ind: select newHash vertBin [
					ind: numVertices
					insert newHash reduce [copy vertBin ind]
					insert tail vertices vertBin
					numVertices: numVertices + 1
				]
				insert tail newIndices ind
			]

			indices: clear head indices
			insert indices newIndices
			clear newIndices
			insert clear vertToIndHash newHash
		]

		reduce [
			length? vertexBuffers                  ;-- indexBuffer
			startIdx                               ;-- firstIndex
			((length? indices) - startIdx) / 3     ;-- numTriangles
		]
	]

	init: does [
		out/clearBuffers
		forall vertexBuffers [clear vertexBuffers/1]
		forall indexBuffers  [clear indexBuffers/1]
		strokeDefinition: clear head strokeDefinition
		vertexBuffers: clear head vertexBuffers
		indexBuffers:  clear head indexBuffers
		vertices: clear head vertices
		indices:  clear head indices
		newIndices: clear head newIndices
		numVertices: 0
		clear vertToIndHash
		ind0: ind1: ind2: ind3: 0
		idx: 0
	]

	vertices:         make binary! 70000 ;-- array of vertices in binary format
	indices:          copy [] ;-- array of indexes pointing to vertices
	newIndices:       copy [] ;-- this is used as a temp holder, when buffer is full
	vertToIndHash:    make hash! 65535
	numVertices: 0
	ind0: ind1: ind2: ind3: 0
	idx: 0

	get-buffers-binary: func[][
		out/clearBuffers

		append/only indexBuffers  copy indices
		append/only vertexBuffers copy vertices
		;probe vertexBuffers
		;probe indexBuffers

		either empty? vertexBuffers/1 [
			out/writeUI8 0
		][
			out/writeUI8 length? vertexBuffers
			;print ["NUM BUFFERS:" length? vertexBuffers]
			foreach vertices vertexBuffers [
				out/writeUI32 (length? vertices) / 24
				print ["VERTEX BUFFER BYTES: " length? vertices]
				out/writeBytes vertices
				clear head vertices
			]
			;shapes indexBuffer:
			foreach indices indexBuffers [
				out/writeUI32 length? indices
				print ["INDEXE BUFFERs: " length? indices]
				forall indices [out/writeUI16 indices/1]
				clear head indices
			]
		]
		clear vertexBuffers
		clear indexBuffers
		;probe copy/part head out/outBuffer 4
		head out/outBuffer
	]
{
	triangulate-shape [
		lineStyle 20 255.0.0.255
		moveTo 200 0
		line [2000 0]
	]

	triangulate-shape [
		;lineStyle 20 0.0.255.255
		moveTo 200 0
		line [0 2000 2000 2000]
	]

;	append/only indexBuffers  copy indices
;		append/only vertexBuffers copy vertices

	probe get-buffers-binary

	probe idx
	;probe vertices
	out: copy ""
	foreach [x y r g b a] vertices [
		append out ajoin [x ", " y ",  " r ", " g ", " b ", " a ", " lf]
	]
	append out "^/^/"
	n: 0
	foreach [i1 i2 i3] indices [
		if n = 2 [n: 0 append out "^/"]
		append out ajoin [i1 "," i2 "," i3 ", "]
		n: n + 1
	]
	print out
}
]


hmac.kmeans=function(data,centers=400,sigma=NULL,parallel=FALSE)
{
kmeans.out=kmeans(data,centers=centers)
center=kmeans.out$centers
cluster.kmeans=kmeans.out$cluster
hmac.out=phmac(dat=center,sigmaselect=sigma,npart=1,parallel=parallel)

#order=sort(cluster.kmeans)
#data.ordered=data[,]

ind=seq(1,dim(data)[1])
myorder=ind[order(kmeans.out$cluster)]
#data.ordered=data[myorder,]

memb.new.rightorder=memb.new=list(1:max(hmac.out$level))

for (i in 1 : max(hmac.out$level)){
       temp=seq(1,dim(data)[1])
	memb.new[[i]]=rep(hmac.out$membership[[i]], kmeans.out$size)
	temp[myorder]=memb.new[[i]]
        #cat(temp)
	memb.new.rightorder[[i]]=temp
}
	output=list()
	output[["data"]]=data
	output[["mode"]]=hmac.out$mode
	output[["sigma"]]=hmac.out$sigmas
    	output[["n.cluster"]]=hmac.out$n.cluster
    	output[["level"]]=hmac.out$level
    	output[["membership"]]=memb.new.rightorder
	class(output)="hmac"
	return(output)

}


# run pipeline on mlgf_on_OneKP_prot_cdhit99
pfamA_sample<-read.table("results/mlgf_on_OneKP_prot_cdhit99/sample_count_table.tsv", sep="\t")
pfamA_clade<-read.table("results/mlgf_on_OneKP_prot_cdhit99/clade_mean_sizes.tsv", sep="\t")
# run pipeline on Pfam-A_noStrepto_on_OneKP_prot_cdhit99
pfamA_noStrepto_sample<-read.table("results/Pfam-A_noStrepto_on_OneKP_prot_cdhit99/sample_count_table.tsv", sep="\t")
pfamA_noStrepto_clade<-read.table("results/Pfam-A_noStrepto_on_OneKP_prot_cdhit99/clade_mean_sizes.tsv", sep="\t")

include<-c("F-box", "AP2_EREBP", "bHLH", "bZIP", "C2H2", "C3H", "WRKY", "ABC", "PP2C", "Receptor-like Kinases", "P450s", "NAC")#, "GRAS")

pfamA_sample<-pfamA_sample[include,]
pfamA_clade<-pfamA_clade[,gsub("[ -]", '.', include)]
pfamA_noStrepto_sample<-pfamA_noStrepto_sample[include,]
pfamA_noStrepto_clade<-pfamA_noStrepto_clade[,gsub("[ -]", '.', include)]

# Korrelationen
x <- as.numeric(as.matrix(pfamA_sample))
y <- as.numeric(as.matrix(pfamA_noStrepto_sample))
cor(x, y, method="pearson")
# 0.9809391
cor(x, y, method="spearman")
# 0.8633884
pdf("plots/figure_4 PfamA vs PfamA noStrepto samples.pdf", width=89/25.4, height=89/25.4)
	par(cex=0.5, mar=c(4, 4, 2, 2) + 0.1, bty="l", las=1)

	smoothScatter(as.vector(as.matrix(pfamA_sample)), as.vector(as.matrix(pfamA_noStrepto_sample)), xlab="PfamA", ylab="PfamA w/o Streptophytes")#, log="xy")#, main="per sample gene family sizes")
	lines(c(1,5e+3),c(1,5e+3), col="grey")
	text(250, 1500, labels=paste0("Pearson = ", round(cor(x, y, method="pearson"), digits=2), "\nSpearman = ", round(cor(x, y, method="spearman"), digits=2)))
dev.off()

x <- as.numeric(as.matrix(pfamA_clade))
y <- as.numeric(as.matrix(pfamA_noStrepto_clade))
cor(x, y, method="pearson")
# 0.9800696
cor(x, y, method="spearman")
# 0.8864
pdf("plots/figure_4 PfamA vs PfamA noStrepto clades.pdf", width=89/25.4, height=89/25.4)
	par(cex=0.5, mar=c(4, 4, 2, 2) + 0.1, bty="l", las=1)
	plot(c(1, max(pfamA_clade, pfamA_noStrepto_clade)),c(1, max(pfamA_clade, pfamA_noStrepto_clade)), col="grey", t="l", xlab="PfamA", ylab="PfamA w/o Streptophytes", main="Average Gene Family Sizes per Clade (for 15 gene families)")
	points(as.vector(as.matrix(pfamA_clade)), as.vector(as.matrix(pfamA_noStrepto_clade)), pch=20)
	lines(c(1,5e+3),c(1,5e+3), col="grey")
	text(80, 650, labels=paste0("Pearson = ", round(cor(x, y, method="pearson"), digits=2), "\nSpearman = ", round(cor(x, y, method="spearman"), digits=2)))
dev.off()


# This is a simple script to calculate the fdr for p values produced from another stat tool
# The output is the input appended with an fdr column
# Rows are sorted by the fdr

mg_calculate_fdr <- function (
                              table_in,                # input data table -- by default, assume that p values are in the last column
                              table_out = "default",   # "default" or an name that the user wants to use for the output
                              p_value_column = "last"  # "last" or 1 based index of selected column
                           )

  {

  ###################################################################################################################################
  # generate filename for the outout
  if ( identical(table_out, "default") ){
    table_out = paste(table_in, ".with_fdr.txt", sep="", collapse="")
  }
  ###################################################################################################################################

  data_matrix <- as.matrix(read.table(file=table_in, row.names=1, header=TRUE, sep="\t", colClasses = "character", check.names=FALSE, comment.char = ""))

  n_cols <- ncol(data_matrix)

  if ( identical( p_value_column,"last" )  ){
    fdr_values <- as.matrix(p.adjust( data_matrix[,n_cols], method="fdr"))
  }else{
    if ( p_value_column > n_cols ){
      stop(  paste("Selected column (", p_value_column, ") is greater than the number of columns (",n_cols, ")", sep="" )  )
    }else{
      fdr_values <- as.matrix(p.adjust( data_matrix[,p_value_column], method="fdr"))
    }
  }

  # add column header to calculated fdr's
  colnames(fdr_values) = "fdr"

  # create matrix with original data and the fdr
  output_matrix <- cbind( data_matrix, fdr_values)

  # sort the output by the fdr
  #output_matrix.ordered <- output_matrix[ order(output_matrix[,ncol(output_matrix)], decreasing=FALSE), ]

  # write the output
  #write.table(output_matrix.ordered, file = table_out, col.names=NA, row.names = rownames(output_matrix.ordered), sep="\t", quote=FALSE)
  write.table(output_matrix, file = table_out, col.names=NA, row.names = rownames(output_matrix), sep="\t", quote=FALSE)

  }