# packages needed
rm(list = ls())
source("project_paths.r")

library(dplyr)
library(tidyverse)
library(plm)
library(lmtest)
library(broom)
# library(flextable)
# library(officer)
#install.packages("stargazer",repos = "http://cran.us.r-project.org")
#install.packages("corrplot",repos = "http://cran.us.r-project.org")
#install.packages("plotmo",repos = "http://cran.us.r-project.org")
library(knitr)
library(stargazer)
library(MASS)
library(readr)
library(tidyr)

tribble(
  ~Event, ~Description,
  "jomcsb","The company I work for will still be in business 5 years from now",
  "jomcd", "My job is complex and difficult",
  "jomfw", "Freedom to decide when to work",
  "jomls", "I have a lot of say about what happens on my job",
  "jomfd", "I have a lot of freedom to decide how I do my own work",
  "jomns", "My job often requires me to learn new skills",
  "jompf", "I get paid fairly for the things I do in my job",
  "jomsf", "I have a secure future in my job",
  "jomus", "I use many of my skills and abilities in my current job",
  "jomms", "My job is more stressful than I had ever imagined",
  "jomwf", "I worry about the future of my job",
  "jomvar", "I worry about the future of my job",
  "jomtime", "I dont have enough time to do everything in my job",
  "jomrpt", "My job requires me to do the same things over and over again",
  "jomflx", "My working times can be flexible",
  "jomdw", "I have a lot of choice in deciding what I do at work",
) %>%
  kable()

tribble(
  ~Event, ~Description,
  "jbmsall","Overall job satisfaction",
  "jbmsflx", "The flexibility to balance work and non-work satisfaction",
  "jbmshrs", "The hours you work satisfaction (plot)",
  "jbmspay", "Total pay satisfaction (plot)+estimate",
  "jbmssec", "Job security satisfaction",
  "jbmswrk", "The work itself satisfaction",
  "jbmtuea", "IDV: Union membership or employee association (dont know=no) ",
) %>%
  kable()

getwd()

#loading in the relevant data

outcomes <- read_rds(paste(PATH_OUT_DATA, "job_sat.rds", sep="/"))

independent_vars_subjective <- read_rds(paste(PATH_OUT_DATA, "subj_vars_job_sat.rds", sep="/"))

#preprocessing the necessary data for the upcoming regressions.
outcomes %>%
  filter(code == 'jbmsall') %>%
  mutate(
    Y = case_when(
      val < 0 ~ NA_integer_,
      TRUE ~ as.integer(val)
    )
  ) %>%
  dplyr::select(-code,-val) -> job_sat.df

independent_vars_subjective %>%
  mutate(
    val = case_when(
      val < 0 ~ NA_integer_,
      TRUE ~ as.integer(val)
    )
  )-> independent_vars

data_wide <- spread(independent_vars,code,val)

#forming the data frame by joining the outcome and independent variables
job_sat.df %>%
  left_join(data_wide, by = c("xwaveid", "wave")) -> full.df

full.df %>%
  ungroup() %>%
  dplyr::select(-Y, -xwaveid) %>%
  dplyr::select(-wave,everything()) %>%
  colnames() -> var.names

var.names <-var.names[var.names!='wave']

#running the fixed effect panel regression for all the variables,the positive events and the negative events.

full.formula <- as.formula(paste('Y ~', paste(var.names, collapse = ' + ')))
fe <- plm(full.formula, full.df, index = c('wave'), method = 'within')
fe_trunc_pos <- plm(Y~ jomcsb+jomfw+jomfd+jomns+jompf+jomdw+jomvar, full.df, index = c('wave'), method = 'within')
fe_trunc_negative <- plm(Y~ jomcd+jomms+jomwf+jomrpt, full.df, index = c('wave'), method = 'within')
#Figure 1:
star_fe <-stargazer(fe_trunc_pos,fe_trunc_negative,type="latex",title= "Panel Fixed Effect Regression Results",
                    covariate.labels = c("Company stability","Freedom when to work","Freedom how to work","Learn new Skills",
                                         "Fair wage","Freedom what to do","Interesting work","Work complex and difficult","Job stress","Worry job stability",
                                          "Repetitive"
                                           ),out=paste(PATH_OUT_FIGURES, "figure1_pos_neg_linear_reg_job.tex", sep="/"))

#shows the relationship between positive and negative variables on job satisfaction

#now let us use ordered logit to rerun the regression using all the variables

full.formula <-as.formula(paste('factor(Y) ~', paste(paste(var.names,collapse = ' + '),'+factor(wave)')))
m <- polr(full.formula, data = full.df, Hess=TRUE)

m_pos<-polr(factor(Y)~ jomcsb+jomfw+jomfd+jomns+jompf+jomdw+jomvar+factor(wave), data = full.df, Hess=TRUE)

m_neg<-polr(factor(Y)~ jomcd+jomms+jomwf+jomrpt+factor(wave), data = full.df, Hess=TRUE)

summary(m)
ctable <- coef(summary(m))
p <- pnorm(abs(ctable[, "t value"]), lower.tail = FALSE) * 2

## combined table
(ctable <- cbind(ctable, "p value" = p))
exp(coef(m))
stargazer(m)
print(full.formula)

#Figure 2:

star_fe <-stargazer(fe_trunc_pos,fe_trunc_negative,m_pos,m_neg,keep=var.names,type="latex",
                    title= "Panel Fixed Effect Regression Results (Feature Selected)",
                    no.space = TRUE,
                    column.sep.width = "3pt",
                    covariate.labels = c("Company stability","Freedom when to work",
                                         "Freedom how to work","Learn new Skills",
                                         "Fair wage","Freedom what to do","Interesting work",
                                         "Work complex and difficult","Job stress",
                                         "Worry job stability",
                                         "Repetitive"),
                    dep.var.labels   = c("Job Satisfaction","Job Satisfaction"),out=paste(PATH_OUT_FIGURES, "figure2_pos_neg_linear_reg_ordered_logit_job.tex", sep="/"))

# however there is high correlation and it is best to first filter out the variables to a manageable number using some kind
# of penalized regression or elastic net methods.

###

##correlation plot
#install.packages("corrplot")
library(corrplot)
#install.packages("ggplot2")
library(ggplot2)

full.df %>%
  filter(wave=='e')%>%
  subset(select = -c(wave,xwaveid)) -> wave_e
summary(wave_e)

cc = cor(wave_e, method = "spearman",use="pairwise.complete.obs")
#drawing the correlation plots

jpeg(file = paste(PATH_OUT_FIGURES, "figure_3_job_variables_corr_plot.png", sep="/"),width = 465, height = 225, units='mm', res = 300)
#Figure 3:
corrplot(cc,method = "shade")
while (!is.null(dev.list()))  dev.off()

##feature selection
#install.packages("glmnet")
#install.packages("plotmo")
library(glmnet)
library(plotmo)

df_temp_dataframe <-as.data.frame(wave_e)
df_temp_dataframe <-na.omit(df_temp_dataframe)

library(caret)

# Model Building : Elastic Net Regression
train_control <- trainControl(method = "repeatedcv",
                              number = 5,
                              repeats = 5,
                              search = "random",
                              verboseIter = TRUE)

invisible(elastic_model_all <- train(Y~ .,
                           data = df_temp_dataframe,
                           method = "glmnet",
                           preProcess = c("center", "scale"),
                           tuneLength = 25,
                           trControl = train_control))

elastic_model_all$bestTune
#alpha and lambda that is best performing for entire data set

cat("Within entire data set,the number of variables have been shrunk to 11")
CF_all <- as.matrix(coef(elastic_model_all$finalModel, elastic_model_all$bestTune$lambda))
as.data.frame(CF_all[CF_all!=0,])

##rerunning the regressions with filtered variables

fe_filt <- plm(Y~jomflex+jomls+jomms+jompf+jomsf+jomus+jomvar, full.df, index = c('wave'), method = 'within')
m_filt <- polr(factor(Y)~jomflex+jomls+jomms+jompf+jomsf+jomus+jomvar+factor(wave), data = full.df, Hess=TRUE)
#figure 5

star_fe_5 <-stargazer(fe_filt,m_filt,keep=var.names,type="latex",
                    title= "Panel Fixed Effect Regression Results",
                    column.sep.width = "3pt",
                    covariate.labels = c("Flexible Work Times","Freedom to make Decisions",
                                         "Job Stress","Fair Wage",
                                         "Worry job stability","Personal Skills utilized","Interesting work"
                                          ),
                    dep.var.labels   = c("Job Satisfaction","Job Satisfaction"),out=paste(PATH_OUT_FIGURES, "figure5_pos_neg_linear_reg_ordered_logit_filtered_job.tex", sep="/"))


# load libraries
library(snpReady)
library(vcfR)
library(ggplot2)

# list all files
files = list.files()
files = files[grep('vcf', files)]

# function that takes a string of the form 'm|n'
# and returns the numeric m+n
cast_as_numeric = function(str){
  return(sum(as.numeric(strsplit(str, '|')[[1]][c(1,3)])))
}

# function that takes a matrix of values of the form 'm|n'
# and returns a new matrix of their sums
convert_to_counts = function(str_mat){
  return(matrix(unlist(lapply(str_mat, cast_as_numeric)), ncol = ncol(str_mat)))
}

# function that takes a VCF filename and calculates the Ne for that file
calc_Ne = function(filename){
  # read file
  vcf = read.vcfR(filename)
  # get the genotype matrix
  mat = as.matrix(vcf@gt)
  # transform (so that individs are on rows, markers on cols
  mat = t(mat)
  # drop the first row (which indicates the formatting, e.g. 'GT')
  mat = mat[2:nrow(mat), ]
  # convert to a numeric matrix of allele counts
  cts = convert_to_counts(mat)
  colnames(cts) = seq(ncol(cts))
  # calculate and extract the Ne
  res = popgen(cts, subgroups=rep(1, nrow(cts)))
  Ne = res$whole$Variability[1,1]
  return(Ne)
}

print(files)

ts = c()
Nes = c()
for (filename in files){
  t = as.numeric(strsplit(strsplit(filename, '_t-')[[1]][2], "_spp")[[1]][1])
  Ne = calc_Ne(filename)
  ts = c(ts, t)
  Nes = c(Nes, Ne)
}

print('ts')
print(ts)
print('Nes')
print(Nes)

df = data.frame(t=ts, Ne=Nes)
print(df)

Ne_plot = ggplot(data=df) +
  geom_line(aes(x=t, y=Ne))

ggsave(Ne_plot, file='Ne_plot.pdf',
       width=30, height=20, units='cm', dpi=1200)


# -*- coding: utf-8 -*-

#' Created on Fri Apr 13 15:38:28 2018
#' R version 3.4.3 (2017-11-30)
#'
#' @group   Group 2, DM2 2018 Semester 2
#' @author: Martins T.
#' @author: Mendes R.
#' @author: Santos R.
#'

# Libs --------------------------------------------------------------------
options(warn=-1)
source("src/packages.r")
include_packs(c("dygraphs","d3heatmap","rockchalk","forcats","rJava",
                "xlsxjars","xlsx","tidyverse","stringi","stringr","ggcorrplot",
                "sm","lubridate","magrittr","ggplot2","openxlsx","RColorBrewer",
                "psych","treemap","data.table","pROC","class",'gmodels','klaR',
                "C50","caret",'gmodels',"DMwR","recipes","epiR","pubh","leaps",
                "MASS","gbm","autoimage","randomForest","settings","factoextra"
                ,"dummies","ROCR","neuralnet","sparseLDA","adabag","RWeka",
                "Metrics"))

# Load data ---------------------------------------------------------------
#Load normalized data xlsx
source("src/wrangling.r")
normalizedDataset <- xlsx::read.xlsx('datasets/normalizedDataset.xlsx',1, header= TRUE)

#backup set
temp<-normalizedDataset

# Logistic CV 10 Predictors ----------------------------------------------

###' Debug
normalizedDataset <- temp

include <- c("DistanceHomeOffice","isAfterHours",
             "isSingle","Age","avgSatisfaction",
             "TenureWorking","NumCompaniesWorked",
             "LastPromotion","MonthlyIncome","isDepartIT",
             "isChurn")

normalizedDataset <- normalizedDataset[ , (names(normalizedDataset) %in% include)]

correlation <- round(cor(normalizedDataset, method = "kendall"), 1)
png(filename="presentations/correlation10Log.png",width=1000, height=565)
corr_plot(correlation)
dev.off()

corr_plot(correlation)

# Data Partition
set.seed(375); trainingRowIndex <- sample(1:nrow(normalizedDataset),
                                          0.69*nrow(normalizedDataset))
#1000 records
trainData <- normalizedDataset[trainingRowIndex, ]
#remaining 450 records
testData <- normalizedDataset[-trainingRowIndex, ]

#checking propotion of target var
normalizedDataset$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
trainData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
testData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)

png(filename="presentations/stratification10Log.png",width=300, height=250)
stratification(normalizedDataset,trainData,testData,"- Log 10 predictors")
dev.off()

stratification(normalizedDataset,trainData,testData,"- Log 10 predictors")

# target to yes/no
trainData$isChurn <- ifelse(trainData$isChurn==1,"Yes","No")
testData$isChurn <- ifelse(testData$isChurn==1,"Yes","No")

# #Save test_labels
test_labels <- as.factor(testData$isChurn)

#drop target from testData, not mandatory
drops <- c("isChurn")
testData <- testData[ , !(names(testData) %in% drops)]

#Setting up CV
ControlParamteres <- trainControl(method="cv",
                                  number=10,
                                  #repeats=10,
                                  #sampling = "up",
                                  #verboseIter = FALSE,
                                  summaryFunction=twoClassSummary,
                                  savePredictions = TRUE,
                                  classProbs = TRUE)

#with no tuning parameters.

#regLogistic
glm10 <- caret::train(isChurn~.,
                    data=trainData,
                    method = "glm",
                    #preProc=c("center", "scale"),
                    metric="ROC",
                    trControl = ControlParamteres)

glm10
summary(glm10)

testData$prob <- predict(glm10, testData ,type = "prob")[2]
ROCR_test <- ROCR::prediction(testData$prob, test_labels)
testData$isChurn <- test_labels

#Cutoff plot
reset.par()
plotCut(ROCR_test,"LOG 10")
abline(v = 0.429, col="seagreen3", lwd=2, lty=8)

png(filename="presentations/cut10LogCV.png",width=760, height=565)
plotCut(ROCR_test,"LOG 10")
abline(v = 0.429, col="seagreen3", lwd=2, lty=8)
dev.off()

testData$pred <- ifelse(testData$prob$Yes > 0.429, "Yes", "No")
testData$pred<-as.factor(testData$pred)

g <- roc(isChurn ~ prob$Yes, data =testData )
reset.par()

#ROC plot
plot(g, col = 4, lty = 1,
     main = "ROC 10 Predictors", asp = NA,
     xlab = "Specificity (%)",
     ylab = "Sensitivity (%)",
     print.auc=TRUE, type  = 'l', ps=1000,las=1)
legend(.40,.8,
       legend=c("Log CV"),
       col=c("4"),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
p<-recordPlot()

png(filename="presentations/roc10LogCV.png",width=760, height=565)
replayPlot(p)
dev.off()

#confusionMatrix(pred, obs, positive = NULL,...), not the inverse
cm <- caret::confusionMatrix(testData$pred, testData$isChurn, positive = 'Yes',
                             dnn=c("Pred","Actual"))

png(filename="presentations/cm10LogCV.png",width=760, height=565)
draw_confusion_matrix_cv(cm,"- Log 10 predictors")
dev.off()
source("src/wrangling.r")
draw_confusion_matrix_cv(cm,"- Log 10 predictors")

save(glm10, file = "models/glm10.rda")

# SVM CV 10 Predictors ----------------------------------------------

###' Debug
normalizedDataset <- temp

include <- c("DistanceHomeOffice","isAfterHours",
             "isSingle","Age","avgSatisfaction",
             "TenureWorking","NumCompaniesWorked",
             "LastPromotion","MonthlyIncome","isDepartIT",
             "isChurn")

normalizedDataset <- normalizedDataset[ , (names(normalizedDataset) %in% include)]

correlation <- round(cor(normalizedDataset, method = "kendall"), 1)
png(filename="presentations/correlation10SVM.png",width=760, height=565)
corr_plot(correlation)
dev.off()

corr_plot(correlation)
# Data Partition
set.seed(375); trainingRowIndex <- sample(1:nrow(normalizedDataset),
                                          0.69*nrow(normalizedDataset))
#1000 records
trainData <- normalizedDataset[trainingRowIndex, ]
#remaining 450 records
testData <- normalizedDataset[-trainingRowIndex, ]

#checking propotion of target var
normalizedDataset$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
trainData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
testData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)

png(filename="presentations/stratification10SVM.png",width=300, height=250)
stratification(normalizedDataset,trainData,testData,"- SVM 10 predictors")
dev.off()

stratification(normalizedDataset,trainData,testData,"- SVM 10 predictors")

# target to Yes/no
trainData$isChurn <- ifelse(trainData$isChurn==1,"Yes","No")
testData$isChurn <- ifelse(testData$isChurn==1,"Yes","No")

# #Save test_labels
test_labels <- as.factor(testData$isChurn)

#drop target from testData, not mandatory
drops <- c("isChurn")
testData <- testData[ , !(names(testData) %in% drops)]

#Setting up CV
ControlParamteres <- trainControl(method="cv",
                                  number=10,
                                  #repeats=10,
                                  #sampling = "up",
                                  #verboseIter = FALSE,
                                  summaryFunction=twoClassSummary,
                                  savePredictions = TRUE,
                                  classProbs = TRUE)
set.seed(375)
svmGrid <- expand.grid(sigma= 2^c(-7:-2), C= 2^c(0:2))

#SVM
svm10 <- caret::train(isChurn~.,
                    data=trainData,
                    method = "svmRadial",
                    #preProc=c("center", "scale"),
                    metric="ROC",
                    #tuneLength = 5,
                    tuneGrid = svmGrid,
                    trControl = ControlParamteres)

svm10

png(filename="presentations/tune10SVMCV.png",width=760, height=565)
plot(svm10)
dev.off()

plot(svm10)

testData$prob <- predict(svm10, testData ,type = "prob")[2]
ROCR_test <- ROCR::prediction(testData$prob, test_labels)
testData$isChurn <- test_labels

#Cutoff plot
reset.par()
plotCut(ROCR_test,"SVM 10")
abline(v = 0.574, col="seagreen3", lwd=2, lty=8)

png(filename="presentations/cut10SVMCV.png",width=760, height=565)
plotCut(ROCR_test,"SVM 10")
abline(v = 0.574, col="seagreen3", lwd=2, lty=8)
dev.off()

#Cutoff
testData$pred <- ifelse(testData$prob$Yes >0.574, "Yes", "No")
testData$pred<-as.factor(testData$pred)

g2 <- roc(isChurn ~ prob$Yes, data =testData )
reset.par()

#ROC plot
plot(g, col = 4, lty = 1,
     main = "ROC 10 Predictors", asp = NA,
     xlab = "Specificity (%)",
     ylab = "Sensitivity (%)",
     print.auc=TRUE, type  = 'l', ps=1000,las=1)
plot(g2, col = 3, lty = 1,
     print.auc=TRUE,
     print.auc.y = .45,
     add = TRUE, ps=1000)
legend(.40,.8,
       legend=c("Log CV"),
       col=c("4"),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.75,
       legend=c("SVM CV"),
       col=c(3),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
p<-recordPlot()

png(filename="presentations/roc10SVMCV.png",width=760, height=565)
replayPlot(p)
dev.off()

#confusionMatrix(pred, obs, positive = NULL,...), not the inverse
cm <- caret::confusionMatrix(testData$pred, testData$isChurn, positive = 'Yes',
                             dnn=c("Pred","Actual"))

png(filename="presentations/cm10SVMCV.png",width=760, height=565)
draw_confusion_matrix_cv(cm,"- SVM 10 predictors")
dev.off()

draw_confusion_matrix_cv(cm,"- SVM 10 predictors")

save(svm10, file = "models/svm10.rda")

# CART Bootstrap 10 Predictors ----------------------------------------------

###' Debug
normalizedDataset <- temp

include <- c("DistanceHomeOffice","isAfterHours",
             "isSingle","Age","avgSatisfaction",
             "TenureWorking","NumCompaniesWorked",
             "LastPromotion","MonthlyIncome","isDepartIT",
             "isChurn")

normalizedDataset <- normalizedDataset[ , (names(normalizedDataset) %in% include)]

correlation <- round(cor(normalizedDataset, method = "kendall"), 1)
png(filename="presentations/correlation10CART.png",width=760, height=565)
corr_plot(correlation)
dev.off()

corr_plot(correlation)
# Data Partition
set.seed(375); trainingRowIndex <- sample(1:nrow(normalizedDataset),
                                          0.69*nrow(normalizedDataset))
#1000 records
trainData <- normalizedDataset[trainingRowIndex, ]
#remaining 450 records
testData <- normalizedDataset[-trainingRowIndex, ]

#checking propotion of target var
normalizedDataset$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
trainData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
testData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)

png(filename="presentations/stratification10CART.png",width=300, height=250)
stratification(normalizedDataset,trainData,testData,"- CART 10 predictors")
dev.off()

stratification(normalizedDataset,trainData,testData,"- CART 10 predictors")

# Yes/No target
trainData$isChurn <- ifelse(trainData$isChurn==1,"Yes","No")
testData$isChurn <- ifelse(testData$isChurn==1,"Yes","No")

# #Save test_labels
test_labels <- as.factor(testData$isChurn)

#drop target from testData, not mandatory
drops <- c("isChurn")
testData <- testData[ , !(names(testData) %in% drops)]

#Setting up CV
ControlParamteres <- trainControl(method="boot",
                                  # number=10,
                                  #repeats=10,
                                  #sampling = "up",
                                  #verboseIter = FALSE,
                                  summaryFunction=twoClassSummary,
                                  savePredictions = TRUE,
                                  classProbs = TRUE)

set.seed(375)
tunegrid <- expand.grid(.maxdepth =c(2:25))
#CART
cart10 <- caret::train(isChurn~.,
                     data=trainData,
                     method = "rpart2",
                     #preProc=c("center", "scale"),
                     metric="ROC",
                     #tuneLength = 10,
                     tuneGrid=tunegrid,
                     trControl = ControlParamteres)

cart10

png(filename="presentations/tune10CART.png",width=760, height=565)
plot(cart10)
dev.off()

plot(cart10)

testData$prob <- predict(cart10, testData ,type = "prob")[2]
ROCR_test <- ROCR::prediction(testData$prob, test_labels)
testData$isChurn <- test_labels

#Cutoff
reset.par()
plotCut(ROCR_test,"CART 10")
abline(v = 0.8, col="seagreen3", lwd=2, lty=8)

png(filename="presentations/cut10CART.png",width=760, height=565)
plotCut(ROCR_test,"CART 10")
abline(v = 0.8, col="seagreen3", lwd=2, lty=8)
dev.off()

testData$pred <- ifelse(testData$prob$Yes > 0.8, "Yes", "No")
testData$pred<-as.factor(testData$pred)

g3 <- roc(isChurn ~ prob$Yes, data =testData )
reset.par()

#ROC plot
plot(g, col = 4, lty = 1,
     main = "ROC 10 Predictors", asp = NA,
     xlab = "Specificity (%)",
     ylab = "Sensitivity (%)",
     print.auc=TRUE, type  = 'l', ps=1000,las=1)
plot(g2, col = 3, lty = 1,
     print.auc=TRUE,
     print.auc.y = .45,
     add = TRUE, ps=1000)
plot(g3, col = 2, lty = 1,
     print.auc=TRUE,
     print.auc.y = .4,
     add = TRUE, ps=1000)
legend(.40,.8,
       legend=c("Log CV"),
       col=c("4"),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.75,
       legend=c("SVM CV"),
       col=c(3),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.7,
       legend=c("CART Bootstrap"),
       col=c(2),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
p<-recordPlot()

png(filename="presentations/roc10CART.png",width=760, height=565)
replayPlot(p)
dev.off()

#confusionMatrix(pred, obs, positive = NULL,...), not the inverse
cm <- caret::confusionMatrix(testData$pred, testData$isChurn, positive = 'Yes',
                             dnn=c("Pred","Actual"))

png(filename="presentations/cm10CART.png",width=760, height=565)
draw_confusion_matrix_boot(cm,"- CART 10 predictors")
dev.off()

draw_confusion_matrix_boot(cm,"- CART 10 predictors")

save(cart10, file = "models/cart10.rda")

# LDA CV 10 Predictors ----------------------------------------------

###' Debug
normalizedDataset <- temp

include <- c("DistanceHomeOffice","isAfterHours",
             "isSingle","Age","avgSatisfaction",
             "TenureWorking","NumCompaniesWorked",
             "LastPromotion","MonthlyIncome","isDepartIT",
             "isChurn")

normalizedDataset <- normalizedDataset[ , (names(normalizedDataset) %in% include)]

correlation <- round(cor(normalizedDataset, method = "kendall"), 1)
png(filename="presentations/correlation10LDA.png",width=1000, height=565)
corr_plot(correlation)
dev.off()

corr_plot(correlation)

# Data Partition
set.seed(375); trainingRowIndex <- sample(1:nrow(normalizedDataset),
                                          0.69*nrow(normalizedDataset))
#1000 records
trainData <- normalizedDataset[trainingRowIndex, ]
#remaining 450 records
testData <- normalizedDataset[-trainingRowIndex, ]

#checking propotion of target var
normalizedDataset$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
trainData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
testData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)

png(filename="presentations/stratification10LDA.png",width=300, height=250)
stratification(normalizedDataset,trainData,testData,"- LDA 10 predictors")
dev.off()

stratification(normalizedDataset,trainData,testData,"- LDA 10 predictors")

#Yes /No target
trainData$isChurn <- ifelse(trainData$isChurn==1,"Yes","No")
testData$isChurn <- ifelse(testData$isChurn==1,"Yes","No")

#Save test_labels
test_labels <- as.factor(testData$isChurn)

#drop target from testData, not mandatory
drops <- c("isChurn")
testData <- testData[ , !(names(testData) %in% drops)]

#Setting up CV
ControlParamteres <- trainControl(method="cv",
                                  number=10,
                                  #repeats=10,
                                  #sampling = "up",
                                  #verboseIter = FALSE,
                                  # summaryFunction=mnLogLoss,
                                  summaryFunction=twoClassSummary,
                                  savePredictions = TRUE,
                                  classProbs = TRUE)

set.seed(375)
# tunegrid <-  expand.grid(.NumVars = c(11),
#                             .lambda = c(100))

#LDA
lda10 <- caret::train(isChurn~.,
                    data=trainData,
                    method = "lda",
                    #preProc=c("center", "scale"),
                    metric="ROC",
                    #tuneGrid = tunegrid,
                    #tuneLength=10,
                    trControl = ControlParamteres)

lda10

testData$prob <- predict(lda10, testData ,type = "prob")[2]
ROCR_test <- ROCR::prediction(testData$prob, test_labels)
testData$isChurn <- test_labels

#Cutoff
reset.par()
plotCut(ROCR_test,"LDA 10")
abline(v = 0.613, col="seagreen3", lwd=2, lty=8)

png(filename="presentations/cut10LDACV.png",width=760, height=565)
plotCut(ROCR_test,"LDA 10")
abline(v = 0.613, col="seagreen3", lwd=2, lty=8)
dev.off()

testData$pred <- ifelse(testData$prob$Yes > 0.613, "Yes", "No")
testData$pred<-as.factor(testData$pred)

g4 <- roc(isChurn ~ prob$Yes, data =testData )
reset.par()

#ROC plot
plot(g, col = 4, lty = 1,
     main = "ROC 10 Predictors", asp = NA,
     xlab = "Specificity (%)",
     ylab = "Sensitivity (%)",
     print.auc=TRUE, type  = 'l', ps=1000,las=1)
plot(g2, col = 3, lty = 1,
     print.auc=TRUE,
     print.auc.y = .45,
     add = TRUE, ps=1000)
plot(g3, col = 2, lty = 1,
     print.auc=TRUE,
     print.auc.y = .4,
     add = TRUE, ps=1000)
plot(g4, col = 4, lty = 3,
     print.auc=TRUE,
     print.auc.y = .35,
     add = TRUE, ps=1000)
legend(.40,.8,
       legend=c("Log CV"),
       col=c("4"),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.75,
       legend=c("SVM CV"),
       col=c(3),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.7,
       legend=c("CART Bootstrap"),
       col=c(2),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.65,
       legend=c("LDA CV"),
       col=c(4),
       lwd=2, ncol = 1,bty = "n", cex=1.3,lty=15)
p<-recordPlot()

png(filename="presentations/roc10LDACV.png",width=760, height=565)
replayPlot(p)
dev.off()

#confusionMatrix(pred, obs, positive = NULL,...), not the inverse
cm <- caret::confusionMatrix(testData$pred, testData$isChurn, positive = 'Yes',
                             dnn=c("Pred","Actual"))

png(filename="presentations/cm10LDACV.png",width=760, height=565)
draw_confusion_matrix_cv(cm,"- LDA 10 predictors")
dev.off()

draw_confusion_matrix_cv(cm,"- LDA 10 predictors")

save(lda10, file = "models/lda10.rda")

# NN CV 10 Predictors ----------------------------------------------

###' Debug
normalizedDataset <- temp

include <- c("DistanceHomeOffice","isAfterHours",
             "isSingle","Age","avgSatisfaction",
             "TenureWorking","NumCompaniesWorked",
             "LastPromotion","MonthlyIncome","isDepartIT",
             "isChurn")

normalizedDataset <- normalizedDataset[ , (names(normalizedDataset) %in% include)]

correlation <- round(cor(normalizedDataset, method = "kendall"), 1)
png(filename="presentations/correlation10NN.png",width=760, height=565)
corr_plot(correlation)
dev.off()

corr_plot(correlation)

# Data Partition
set.seed(375); trainingRowIndex <- sample(1:nrow(normalizedDataset),
                                          0.69*nrow(normalizedDataset))
#1000 records
trainData <- normalizedDataset[trainingRowIndex, ]
#remaining 450 records
testData <- normalizedDataset[-trainingRowIndex, ]

#checking propotion of target var
normalizedDataset$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
trainData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
testData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)

png(filename="presentations/stratification10NN.png",width=300, height=250)
stratification(normalizedDataset,trainData,testData,"- NN 10 predictors")
dev.off()

stratification(normalizedDataset,trainData,testData,"- NN 10 predictors")

# Yes no target
trainData$isChurn <- ifelse(trainData$isChurn==1,"Yes","No")
testData$isChurn <- ifelse(testData$isChurn==1,"Yes","No")

# #Save test_labels
test_labels <- as.factor(testData$isChurn)

#drop target from testData, not mandatory
drops <- c("isChurn")
testData <- testData[ , !(names(testData) %in% drops)]

#Setting up CV
ControlParamteres <- trainControl(method="cv",
                                  number=10,
                                  #repeats=10,
                                  #sampling = "up",
                                  #verboseIter = FALSE,
                                  summaryFunction=twoClassSummary,
                                  savePredictions = TRUE,
                                  classProbs = TRUE)

set.seed(375) #weights
nnetGrid <-  expand.grid(size = seq(from = 1, to = 10, by = 1),
                         decay = seq(from = 0.1, to = 0.5, by = 0.1))

#NN
bin <- capture.output(nn10 <- caret::train(isChurn~.,
                                         data=trainData,
                                         method = "nnet",
                                         #preProc=c("center", "scale"),
                                         metric="ROC",
                                         #tuneLength = 5,
                                         tuneGrid = nnetGrid,
                                         trControl = ControlParamteres))

nn10

png(filename="presentations/tune10NNCV.png",width=760, height=565)
plot(nn10)
dev.off()

plot(nn10)

testData$prob <- predict(nn10, testData ,type = "prob")[2]
ROCR_test <- ROCR::prediction(testData$prob, test_labels)
testData$isChurn <- test_labels

#Cutoff
reset.par()
plotCut(ROCR_test,"NN 10")
abline(v = 0.53, col="seagreen3", lwd=2, lty=8)

png(filename="presentations/cut10NNCV.png",width=760, height=565)
plotCut(ROCR_test,"NN 10")
abline(v = 0.53, col="seagreen3", lwd=2, lty=8)
dev.off()

testData$pred <- ifelse(testData$prob$Yes > 0.53, "Yes", "No")
testData$pred<-as.factor(testData$pred)

g5 <- roc(isChurn ~ prob$Yes, data =testData )
reset.par()

#ROC plot
plot(g, col = 4, lty = 1,
     main = "ROC 10 Predictors", asp = NA,
     xlab = "Specificity (%)",
     ylab = "Sensitivity (%)",
     print.auc=TRUE, type  = 'l', ps=1000,las=1)
plot(g2, col = 3, lty = 1,
     print.auc=TRUE,
     print.auc.y = .45,
     add = TRUE, ps=1000)
plot(g3, col = 2, lty = 1,
     print.auc=TRUE,
     print.auc.y = .4,
     add = TRUE, ps=1000)
plot(g4, col = 4, lty = 3,
     print.auc=TRUE,
     print.auc.y = .35,
     add = TRUE, ps=1000)
plot(g5, col = 3, lty = 3,
     print.auc=TRUE,
     print.auc.y = .3,
     add = TRUE, ps=1000)
legend(.40,.8,
       legend=c("Log CV"),
       col=c("4"),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.75,
       legend=c("SVM CV"),
       col=c(3),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.7,
       legend=c("CART Bootstrap"),
       col=c(2),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.65,
       legend=c("LDA CV"),
       col=c(4),
       lwd=2, ncol = 1,bty = "n", cex=1.3,lty=15)
legend(.40,.6,
       legend=c("NN CV"),
       col=c(3),
       lwd=2, ncol = 1,bty = "n", cex=1.3,lty=15)
p<-recordPlot()

png(filename="presentations/roc10NN.png",width=760, height=565)
replayPlot(p)
dev.off()

#confusionMatrix(pred, obs, positive = NULL,...), not the inverse
cm <- caret::confusionMatrix(testData$pred, testData$isChurn, positive = 'Yes',
                             dnn=c("Pred","Actual"))

png(filename="presentations/cm10NN.png",width=760, height=565)
draw_confusion_matrix_cv(cm,"- NN 10 predictors")
dev.off()

draw_confusion_matrix_cv(cm,"- NN 10 predictors")

save(nn10, file = "models/nn10.rda")

# RF Bootstrap 10 Predictors ----------------------------------------------

###' Debug
normalizedDataset <- temp

include <- c("DistanceHomeOffice","isAfterHours",
             "isSingle","Age","avgSatisfaction",
             "TenureWorking","NumCompaniesWorked",
             "LastPromotion","MonthlyIncome","isDepartIT",
             "isChurn")

normalizedDataset <- normalizedDataset[ , (names(normalizedDataset) %in% include)]

correlation <- round(cor(normalizedDataset, method = "kendall"), 1)
png(filename="presentations/correlation10RF.png",width=760, height=565)
corr_plot(correlation)
dev.off()

corr_plot(correlation)

# Data Partition
set.seed(375); trainingRowIndex <- sample(1:nrow(normalizedDataset),
                                          0.69*nrow(normalizedDataset))
#1000 records
trainData <- normalizedDataset[trainingRowIndex, ]
#remaining 450 records
testData <- normalizedDataset[-trainingRowIndex, ]

#checking propotion of target var
normalizedDataset$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
trainData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
testData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)

png(filename="presentations/stratification10RF.png",width=300, height=250)
stratification(normalizedDataset,trainData,testData,"- RF 10 predictors")
dev.off()

stratification(normalizedDataset,trainData,testData,"- RF 10 predictors")

# Yes/No target
trainData$isChurn <- ifelse(trainData$isChurn==1,"Yes","No")
testData$isChurn <- ifelse(testData$isChurn==1,"Yes","No")

#Save test_labels
test_labels <- as.factor(testData$isChurn)

#drop target from testData, not mandatory
drops <- c("isChurn")
testData <- testData[ , !(names(testData) %in% drops)]

#Setting up CV
ControlParamteres <- trainControl(method="boot",
                                  #number=10,
                                  #repeats=10,
                                  #sampling = "up",
                                  #verboseIter = FALSE,
                                  summaryFunction=twoClassSummary,
                                  savePredictions = TRUE,
                                  classProbs = TRUE)

set.seed(375)
tunegrid <- expand.grid(.mtry=c(1:10))

#Random forest
rf10 <- caret::train(isChurn~.,
                   data=trainData,
                   method = "rf",
                   ntree=50,
                   #preProc=c("center", "scale"),
                   metric="ROC",
                   #tuneLength=10,
                   tuneGrid=tunegrid,
                   trControl = ControlParamteres)

rf10

png(filename="presentations/tune10RF.png",width=760, height=565)
plot(rf10)
dev.off()

plot(rf10)

testData$prob <- predict(rf10, testData ,type = "prob")[2]
ROCR_test <- ROCR::prediction(testData$prob, test_labels)
testData$isChurn <- test_labels

#Cutoff
reset.par()
plotCut(ROCR_test,"RF 10")
abline(v = 0.399, col="seagreen3", lwd=2, lty=8)

png(filename="presentations/cut10RF.png",width=760, height=565)
plotCut(ROCR_test,"RF 10")
abline(v = 0.399, col="seagreen3", lwd=2, lty=8)
dev.off()

testData$pred <- ifelse(testData$prob$Yes > 0.399, "Yes", "No")
testData$pred<-as.factor(testData$pred)

g6 <- roc(isChurn ~ prob$Yes, data =testData )
reset.par()

#ROC plot
plot(g, col = 4, lty = 1,
     main = "ROC 10 Predictors", asp = NA,
     xlab = "Specificity (%)",
     ylab = "Sensitivity (%)",
     print.auc=TRUE, type  = 'l', ps=1000,las=1)
plot(g2, col = 3, lty = 1,
     print.auc=TRUE,
     print.auc.y = .45,
     add = TRUE, ps=1000)
plot(g3, col = 2, lty = 1,
     print.auc=TRUE,
     print.auc.y = .4,
     add = TRUE, ps=1000)
plot(g4, col = 4, lty = 3,
     print.auc=TRUE,
     print.auc.y = .35,
     add = TRUE, ps=1000)
plot(g5, col = 3, lty = 3,
     print.auc=TRUE,
     print.auc.y = .3,
     add = TRUE, ps=1000)
plot(g6, col = 2, lty = 3,
     print.auc=TRUE,
     print.auc.y = .25,
     add = TRUE, ps=1000)
legend(.40,.8,
       legend=c("Log CV"),
       col=c("4"),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.75,
       legend=c("SVM CV"),
       col=c(3),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.7,
       legend=c("CART Bootstrap"),
       col=c(2),
       lwd=2, ncol = 1,bty = "n", cex=1.3)
legend(.40,.65,
       legend=c("LDA CV"),
       col=c(4),
       lwd=2, ncol = 1,bty = "n", cex=1.3,lty=15)
legend(.40,.6,
       legend=c("NN CV"),
       col=c(3),
       lwd=2, ncol = 1,bty = "n", cex=1.3,lty=15)
legend(.40,.55,
       legend=c("RF Bootstrap"),
       col=c(2),
       lwd=2, ncol = 1,bty = "n", cex=1.3,lty=15)
p<-recordPlot()

png(filename="presentations/roc10RF.png",width=760, height=565)
replayPlot(p)
dev.off()

#confusionMatrix(pred, obs, positive = NULL,...), not the inverse
cm <- caret::confusionMatrix(testData$pred, testData$isChurn, positive = 'Yes',
                             dnn=c("Pred","Actual"))

png(filename="presentations/cm10RF.png",width=760, height=565)
draw_confusion_matrix_boot(cm,"- RF 10 predictors")
dev.off()

draw_confusion_matrix_boot(cm,"- RF 10 predictors")

save(rf10, file = "models/rf10.rda")


rm(list = ls()) # This clears everything from memory.

setwd("~/Dropbox/BCI_Turnover")
load("BCI_turnover20150611.RData")
source("~/Dropbox/MS/TurnoverBCI/TurnoverBCImain/source.R")

####
#kernel density
#####
library(ggplot2)
library(gridExtra)
library(dplyr)
theme_set(theme_bw())

WSG100 <- lapply(D100ba, function(x)com.mean.ab(x, trait, "WSG"))
Moist100 <- lapply(D100ba, function(x)com.mean.ab(x, trait, "Moist"))
slope100 <- lapply(D100ba, function(x)com.mean.ab(x, trait, "sp.slope.mean"))
convex100 <- lapply(D100ba, function(x)com.mean.ab(x, trait, "sp.convex.mean"))

WSG20 <- lapply(D20ba, function(x)com.mean.ab(x, trait, "WSG"))
Moist20 <- lapply(D20ba, function(x)com.mean.ab(x, trait, "Moist"))
slope20 <- lapply(D20ba, function(x)com.mean.ab(x, trait, "sp.slope.mean"))
convex20 <- lapply(D20ba, function(x)com.mean.ab(x, trait, "sp.convex.mean"))

kernel.20 <- data.frame(WSG=unlist(WSG20),
             convex=unlist(convex20),
             slope=unlist(slope20),
             moist=unlist(Moist20),
             time=c(rep(1982,50),
                    rep(1985,50),
                    rep(1990,50),
                    rep(1995,50),
                    rep(2000,50),
                    rep(2005,50),
                    rep(2010,50)))

kernel.100 <- data.frame(WSG=unlist(WSG100),
             #convex=unlist(convex.100.rare[[10]),
             #slope=unlist(slope.100.rare[[10]),
             convex=unlist(convex100),
             slope=unlist(slope100),
             moist=unlist(Moist100),
             time=c(rep(1982,50),
                    rep(1985,50),
                    rep(1990,50),
                    rep(1995,50),
                    rep(2000,50),
                    rep(2005,50),
                    rep(2010,50)))

temp <- sapply(WSG.ind,length)
k.ind.WSG <- data.frame(WSG=unlist(WSG.ind),
            time=c(rep(1982,temp[1]),
                  rep(1985,temp[2]),
                  rep(1990,temp[3]),
                  rep(1995,temp[4]),
                  rep(2000,temp[5]),
                  rep(2005,temp[6]),
                  rep(2010,temp[7])))

temp <- sapply(Moist.ind,length)
k.ind.moist <- data.frame(moist=unlist(Moist.ind),
            time=c(rep(1982,temp[1]),
                  rep(1985,temp[2]),
                  rep(1990,temp[3]),
                  rep(1995,temp[4]),
                  rep(2000,temp[5]),
                  rep(2005,temp[6]),
                  rep(2010,temp[7])))
# temp <- sapply(slope.ind.rare[[1]],length)
temp <- sapply(slope.ind,length)
k.ind.slope <- data.frame(slope=unlist(slope.ind),
            time=c(rep(1982,temp[1]),
                  rep(1985,temp[2]),
                  rep(1990,temp[3]),
                  rep(1995,temp[4]),
                  rep(2000,temp[5]),
                  rep(2005,temp[6]),
                  rep(2010,temp[7])))

# temp <- sapply(convex.ind.rare[[1]],length)
temp <- sapply(convex.ind, length)
k.ind.convex <- data.frame(convex=unlist(convex.ind),
            time=c(rep(1982,temp[1]),
                  rep(1985,temp[2]),
                  rep(1990,temp[3]),
                  rep(1995,temp[4]),
                  rep(2000,temp[5]),
                  rep(2005,temp[6]),
                  rep(2010,temp[7])))

temp100 <- kernel.100 %>%
  mutate(size = "1ha")

temp20 <- kernel.20 %>%
  mutate(size = "0.04ha")

fig_dat <- bind_rows(temp100, temp20) %>%
  tidyr::gather(., "trait", "val", 1:4)

temp1 <- data_frame(time = k.ind.WSG$time,
    size = "individual",
    trait = "WSG",
    val = k.ind.WSG[,1])

temp2 <- data_frame(time = k.ind.moist$time,
    size = "individual",
    trait = "moist",
    val = k.ind.moist[,1])

temp3 <- data_frame(time = k.ind.convex$time,
    size = "individual",
    trait = "convex",
    val = k.ind.convex[,1])

temp4 <- data_frame(time = k.ind.slope$time,
    size = "individual",
    trait = "slope",
    val = k.ind.slope[,1])

fig_dat2 <- bind_rows(fig_dat, temp1, temp2, temp3, temp4) %>%
  mutate(size = factor(size, levels = c("1ha", "0.04ha", "individual"))) %>%
  mutate(trait = factor(trait, levels = c("WSG", "moist", "convex", "slope"))) %>%
  mutate(size2 = factor(size, labels = c("1ha", "0.04ha", "Individual"))) %>%
  mutate(trait2 = factor(trait, labels = c("Wood~density ~(g~cm^{-3})", "Moist", "Convexity~(m)", "Slope~(degrees)")))

dummy1 <- data_frame(time = 1982,
    size = "1ha",
    trait = "WSG",
    val = c(0.55, 0.65))
dummy2 <- data_frame(time = 1982,
    size = "1ha",
    trait = "moist",
    val = c(-2, 4))

dummy3 <- data_frame(time = 1982,
    size = "individual",
    trait = "moist",
    val = c(-2, 4))

dummy4 <- data_frame(time = 1982,
    size = "1ha",
    trait = "slope",
    val = c(4, 6))

dummy5 <- data_frame(time = 1982,
    size = "0.04ha",
    trait = "slope",
    val = c(4, 6))

dummy0 <- fig_dat2 %>%
    filter(., size != "0.04ha" | trait != "convex" | (val > 0.035 & val < 0.085)) %>%
    filter(., size != "individual" | trait != "convex" | (val > -0.15 & val < 0.25)) %>%
    filter(., size != "0.04ha" | trait != "slope" | (val > 4 & val < 6)) %>%
    filter(., size != "individual" | trait != "slope" | (val > 2 & val < 8)) %>%
    filter(size != "0.04ha") %>%# new
    mutate(size = factor(size, levels = c("1ha", "individual"))) %>%
    mutate(size2 = factor(size, labels = c("1ha", "Individual")))

dummy <- bind_rows(dummy0, dummy1, dummy2, dummy3, dummy4, dummy5) %>%
  filter(size != "0.04ha") %>%# new
  mutate(size = factor(size, levels = c("1ha","individual"))) %>%
  mutate(trait = factor(trait, levels = c("WSG", "moist", "convex", "slope"))) %>%
  mutate(size2 = factor(size, labels = c("1ha", "Individual"))) %>%
  mutate(trait2 = factor(trait, labels = c("Wood~density ~(g~cm^{-3})", "Moist", "Convexity~(m)", "Slope~(degrees)")))

before <- proc.time()
pdf("~/Dropbox/MS/TurnoverBCI/fig/fig1_BA.pdf",
  width = 8, height = 5, paper = "special")

ggplot(dummy0, aes(x = val)) +
  facet_wrap(~ size2 + trait2, nrow = 2, scale = "free",
  labeller = labeller(trait2 = label_parsed, sizes = label_value)) +
  geom_density(data = filter(dummy0, size == "1ha"), adjust = 1,
    aes(colour = as.factor(time))) +
  guides(colour = guide_legend(title = NULL)) +
  # guides(fill = guide_legend(override.aes = list(fille = as.factor(time)))) +
  theme(panel.margin.x = unit(0.5, "lines"),
  legend.position = c(1, 0.4), legend.justification = c(1,1),
  legend.text = element_text(size = 7),
  legend.background = element_rect(fill=alpha('blue', 0)),
  legend.key.size = unit(0.4, "cm"),
  axis.text.x = element_text(angle = 45)) +

  geom_blank(data = dummy) +
  geom_density(data = filter(dummy0, size == "individual"), adjust = 4, aes(colour = as.factor(time))) +
  ylab("Density") +
  xlab("Trait values")
dev.off()
after <- proc.time()
after - before


suppressPackageStartupMessages(library(float))
tol = 1e-6

x = matrix(1:10, 5)
s = fl(x)

test = dbl(rbind(s, s))
truth = rbind(x, x)
stopifnot(all.equal(test, truth))

test = dbl(rbind(s, 1L))
truth = rbind(x, 1L)
stopifnot(all.equal(test, truth))

test = rbind(s, 1.0)
truth = rbind(x, 1.0)
stopifnot(all.equal(test, truth))

test = dbl(cbind(s, s))
truth = cbind(x, x)
stopifnot(all.equal(test, truth))

test = dbl(cbind(s, 1L))
truth = cbind(x, 1L)
stopifnot(all.equal(test, truth))

test = cbind(s, 1.0)
truth = cbind(x, 1.0)
stopifnot(all.equal(test, truth))


## Thanks: Colin O'Rourke <orourkc@ccf.org>

require(Hmisc)
d = data.frame(
    CaseNum = 1:20,
   Status = c("Dead", "Dead", "Dead", "Dead", "Alive", "Alive",
                "Alive", "Dead", "Dead", "Dead", "Dead", "Dead",
                "Alive", "Alive", "Alive", "Dead", "Dead", "Dead",
                "Alive", "Dead"),
   Cause1 = c("Bloating", "Heart", "Age", "Sepsis", NA, NA,
                NA, "Age", "Bloating", "Sepsis", "Heart", "Heart",
                NA, NA, NA, "Cancer", "Sepsis", "Heart", NA,
                "Age"),
   Cause2 = c("", "Age", "Bloating", "Dog bite", NA, NA, NA,
                "Fright", "Sepsis", "Age", "Bloating", "Cancer",
                NA, NA, NA, "Heart", "Dog bite", "", NA,
                "Dog bite"),
   Cause3 = c("", "", "", "Trauma", NA, NA, NA, "", "Trauma",
                "", "Trauma", "", NA, NA, NA, "", "", "", NA,
                ""))

#   The data created from the R code above has patient status (alive/dead) and
# if dead, what the cause or causes of death are. Patients who are alive have a
# causes set to missing.
#    Turn the causes of death in a variable of class “mChoice”.
d$Cause = with(d, mChoice(Cause1, Cause2, Cause3, label="Cause of death"))
sum(is.na(d$Cause))
summary(~ Cause, data=d)
summary(~ Cause, data=subset(d, Status == 'Dead'))

# Notice how NA is tabulated as part of the summary, and how it appears as
# the most common combination of causes. Now, I would like to summarise the
# frequency of each cause, marginal on the other causes.

# This gives the following summary table (output in table 1):
#  Not only is NA tabulated in the summary, but the percentages are out of the
# full 20 patients, rather than only the 13 patient who died.

# FH response: mChoice intended for the NA to be something like "none" or "", and to get the proportions
# you want you need to subset the data as above on Status == 'Dead'


# install necessary packages ----
library(ggplot2)
library(ggradar)
suppressPackageStartupMessages(library(dplyr))
library(scales)

#load necessary data
forward <= read_csv('forward.csv')

# data processing ----
forward_radar <- forward %>%
  mutate_at(vars(-'Player Name'),function(x) x/100)%>%
  tail(3)

# visualization radar plot ----
ggradar(forward_radar) +
  ggsave("forward_radar_plot.png")


# Rscript visualize_prs_betase.r

### assign file and path names ###
args<-commandArgs(TRUE)
mpath <- args[1]
outpath <- args[2]
idsf <- args[3]
prefix <- args[4]
pval <- args[5]
outtype <- args[6]
x <- c("CEU", "GBR", "IBS", "TSI")

### read in individual assignment file ###
ids <- read.table(idsf, header=TRUE)
npops <- length(unique(ids$assignment))

### obtain original scores
fname2 <- paste(prefix,".effectacounts.indsubset.subpops.gwas.pvalthres.", pval,".prs", sep="")
f2 <- paste(mpath, fname2, sep="")

### Subpopulation analysis ###
## read in file with subpopulation counts
fields <- count.fields(f2, sep = '\t')
maxf <- max(fields)
df2 <- read.table(f2, header=FALSE, col.names = paste0("V",seq_len(maxf)), fill = TRUE)

## pull number and names of subpopulations
n <- df2[2,]
labels <- n[n != ""]
nlabels <- length(labels)
sumso <- as.numeric(t(df2[3,1:nlabels]))
totso <- as.numeric(t(df2[3,(nlabels+1):(nlabels*2)]))
countso <- as.numeric(t(df2[3,((nlabels*2)+1):(nlabels*3)]))
meano <- as.numeric(t(df2[3,((nlabels*3)+1):((nlabels*3)+2)]))[1]
Vao <- as.numeric(t(df2[3,((nlabels*3)+1):((nlabels*3)+2)]))[2]
varZ <- as.numeric(t(df2[3,((nlabels*3)+3):((nlabels*3)+3+nlabels-1)]))
normprso <- (sumso-meano)/sqrt(Vao)
se <- sqrt(varZ)
normcilow <- ((sumso-1.96*se) - meano)/sqrt(Vao)
normcihi <- ((sumso + 1.96*se) - meano)/sqrt(Vao)

## compute times for each subpopulation
avg_dates <- c()
counter <- 1
for (labeli in labels){
	dates = ids$date[ids$assignment==labeli]
	avg_dates[counter] <- mean(dates)
	counter <- counter + 1
}
avg_dates <- avg_dates * -1

## create data frame for subpopulations

inds <- match(x, labels)

outdf <- data.frame(labels[inds], sumso[inds], se[inds], sumso[inds]-1.96*se[inds], sumso[inds]+1.96*se[inds],avg_dates[inds])
names(outdf) <- c("populations", "scores", "se", "lower", "upper","times")
write.table(outdf, file=paste(outpath, outtype, ".betase.pval.", pval, sep=""), quote=FALSE, row.names=FALSE)

outdf2 <- data.frame(labels[inds], normprso[inds], normcilow[inds], normcihi[inds],avg_dates[inds])
names(outdf2) <- c("populations", "scores", "lower", "upper","times")
write.table(outdf2, file=paste(outpath, outtype, ".betase.norm.pval.", pval, sep=""), quote=FALSE, row.names=FALSE)


#' Function for easy access to `mlr` machine learning models
#'
#' @param formula     A formula that describes the data relationship
#' @param train_args  mlr args, e.g. list("regr.glmnet", dfmax=5)
#' @param data        The data to process, or parent.frame() by default
#' @param models      Return model objects instead of fit statistics
#' @param aggr        Return aggregate statistics instead of fit statistics
#'                    This can be a list of mlr "Measure" objects (e.g. mlr::mse)
#' @param xval        Number of cross-validation steps to perform
#' @param min_pts     Minimum number of data points to calculate model from
#' @param shuffle_labels  Whether to shuffle the response variable - for null models
#' @param subsets     Vector whose unique set is used to split the data along rows
#' @param atomic_class  Variable classes that should not be split by default
#' @return            A data.frame containing the trained models
ml = function(formula, train_args, data=environment(formula), models=FALSE, aggr=FALSE,
              xval=5, min_pts=10, shuffle_labels=FALSE, atomic_class=c('vector','matrix')) {
    library(mlr) # needed for options

    # set all formula vars to atomic
    indep_vars = all.vars(formula[[3]])
    dep_vars = all.vars(formula[[2]])
    stopifnot(length(dep_vars) == 1 && length(dim(dep_vars)) < 2) # only vector response
    if (identical(shuffle_labels, TRUE))
        data[[dep_vars]] = sample(data[[dep_vars]])

    # bind data and response to data.frame, use var name if one column
    data = as.list(data)[c(indep_vars, dep_vars)]
    for (i in names(data))
        if (is.matrix(data[[i]]) && ncol(data[[i]]) == 1 && is.null(colnames(data[[i]])))
            colnames(data[[i]]) = names(data)[i]
    data = as.data.frame(na.omit(do.call(cbind, data)))
    colnames(data) = make.names(colnames(data), unique=TRUE) # mlr needs this

    # make sure we have enough data
    if (nrow(data) < min_pts)
        return(NULL)

    # train model, max 4 variables
    learner = do.call(mlr::makeLearner, as.list(train_args))
    task = mlr::makeRegrTask(data=data, target=dep_vars)

    if (is.list(aggr)) {
        result = mlr::crossval(learner, task, iters=xval, models=models, measures=aggr)
        aggr = TRUE
    } else
        result = mlr::crossval(learner, task, iters=xval, models=models)

    if (aggr)
        result$aggr
    else if (models)
        result
    else
        result$pred$data
}

if (is.null(module_name())) {
    library(testthat)

    dm = data.matrix(iris[1:4])
    resp = as.factor(iris$Species)

    re = ml(resp ~ dm, list("regr.glmnet"))

    expect_equal(class(re), "data.frame")
    expect_equal(nrow(re), 150)
}


#' extract_npp.r
#' Extracts NPP from the Atlas of the Biosphere product, a MODIS NPP product.
#' Foley, J.A., I.C. Prentice, N. Ramankutty, S. Levis, D. Pollard, S. Sitch, and A. Haxeltine (1996) An Integrated Biosphere Model of Land Surface Processes, Terrestrial Carbon Balance and Vegetation Dynamics, Global Biogeochemical Cycles, 10, 603-628.
#'
#' @param latitude   #vector of latitude in decimal degrees.
#' @param longitude  #vector of longitude in decimal degrees.
#' @param path       #path to NPP raster with header file. downloaded here: https://nelson.wisc.edu/sage/data-and-models/atlas/data/npp.zip
#' @return           #returns a vector of NPP values.
#' @export
#'
#' @examples
#' points <- structure(c(-102.644235, -58.015319, 50.508187, -148.2747566, 38.816171, -7.719157, 21.754477, 64.766184), .Dim = c(4L,2L))
#' test.out <- extract_npp(points[,2], points[,1])
extract_npp <- function(latitude, longitude, path = '/fs/data3/caverill/AoB_NPP/npp_raster/npp/w001001.adf'){
  #load NPP raster
  npp_raster <- raster::raster(path)
  #extract
  points <- cbind(longitude, latitude)
  output <- raster::extract(npp_raster, points)
  return(output)
}


# Performing selection tasks on the dataframe

# Print out diameter of Mercury (row 1, column 3)
planets_df[1,3]

# Print out data for Mars (entire fourth row)
planets_df[4,]

# Select first 5 values of diameter column - making use of the column name
planets_df[1:5, "diameter"]

# Select the rings variable from planets_df - the $variable_name allows us to subset the dataframe for all values in this column
rings_vector <- planets_df$rings

# Print out rings_vector
rings_vector

# Adapt the code to select all columns for planets with rings - select true values
planets_df[rings_vector, ]

# Select planets with diameter < 1
subset(planets_df, subset = diameter < 1)

# subset(my_df, subset = some_condition)
# my_df: dataframe to be reviewed
# subset: condition to filter dataframe on. Can use columns that are logical or create a filter string as shown above


suppressPackageStartupMessages(library(kazaam))

y = 1:5 # deliberately global

if (comm.rank() == 0){
  x = matrix(1:30, 10)
  z = matrix(rnorm(14), ncol=2)
} else {
  x = NULL
}

dx = expand(x)
dz = expand(z)

test = sum(dx)
comm.print(all.equal(test, sum(x)))

test = sum(dx, y)
comm.print(all.equal(test, sum(x, y)))

test = sum(dx, y, dz)
comm.print(all.equal(test, sum(x, y, z)))

finalize()


#' getData
#'
#' Extract the internal storage representation of the banded matrix. WARNING:
#' for advanced users only.
#'
#' @details
#' See url in the references for an explanation of the storage.
#'
#' @param x
#' A band matrix.
#'
#' @references \url{http://www.netlib.org/lapack/lug/node124.html}
#' @keywords Accessors
#' @export
getData <- function(x) x@Data

#' getdim
#'
#' Get the dimension of the banded matrix. Like \code{dim()} for R matrices.
#'
#' @param x
#' A band matrix.
#'
#' @keywords Accessors
#' @export
getdim <- function(x) x@dim

#' kdim
#'
#' Get the "dimension" of the bands, i.e. the bandwidth.
#'
#' @details
#' The first digit is the width of the lower band while the second is the
#' width of the upper band.  For a general band matrix, these numbers can
#' be different.  For a symmetric matrix, they will be the same.  For a
#' diagonal matrix, they will both be 0.  In any case, each will be a
#' non-negative integer.
#'
#' @param x
#' A band matrix.
#'
#' @return
#' A length 2 vector, similar to \code{dim()}.
#'
#' @keywords Accessors
#' @export
kdim <- function(x)
{
  if (class(x) == "GenBandMat")
    c(x@kl, x@ku)
  else if (class(x) == "SymBandMat")
    c(x@k, x@k)
  else if (class(x) == "DiagMat")
    c(0L, 0L)
  else if (class(x) == "ZeroMat")
    c(-1L, -1L)
  else
    stop("'x' must be a band matrix")
}

# TODO
# Prefer not to export this, because someone will likely do something crazy with it
setGeneric("setData<-",
  function(x, value)
    standardGeneric("setData<-"),
  package="band"
)

setMethod("setData<-", signature(x="BandMat", value="VecTypes"),
  function(x, value)
  {
    x@Data[!is.na(x)] <- value
    invisible()
  }
)


a<-read.csv(file.path("C:","MV","SMS","data_northSea","2011-data","mammals","seal_diet.csv"))
a<-subset(a,prey=='COD')

cleanup()
X11()

par(mfcol=c(2,1))
par(mar=c(4,4,3,2)) # c(bottom, left, top, right)

b<-aggregate(preyw~prey+lowpreyl,data=a,sum)
b$preyw<-b$preyw/sum(b$preyw)*100
plot(b$lowpreyl,b$preyw,type='h',xlab='length (cm)',ylab='Weight proportion (%)',lwd=3,col='blue')

b<-aggregate(nprey~prey+lowpreyl,data=a,sum)
b$nprey<-b$nprey/sum(b$nprey)*100
plot(b$lowpreyl,b$nprey,type='h',xlab='length (cm)',ylab='Number proportion (%)',lwd=3,col='blue')


#' forecast_plot.r
#' Takes a dataframe with observed data as `obs`, then predicted, 95%CI and 95%PI as columns, returns a plot that looks nice.
#'
#' @param to.plot   #dataframe with observations, mean prediction, uper and lower bounds of PI and CI for each prediction.
#' @param limy      #y limit values. Default 0,100
#' @param trans     #transparanecy of shaded region, 0-1. Default 0.3.
#' @param ylab      #y-axis label.
#'
#' @return
#' @export
#'
#' @examples
forecast_plot <- function(to.plot, limy=c(0,100),trans=0.3, ylab=NA){
  par(mai = c(0.1,0.8,0.1,0.1))
  plot(to.plot$mean, ylim = limy, cex = 0, ylab = NA, xlab = NA, xaxt='n',bty='n')
  lines(smooth.spline(to.plot$mean), lwd = 2) #plot mean line
  #plot and shade 95% credible interval.
  range <- c(1:nrow(to.plot))
  polygon(c(range, rev(range)),c(to.plot$pi_0.975, rev(to.plot$pi_0.025)), col=adjustcolor('green', trans), lty=0)
  polygon(c(range, rev(range)),c(to.plot$ci_0.975, rev(to.plot$ci_0.025)), col=adjustcolor('blue' , trans), lty=0)
  #drop observed points.
  par(new = T)
  plot(to.plot$obs, cex = 0.6, pch =16, ylim=limy,xlab=NA,ylab=NA,xaxt='n',yaxt='n', bty='n')

  #get some summary stats on here.
  lpos <- 0.06
  pi_match <- round((nrow(to.plot[to.plot$obs < to.plot$pi_0.975 & to.plot$obs > to.plot$pi_0.025,]) / nrow(to.plot))*100,1)
  rsq <- round(summary(lm(to.plot$obs ~ to.plot$mean))$r.squared,2)
  txt <- paste0(pi_match,'% of obs. in 95% predictive interval.')
  mtext(txt,adj = lpos, line = -1.8)
  txt <- bquote(R^2 == .(format(rsq, digits = 2)))
  mtext(txt,adj = lpos, line = -3.1)
  mtext(ylab, side = 2, line = 2)
}


#!/usr/bin/env Rscript

#Andrew Burt - a.burt@ucl.ac.uk

getFieldResults <- function(caldata,ffname,alpha,runs,localreg,nn=200)
{
	model <- fitNLS(caldata)
	nlqrmodels <- nlQuantileRegression(model,caldata,alpha)
	bmodels <- bootstrap(model,caldata,runs)
	results <- list()
	j <- 1
	for(i in 1:length(ffname))
	{
		###field data
		fielddata <- read.table(ffname[i],col.names=c("id","x","y","d","h","rho"))
		tmp1 <- strsplit(ffname[i],'/')
		tmp2 <- tmp1[[1]][length(tmp1[[1]])]
		tmp3 <- strsplit(tmp2,'\\.')
		pname <- tmp3[[1]][1]
		##filter
		#fielddata <- fielddata[fielddata$d >= 0.9,]
		##
		fdata <- data.frame(fielddata$d*fielddata$d*fielddata$h*fielddata$rho)
		colnames(fdata) <- c("X")
		stem_count <- nrow(fielddata)
		basal_area <- sum((fielddata$d / 2) ^ 2 * pi)
		lorey_height <- sum(((fielddata$d / 2) ^ 2 * pi) * fielddata$h ) / sum((fielddata$d / 2) ^ 2 * pi)
		wd_baw <- sum((fielddata$d / 2) ^ 2 * pi * fielddata$rho ) / sum((fielddata$d / 2) ^ 2 * pi)
		###ols
		ols_t_agb <- yhatBIOMASS(fielddata) * 1000
		ols_intervals <- uncertaintyIntervalsBIOMASS(fielddata,0.05)
		ols_t_agb_li <- ols_intervals[[1]][,1] * 1000
		ols_t_agb_ui <- ols_intervals[[1]][,2] * 1000
		ols_t_u <- 0.5 * (ols_t_agb_ui - ols_t_agb_li) / ols_t_agb
		ols_p_agb <- sum(ols_t_agb)
		ols_p_agb_li <- ols_intervals[[2]][1] * 1000
		ols_p_agb_ui <- ols_intervals[[2]][2] * 1000
		ols_p_u <- 0.5 * (ols_p_agb_ui - ols_p_agb_li) / ols_p_agb
		###nls
		nlmle_sigma_meas <- measSigma(model,fielddata)
		nlmle_t_agb <- yhat(model,fdata)
		nlmle_t_agb_ali <- getPredictionIntervals(nlqrmodels,fdata)[,1]
		nlmle_t_agb_aui <- getPredictionIntervals(nlqrmodels,fdata)[,2]
		nlmle_t_agb_mli <- nlmle_t_agb - (nlmle_sigma_meas * qnorm(alpha/2,lower.tail=FALSE))
		nlmle_t_agb_mui <- nlmle_t_agb + (nlmle_sigma_meas * qnorm(alpha/2,lower.tail=FALSE))
		nlmle_t_agb_li <- nlmle_t_agb_ali - (nlmle_sigma_meas * qnorm(alpha/2,lower.tail=FALSE))
		nlmle_t_agb_ui <- nlmle_t_agb_aui + (nlmle_sigma_meas * qnorm(alpha/2,lower.tail=FALSE))
		nlmle_t_u_a <- 0.5 * (nlmle_t_agb_aui - nlmle_t_agb_ali) / nlmle_t_agb
		nlmle_t_u_m <- 0.5 * (nlmle_t_agb_mui - nlmle_t_agb_mli) / nlmle_t_agb
		nlmle_t_u <- 0.5 * (nlmle_t_agb_ui - nlmle_t_agb_li) / nlmle_t_agb
		#
		nlmle_p_agb <- sum(nlmle_t_agb)
		nlmle_p_agb_ali <- sum(getConfidenceIntervals(bmodels,fdata,alpha)[,1])
		nlmle_p_agb_aui <- sum(getConfidenceIntervals(bmodels,fdata,alpha)[,2])
		nlmle_p_agb_mli <- nlmle_p_agb - (1/sqrt(nrow(fdata)) * sum(nlmle_sigma_meas*qnorm(alpha/2,lower.tail=FALSE)))
		nlmle_p_agb_mui <- nlmle_p_agb + (1/sqrt(nrow(fdata)) * sum(nlmle_sigma_meas*qnorm(alpha/2,lower.tail=FALSE)))
		nlmle_p_agb_li <- nlmle_p_agb_ali - (1/sqrt(nrow(fdata)) * sum(nlmle_sigma_meas*qnorm(alpha/2,lower.tail=FALSE)))
		nlmle_p_agb_ui <- nlmle_p_agb_aui + (1/sqrt(nrow(fdata)) * sum(nlmle_sigma_meas*qnorm(alpha/2,lower.tail=FALSE)))
		nlmle_p_u_a <- 0.5 * (nlmle_p_agb_aui - nlmle_p_agb_ali) / nlmle_p_agb
		nlmle_p_u_m <- 0.5 * (nlmle_p_agb_mui - nlmle_p_agb_mli) / nlmle_p_agb
		nlmle_p_u <- 0.5 * (nlmle_p_agb_ui - nlmle_p_agb_li) / nlmle_p_agb
		#
		if(localreg == FALSE)
		{
			###sort tree results
			tr <- data.frame(pname,fielddata$id,fielddata$x,fielddata$y,round(fielddata$d,3),round(fielddata$h,3),round(fielddata$rho,3),
			round(ols_t_agb,3),round(ols_t_agb_li,3),round(ols_t_agb_ui,3),round(ols_t_u,3),
			round(nlmle_t_agb,3),round(nlmle_t_agb_ali,3),round(nlmle_t_agb_aui,3),round(nlmle_t_agb_mli,3),round(nlmle_t_agb_mui,3),round(nlmle_t_agb_li,3),round(nlmle_t_agb_ui,3),round(nlmle_t_u_a,3),round(nlmle_t_u_m,3),round(nlmle_t_u,3))
			colnames(tr) <- c("pid","tid","x","y","d","h","rho",
			"ols_t_agb","ols_t_agb_li","ols_t_agb_ui","ols_t_u",
			"nlmle_t_agb","nlmle_t_agb_ali","nlmle_t_agb_aui","nlmle_t_agb_mli","nlmle_t_agb_mui","nlmle_t_agb_li","nlmle_t_agb_ui","nlmle_t_u_a","nlmle_t_u_m","nlmle_t_u")
			###sort plot results
			pr <- data.frame(pname,round(stem_count,0),round(basal_area,3),round(lorey_height,3),round(wd_baw,3),
			round(ols_p_agb,3),round(ols_p_agb_li,3),round(ols_p_agb_ui,3),round(ols_p_u,3),
			round(nlmle_p_agb,3),round(nlmle_p_agb_ali,3),round(nlmle_p_agb_aui,3),round(nlmle_p_agb_mli,3),round(nlmle_p_agb_mui,3),round(nlmle_p_agb_li,3),round(nlmle_p_agb_ui,3),round(nlmle_p_u_a,3),round(nlmle_p_u_m,3),round(nlmle_p_u,3))
			colnames(pr) <- c("pid","sc","ba","lh","wd_baw",
			"ols_p_agb","ols_p_agb_li","ols_p_agb_ui","ols_p_u",
			"nlmle_p_agb","nlmle_p_agb_ali","nlmle_p_agb_aui","nlmle_p_agb_mli","nlmle_p_agb_mui","nlmle_p_agb_li","nlmle_p_agb_ui","nlmle_p_u_a","nlmle_p_u_m","nlmle_p_u")
			###
			results[[j]] <- tr
			j <- j+1
			results[[j]] <- pr
			j <- j+1
		}
		if(localreg == TRUE)
		{
			lnlmle_t_agb <- numeric(nrow(fdata))
			lnlmle_t_agb_ali <- numeric(nrow(fdata))
			lnlmle_t_agb_aui <- numeric(nrow(fdata))
			lnlmle_t_agb_mli <- numeric(nrow(fdata))
			lnlmle_t_agb_mui <- numeric(nrow(fdata))
			lnlmle_t_agb_li <- numeric(nrow(fdata))
			lnlmle_t_agb_ui <- numeric(nrow(fdata))
			lnlmle_t_u_a <- numeric(nrow(fdata))
			lnlmle_t_u_m <- numeric(nrow(fdata))
			lnlmle_t_u <- numeric(nrow(fdata))
			lnlmle_p_agb <- 0
			lnlmle_p_agb_ali <- 0
			lnlmle_p_agb_aui <- 0
			lnlmle_p_agb_mli <- 0
			lnlmle_p_agb_mui <- 0
			lnlmle_p_agb_li <- 0
			lnlmle_p_agb_ui <- 0
			for(k in 1:nrow(fielddata))
			{
				lcaldata <- head(caldata[order(abs(caldata$X-fdata$X[k])),],nn)
				lfielddata <- data.frame(fielddata[k,])
				lfdata <- data.frame(fdata$X[k])
				colnames(lfdata) <- c("X")
				lmodel <- fitNLS(lcaldata)
				lnlqrmodels <- nlQuantileRegression(lmodel,lcaldata,alpha)
				lbmodels <- bootstrap(lmodel,lcaldata,runs)
				lnlmle_t_agb[k] <- yhat(lmodel,lfdata)
				lnlmle_t_agb_ali[k] <- getPredictionIntervals(lnlqrmodels,lfdata)[,1]
				lnlmle_t_agb_aui[k] <- getPredictionIntervals(lnlqrmodels,lfdata)[,2]
				lnlmle_t_agb_mli[k] <- lnlmle_t_agb[k] - (nlmle_sigma_meas[k] * qnorm(alpha/2,lower.tail=FALSE))
				lnlmle_t_agb_mui[k] <- lnlmle_t_agb[k] + (nlmle_sigma_meas[k] * qnorm(alpha/2,lower.tail=FALSE))
				lnlmle_t_agb_li[k] <- lnlmle_t_agb_ali[k] - (nlmle_sigma_meas[k] * qnorm(alpha/2,lower.tail=FALSE))
				lnlmle_t_agb_ui[k] <- lnlmle_t_agb_aui[k] + (nlmle_sigma_meas[k] * qnorm(alpha/2,lower.tail=FALSE))
				lnlmle_t_u_a[k] <- 0.5 * (lnlmle_t_agb_aui[k] - lnlmle_t_agb_ali[k]) / lnlmle_t_agb[k]
				lnlmle_t_u_m[k] <- 0.5 * (lnlmle_t_agb_mui[k] - lnlmle_t_agb_mli[k]) / lnlmle_t_agb[k]
				lnlmle_t_u[k] <- 0.5 * (lnlmle_t_agb_ui[k] - lnlmle_t_agb_li[k]) / lnlmle_t_agb[k]
				#
				lnlmle_p_agb <- lnlmle_p_agb + lnlmle_t_agb[k]
				lnlmle_p_agb_ali <- lnlmle_p_agb_ali + getConfidenceIntervals(lbmodels,lfdata,alpha)[,1]
				lnlmle_p_agb_aui <- lnlmle_p_agb_aui + getConfidenceIntervals(lbmodels,lfdata,alpha)[,2]
				lnlmle_p_agb_mli <- lnlmle_p_agb_mli + lnlmle_t_agb[k] - (1/sqrt(nrow(fdata)) * nlmle_sigma_meas[k] * qnorm(alpha/2,lower.tail=FALSE))
				lnlmle_p_agb_mui <- lnlmle_p_agb_mui + lnlmle_t_agb[k] + (1/sqrt(nrow(fdata)) * nlmle_sigma_meas[k] * qnorm(alpha/2,lower.tail=FALSE))
				lnlmle_p_agb_li <- lnlmle_p_agb_li + getConfidenceIntervals(lbmodels,lfdata,alpha)[,1] - (1/sqrt(nrow(fdata)) * nlmle_sigma_meas[k] * qnorm(alpha/2,lower.tail=FALSE))
				lnlmle_p_agb_ui <- lnlmle_p_agb_ui + getConfidenceIntervals(lbmodels,lfdata,alpha)[,2] + (1/sqrt(nrow(fdata)) * nlmle_sigma_meas[k] * qnorm(alpha/2,lower.tail=FALSE))
			}
			lnlmle_p_u_a <- 0.5 * (lnlmle_p_agb_aui - lnlmle_p_agb_ali) / lnlmle_p_agb
			lnlmle_p_u_m <- 0.5 * (lnlmle_p_agb_mui - lnlmle_p_agb_mli) / lnlmle_p_agb
			lnlmle_p_u <- 0.5 * (lnlmle_p_agb_ui - lnlmle_p_agb_li) / lnlmle_p_agb
			###sort tree results
			tr <- data.frame(pname,fielddata$id,fielddata$x,fielddata$y,round(fielddata$d,3),round(fielddata$h,3),round(fielddata$rho,3),
			round(ols_t_agb,3),round(ols_t_agb_li,3),round(ols_t_agb_ui,3),round(ols_t_u,3),
			round(nlmle_t_agb,3),round(nlmle_t_agb_ali,3),round(nlmle_t_agb_aui,3),round(nlmle_t_agb_mli,3),round(nlmle_t_agb_mui,3),round(nlmle_t_agb_li,3),round(nlmle_t_agb_ui,3),round(nlmle_t_u_a,3),round(nlmle_t_u_m,3),round(nlmle_t_u,3),
			round(lnlmle_t_agb,3),round(lnlmle_t_agb_ali,3),round(lnlmle_t_agb_aui,3),round(lnlmle_t_agb_mli,3),round(lnlmle_t_agb_mui,3),round(lnlmle_t_agb_li,3),round(lnlmle_t_agb_ui,3),round(lnlmle_t_u_a,3),round(lnlmle_t_u_m,3),round(lnlmle_t_u,3))
			colnames(tr) <- c("pid","tid","x","y","d","h","rho",
			"ols_t_agb","ols_t_agb_li","ols_t_agb_ui","ols_t_u",
			"nlmle_t_agb","nlmle_t_agb_ali","nlmle_t_agb_aui","nlmle_t_agb_mli","nlmle_t_agb_mui","nlmle_t_agb_li","nlmle_t_agb_ui","nlmle_t_u_a","nlmle_t_u_m","nlmle_t_u",
			"lnlmle_t_agb","lnlmle_t_agb_ali","lnlmle_t_agb_aui","lnlmle_t_agb_mli","lnlmle_t_agb_mui","lnlmle_t_agb_li","lnlmle_t_agb_ui","lnlmle_t_u_a","lnlmle_t_u_m","lnlmle_t_u")
			###sort plot results
			pr <- data.frame(pname,round(stem_count,0),round(basal_area,3),round(lorey_height,3),round(wd_baw,3),
			round(ols_p_agb,3),round(ols_p_agb_li,3),round(ols_p_agb_ui,3),round(ols_p_u,3),
			round(nlmle_p_agb,3),round(nlmle_p_agb_ali,3),round(nlmle_p_agb_aui,3),round(nlmle_p_agb_mli,3),round(nlmle_p_agb_mui,3),round(nlmle_p_agb_li,3),round(nlmle_p_agb_ui,3),round(nlmle_p_u_a,3),round(nlmle_p_u_m,3),round(nlmle_p_u,3),
			round(lnlmle_p_agb,3),round(lnlmle_p_agb_ali,3),round(lnlmle_p_agb_aui,3),round(lnlmle_p_agb_mli,3),round(lnlmle_p_agb_mui,3),round(lnlmle_p_agb_li,3),round(lnlmle_p_agb_ui,3),round(lnlmle_p_u_a,3),round(lnlmle_p_u_m,3),round(lnlmle_p_u,3))
			colnames(pr) <- c("pid","sc","ba","lh","wd_baw",
			"ols_p_agb","ols_p_agb_li","ols_p_agb_ui","ols_p_u",
			"nlmle_p_agb","nlmle_p_agb_ali","nlmle_p_agb_aui","nlmle_p_agb_mli","nlmle_p_agb_mui","nlmle_p_agb_li","nlmle_p_agb_ui","nlmle_p_u_a","nlmle_p_u_m","nlmle_p_u",
			"lnlmle_p_agb","lnlmle_p_agb_ali","lnlmle_p_agb_aui","lnlmle_p_agb_mli","lnlmle_p_agb_mui","lnlmle_p_agb_li","lnlmle_p_agb_ui","lnlmle_p_u_a","lnlmle_p_u_m","lnlmle_p_u")
			###
			results[[j]] <- tr
			j <- j+1
			results[[j]] <- pr
			j <- j+1
		}
	}
	return(results)
}

writeResults <- function(results)
{
	i <- 1
	while(i < length(results))
	{
		pname <- toString(results[[i+1]][1,"pid"])
		tfile <- paste(pname,'_tree.txt',sep='')
		pfile <- paste(pname,'_plot.txt',sep='')
		write.table(results[[i]],file=tfile,col.names=TRUE,row.names=FALSE,quote=FALSE)
		write.table(results[[i+1]],file=pfile,col.names=TRUE,row.names=FALSE,quote=FALSE)
		i <- i + 2
	}
	tsum <- data.frame()
	psum <- data.frame()
	j <- 1
	while(j < length(results))
	{
		tsum <- rbind(tsum,results[[j]])
		psum <- rbind(psum,results[[j+1]])
		j <- j + 2
	}
	write.table(tsum,file="tree_results.txt",col.names=TRUE,row.name=FALSE,quote=FALSE)
	write.table(psum,file="plot_results.txt",col.names=TRUE,row.name=FALSE,quote=FALSE)
}


library(readr)

# Read dataset as comma separated value
DataSet <- read_csv(<path>.csv")
View(DataSet)

# Sort dataset by timestamp
dsIdx<-order(DataSet$`@timestamp`)
dsSort<-DataSet[dsIdx,]

# Remove NA values manually (See "na.rm = TRUE")
dsClean<-dsSort$column[-c(1,2)]

# Select interval for a consistent dataset (if multiple data sources are used)
dsClean = dsClean[1:360]

# Calculate mean
dsMean = mean(dsClean)

# Prepare string above line
paste("Mean:",sprintf(dsMean, fmt = '%#.2f'))->MeanValueStringDS

# Plot graph
plot(dsClean, xlab="Measurement file index", ylab="Execution time (s)", main="Execution times with measurement data from <object>")
abline(h=dsMean, col="blue", lwd=2)
text(dsMean+16,dsMean,MeanValueStringDS,srt=0.2,pos=3,col = "blue")


\docType{data}
\name{mt_arabalar}
\alias{mt_arabalar}
\title{Motor Trend'in Araba Yol Testleri}
\format{32 gözlem 11 değişkenden oluşan bir data.frame
\describe{
\item{mil}{Galon başına katedilen mil}
\item{silindir}{Silindir sayısı}
\item{hacim}{Motor hacmi}
\item{beygir}{Brüt beygir gücü}
\item{aks}{Aks (diferansiyel veya son dişli) oranı}
\item{ağırlık}{Ağırlık (1000 libre)}
\item{hızlanma}{Çeyrek mil katetme süresi}
\item{tip}{Motor tipi (0 = V tipi, 1 = sıralı)}
\item{şanzıman}{Şanzıman türü (0 = otomatik, 1 = manuel)}
\item{vites}{İleri vites sayısı}
\item{karbüratör}{Karbüratör sayısı}
}}
\usage{mt_arabalar}
\description{Veriler, 1974 Motor Trend US dergisinden alınmıştır ve 32 otomobil (1973–74 modelleri) için yakıt tüketimini ve otomobil tasarımı ve performansının 10 özelliğini içermektedir.}
\seealso{\code{\link[datasets]{mtcars}}}
\keyword{datasets}


### Ensures that the internal ipv4 validipation method operates correctly. Does
### not query any device or internet service (as getip() does).

library(getip)

# should be true
test = "127.0.0.1"
stopifnot(validip(test))

test = "8.8.8.8"
stopifnot(validip(test))

test = "255.255.255.255"
stopifnot(validip(test))

# should be false
test = "11127.0.0.1"
stopifnot(!validip(test))

test = "8.8.8.8.8"
stopifnot(!validip(test))

test = "-127.0.0.1"
stopifnot(!validip(test))

test = "127.1"
stopifnot(!validip(test))

test = "256.255.255.255"
stopifnot(!validip(test))

test = "255.256.255.255"
stopifnot(!validip(test))

test = "255.255.256.255"
stopifnot(!validip(test))

test = "255.255.255.256"
stopifnot(!validip(test))

test = "255.255.255.255, 127.0.0.1"
stopifnot(!validip(test))

test = 127.001
stopifnot(!validip(test))

test = NA
stopifnot(!validip(test))

# vector test
test = c("255.255.255.255", "127.0.0.1")
truth = c(TRUE, TRUE)
stopifnot(identical(validip(test), truth))

test = c("127.0.0.1", NA)
truth = c(TRUE, FALSE)
stopifnot(identical(validip(test), truth))


g1 <- apply(AudiByMarkets,1,function(y) y[1])
g1 <- g1[!is.na(g1)]
pdf("slike/Audi_trgi.pdf")
barplot(as.matrix(AudiByMarkets[-15,])/1000, beside = TRUE,
        las=2, names.arg=1996:2006,
        col=rainbow(14), cex.names=0.6, ylim = c(0, 400))
legend("topleft", legend = row.names(AudiByMarkets)[1:14], cex=0.6,
       fill=rainbow(14))
dev.off()

# GRAFI ZAPOSLENIH V POSAMEZNIH LETIH
# f1 <- apply(AudiEmployees,1,function(x) x[1])
# pdf("slike/Audi_zaposleni_2000.pdf")
# vrstice <- rownames(AudiEmployees)
# vrstice[2] <- "Audi AG\nincl. Others"
# vrstice[7] <- "Cosworth\nTechnology"
# barplot(f1/1000,main='Zaposleni v Audi tovarnah 2000',
#         ylab='Število zaposlenih (×1000)', col=c("pink"),
#         names.arg = vrstice, las=2,cex.names=0.6)
# dev.off()
#
# f2 <- apply(AudiEmployees,1,function(x) x[3])
# pdf("slike/Audi_zaposleni_2002.pdf")
# barplot(f2/1000,main='Zaposleni v Audi tovarnah 2002',
#         ylab='Število zaposlenih (×1000)',
#         col=c("blue"),las=2,cex.names=0.6)
# dev.off()
#
# f3 <- apply(AudiEmployees,1,function(x) x[4])
# pdf("slike/Audi_zaposleni_2003.pdf")
# barplot(f3/1000,main='Zaposleni v Audi tovarnah 2003',
#         ylab='Število zaposlenih (×1000)',
#         col=c("yellow"),las=2,cex.names=0.6)
# dev.off()
#
# f4 <- apply(AudiEmployees,1,function(x) x[5])
# pdf("slike/Audi_zaposleni_2004.pdf")
# barplot(f4/1000,main='Zaposleni v Audi tovarnah 2004',
#         ylab='Število zaposlenih (×1000)',
#         col=c("green"),las=2,cex.names=0.6)
# dev.off()

pdf("slike/Audi_modeli.pdf")
vrstice <- grep("Total|Threreof", rownames(AudiProduction),
                ignore.case=TRUE, invert=TRUE)
izbor <- AudiProduction[vrstice,]
modeli <- c('A3','A4','A5','A6','A8','TT','Lamborghini')
vsote <- sapply(modeli,
                function(x) sum(izbor[grep(x, rownames(izbor)),11], na.rm = TRUE))
pie(vsote)
dev.off()

f1 <- apply(AudiEmployees,1,function(x) x[1])
pdf("slike/Audi_zaposleni.pdf")

g_range <- range(0)
izbrani <- c(2:8)
barve <- c("blue", "red", 116, "brown", "black", "purple", "orange")
for (i in izbrani ) {
  row <- as.numeric(as.vector(AudiEmployees[i,]))
  row[is.na(row)] = 0
  row <- row / 1000
  g_range <- range(g_range, row)
}

row <- as.numeric(as.vector(AudiEmployees[izbrani[1],]))
row[is.na(row)] = 0
row <- row / 1000
plot(row, type="o", col=barve[1], ylim=g_range,
     axes=FALSE, ann=FALSE)
for (k in 2:length(izbrani) ) {
  i <- izbrani[k]
  row <- as.numeric(as.vector(AudiEmployees[i,]))
  row[is.na(row)] = 0
  row <- row / 1000
  # Graph trucks with red dashed line and square points
  lines(row, type="o", col=barve[k])
}

# Make x axis using Mon-Fri labels
axis(1, at=1:6, lab=names(AudiEmployees))

# Make y axis with horizontal labels that display ticks at
# every 4 marks. 4*0:g_range[2] is equivalent to c(0,4,8,12).
axis(2, las=1, at=ceiling(seq(g_range[1], g_range[2],length=8)))

# Create box around plot
box()

# Create a title with a red, bold/italic font
title(main="Audi tovarne", col.main="black", font.main=4)

# Label the x and y axes with dark green text
title(xlab="Leta")
title(ylab="Število zaposlenih")

# Create a legend at (1, g_range[2]) that is slightly smaller
# (cex) and uses the same line colors and points used by
# the actual plots
legend(1, 29 , row.names(AudiEmployees)[izbrani], cex=0.5,
       col=barve, lty=1:1);
dev.off()


# Creating Spark Session with hive Support
sparkR.session(enableHiveSupport=TRUE)

# Creating a table to hold CDRs
sql("CREATE TABLE IF NOT EXISTS cdrs(callingNumber STRING, calledNumber String, origin String, Dest String,CallDtTm String, callCharge Int) ROW FORMAT DELIMITED FIELDS TERMINATED BY ','")

# Loading data
sql("LOAD DATA LOCAL INPATH '/home/spark/sampledata/cdrs.csv' INTO table cdrs")

# Finding top paired origin/destinations
sql(" SELECT origin, dest, count(*) as cnt from cdrs group by origin, dest order by cnt desc LIMIT 5")


# To add a new cell, type '# %%'
# To add a new markdown cell, type '# %% [markdown]'
# %% [markdown]
# # Network-based *in silico* drug efficacy screening
#
# This notebook reproduces the proximity-based analysis in the the manuscript. Known drug-disease associations, proximity and relative efficacy values are given in Supplementary Data 1 (the information is combined in "proximity.dat").

# %%
# Read the data file containing information on analyzed drug-disease pairs
# flag: True (known) | CT (unknown & in trials) | False (unknown & not in trials)
# d: average shortest path length from drug targets to closest disease gene
# z: proximity value
# re: relative efficacy value
setwd('/scratch/hdd001/home/haotian/Covid19Datasets/resources/proximity')
file.name = "proximity.dat"
d = read.table(file.name, header=T)
draw.plots = T #F

# %% [markdown]
# ## Area under ROC Curve
# %% [markdown]
# ***AUC using proximity***

# %%
#require(pROC)
f = data.frame(V1=-d$z, V2=ifelse(d$flag=="True", 1, 0))
#auc = auc(f$V2, f$V1)
#print(sprintf("AUC: %.3f", auc))
require(ROCR)
pred = prediction(f$V1, f$V2)
perf = performance(pred, "auc")
print(sprintf("AUC: %.3f", perf@y.values[[1]]))
# Draw the ROC curve (not in the main text)
if(draw.plots) {
   perf = performance(pred, "tpr", "fpr")
   plot(perf)
}

# %% [markdown]
# ***AUC using proximity based similarity***

# %%
file.name = "proximity_similarity.dat"
e = read.table(file.name, header=T)
f = data.frame(V1=e$s, V2=ifelse(e$flag=="True", 1, 0))
#auc = auc(f$V2, f$V1)
#print(sprintf("AUC: %.3f", auc))
pred = prediction(f$V1, f$V2)
perf = performance(pred, "auc")
print(sprintf("AUC: %.3f", perf@y.values[[1]]))
# Draw the ROC curve (not in the main text)
if(draw.plots) {
   perf = performance(pred, "tpr", "fpr")
   plot(perf)
}

# %% [markdown]
# ## Drug target degree vs shortest path and proximity
# ***Correlation between min shortest path length and drug target degree***

# %%
e = d[d$flag == "True",]
selected = "d"
variable = "d.target"
a = cor.test(e[,variable], e[,selected], method="spearman")
print(sprintf("%s vs %s: %.3f %e", selected, variable, a$estimate, a$p.value))

# %% [markdown]
# ***Correlation between proximity and drug target degree***

# %%
e = d[d$flag == "True",]
selected = "z"
variable = "d.target"
a = cor.test(e[,variable], e[,selected], method="spearman")
print(sprintf("%s vs %s: %.3f %e", selected, variable, a$estimate, a$p.value))

# %% [markdown]
# ## Proximity cutoff

# %%
require(ROCR)
f = data.frame(V1=-d$z, V2=ifelse(d$flag=="True", 1, 0))
pred = prediction(f$V1, f$V2)
perf = performance(pred, "sens")
x = -perf@x.values[[1]]
a = perf@y.values[[1]]
# Draw sensitivity - specificity curve
if(draw.plots) {
    plot(x, a, col="blue", type="l", bty="n", lwd=3, xlab="Proximity (z)", ylab="Performance (%)", yaxt='n', cex.lab=1.5, cex.axis=1.5)
    axis(2, labels=F)
    text(par("usr")[1]-0.1, y = seq(0, 1, by=0.2), labels = seq(0, 1, by=0.2), pos=2, cex=1.5, xpd=T)
    perf = performance(pred, "spec")
    b = perf@y.values[[1]]
    lines(x, b, col="green", lwd=3)
    legend("left", legend=c("Sensitivity", "Specificity"), col=c("blue", "green"), lty=c(1,1), lwd=c(3,3), bty="n", cex=1.5)
}
i = which.max(abs(a - b) <= 0.01)
print(sprintf("Cutoff: %.4f", x[i]))
print(sprintf("Sens: %.4f Spec: %.4f", a[i], b[i]))

# Set z cutoff for further analysis
Z.CUTOFF = -0.15
cutoff = Z.CUTOFF

# %% [markdown]
# ## Enrichment of known and clinical trial drug-disease pairs

# %%
e = d
# Draw the bar plots
if(draw.plots) {
    require(ggplot2)
    # Enrichment plot
    e$close = ifelse(e$z<=cutoff, "Proximal", "Distant")
    e$close = factor(e$close, c("Proximal", "Distant"))
    e$known = ifelse(e$flag == "True", "Known", ifelse(e$flag=="CT", "In trials", "Not in trials"))
    e$known = factor(e$known, c("Known", "In trials", "Not in trials"))
    e$ct = ifelse(e$flag == "CT", "in CT", "not in CT")
    p = ggplot(data=e, aes(known)) + geom_bar(aes(fill=close), position="dodge", alpha=0.8) + labs(x="", y="Number of drug-disease pairs") + guides(fill=guide_legend("")) + scale_fill_manual(values=c("blue", "green", "orange"))
    print(p)
}

# %% [markdown]
# ***Known vs Unknown (in trails and not in trials)***

# %%
# Enrichment of known among proximal and distant at proximity cutoff
method = "z"
cutoff = Z.CUTOFF
x=e[e$flag=="True", ]
y=e[e$flag!="True", ]
a = sum(x[[method]]<=cutoff, na.rm=T)
b = sum(y[[method]]<=cutoff, na.rm=T)
contigency = matrix(c(a, nrow(x)-a, b, nrow(y)-b), 2, 2)
s = fisher.test(contigency)
print(sprintf("z <= %.2f: OR = %.3f P = %s", cutoff, s$estimate, s$p.value))
print(contigency)
print(sum(contigency))

# %% [markdown]
# ***In trials vs not in trials***

# %%
# CT enrichment
method = "z"
cutoff = Z.CUTOFF
x=e[e$flag=="CT", ]
y=e[e$flag=="False", ]
a = sum(x[[method]]<=cutoff, na.rm=T)
b = sum(y[[method]]<=cutoff, na.rm=T)
contigency = matrix(c(a, nrow(x)-a, b, nrow(y)-b), 2, 2)
s = fisher.test(contigency)
print(sprintf("CT vs Uknown z <= %.2f: OR = %.3f P = %s", cutoff, s$estimate, s$p.value))
print(contigency)
print(sum(contigency))

# %% [markdown]
# ***Known vs Unknown of significantly proximal***

# %%
# Enrichment of significantly proximal
method = "z"
cutoff = -2
x=e[e$flag=="True", ]
y=e[e$flag!="True", ]
a = sum(x[[method]]<=cutoff, na.rm=T)
b = sum(y[[method]]<=cutoff, na.rm=T)
contigency = matrix(c(a, nrow(x)-a, b, nrow(y)-b), 2, 2)
s = fisher.test(contigency)
print(sprintf("z <= %.2f: OR = %.3f P = %s", cutoff, s$estimate, s$p.value))
print(contigency)
print(sum(contigency))

# %% [markdown]
# ***Pairs in which drug targets are disease genes***

# %%
# Enirchment of pairs in which the drug targets are disease genes
method = "d"
cutoff = 0
a = sum(x[[method]]<=cutoff, na.rm=T) # n.overlap
b = sum(y[[method]]<=cutoff, na.rm=T)
contigency = matrix(c(a, nrow(x)-a, b, nrow(y)-b), 2, 2)
s = fisher.test(contigency)
print(sprintf("n.overlap >= %.2f: OR = %.3f P = %s", cutoff, s$estimate, s$p.value))
print(contigency)
print(sum(contigency))

# %% [markdown]
# ***Pairs with at least one overlapping drug target and disease gene***

# %%
# Enirchment of pairs with at least one overlapping drug target and disease gene
method = "n.overlap"
cutoff = 0
a = sum(x[[method]]>cutoff, na.rm=T) # n.overlap
b = sum(y[[method]]>cutoff, na.rm=T)
contigency = matrix(c(a, nrow(x)-a, b, nrow(y)-b), 2, 2)
s = fisher.test(contigency)
print(sprintf("n.overlap >= %.2f: OR = %.3f P = %s", cutoff, s$estimate, s$p.value))
print(contigency)
print(sum(contigency))

# %% [markdown]
# ## Proximity and drug efficacy

# %%
method = "z"
cutoff = Z.CUTOFF

# Read drug label / palliativeness info
g = read.table("palliative.csv", header=T)
g = g[-(g$label==-1),]

e = d[d$flag=="True",]
e$re = 100*e$re
e = e[order(e$disease, e$group.name),]
e$close = ifelse(e$z<=cutoff, "Proximal", "Distant")
e$palliative = ifelse(g$palliative>0.5, "Palliative", "Non-palliative")
e$label = ifelse(g$label==1, "Label", "Off-label")
e$type = ifelse(e$label=="Label", ifelse(e$palliative=="Palliative", "Palliative", "Non-palliative"), "Off-label")

# %% [markdown]
# *** Relative efficacy (RE) of palliative pairs vs non-palliative and off-label***

# %%
# RE among palliative vs non-palliaitve and off-label
x = e[e$type=="Non-palliative",]
y = e[e$type=="Palliative",]
a = wilcox.test(x$re, y$re, alternative="greater")
print(sprintf("RE non-palliative ~ palliative: %.3f %.3f %s", median(x$re, na.rm=T), median(y$re, na.rm=T), a$p.value))
x = e[e$type=="Off-label",]
a = wilcox.test(x$re, y$re, alternative="greater")
print(sprintf("RE off-label ~ palliative: %.3f %.3f %s", median(x$re, na.rm=T), median(y$re, na.rm=T), a$p.value))

f = e
f$type = factor(f$type, levels=rev(c("Palliative", "Non-palliative", "Off-label")))
if(draw.plots) {
    # Type vs RE
    #p = draw.violinplot(f, "type", "re", "", "Relative Efficacy (%)")
    variable = "type"
    value = "re"
    y.lab = "Relative Efficacy (%)"
    p = ggplot(data=f, aes_string(x=variable, y=value)) + geom_violin(alpha=0.5, color="gray")
    p = p + geom_jitter(alpha=0.5, aes_string(color=variable), position = position_jitter(width = 0.1))
    p = p + stat_summary(fun.y="median", geom='point', color='black', size=10, alpha=0.5) + coord_flip()
    p = p + scale_color_manual(values=c("blue", "green", "orange"))
    p = p + labs(y = y.lab, x="") + guides(color=F)
    print(p)
}

# %% [markdown]
# *** Proximity of palliative pairs vs non-palliative and off-label***

# %%
# Proximity and RE among palliative vs non-palliaitve and off-label
y = e[e$type=="Palliative",]
x = e[e$type=="Non-palliative",]
a = wilcox.test(x$z, y$z, alternative="less")
print(sprintf("z non-palliative ~ palliative: %.3f %.3f %s", median(x$z, na.rm=T), median(y$z, na.rm=T), a$p.value))
x = e[e$type=="Off-label",]
a = wilcox.test(x$z, y$z, alternative="less")
print(sprintf("z off-label ~ palliative: %.3f %.3f %s", median(x$z, na.rm=T), median(y$z, na.rm=T), a$p.value))

if(draw.plots) {
    # Type vs z
    #p = draw.violinplot(f, "type", "z", "", "Proximity (z)") in R_utilities at toolbox
    variable = "type"
    value = "z"
    y.lab = "Proximity (z)"
    p = ggplot(data=f, aes_string(x=variable, y=value)) + geom_violin(alpha=0.5, color="gray")
    p = p + geom_jitter(alpha=0.5, aes_string(color=variable), position = position_jitter(width = 0.1))
    p = p + stat_summary(fun.y="median", geom='point', color='black', size=10, alpha=0.5) + coord_flip()
    p = p + scale_color_manual(values=c("blue", "green", "orange"))
    p = p + labs(y = y.lab, x="") + guides(color=F)
    print(p)
}

# %% [markdown]
# *** RE of proximal vs distant pairs***

# %%
# RE among proximal vs distant
x = e[e$close=="Proximal",]
y = e[e$close=="Distant",]
a = wilcox.test(x$re, y$re, alternative="greater")
print(sprintf("RE proximal ~ distant: %.3f %.3f %s", median(x$re, na.rm=T), median(y$re, na.rm=T), a$p.value))

if(draw.plots) {
    # z vs RE
    e$close = factor(e$close, c("Proximal", "Distant"))
    #p = draw.violinplot(e, "close", "re", "", "Relative Efficacy (%)")
    variable = "close"
    value = "re"
    y.lab = "Relative Efficacy (%)"
    p = ggplot(data=e, aes_string(x=variable, y=value)) + geom_violin(alpha=0.5, color="gray")
    p = p + geom_jitter(alpha=0.5, aes_string(color=variable), position = position_jitter(width = 0.1))
    p = p + stat_summary(fun.y="median", geom='point', color='black', size=10, alpha=0.5) + coord_flip()
    p = p + scale_color_manual(values=c("blue", "green", "orange"))
    p = p + labs(y = y.lab, x="") + guides(color=F)
    print(p)
}

# %% [markdown]
# ***Proximal drugs per disease***

# %%
method = "z"
cutoff = Z.CUTOFF
n.drug.cutoff = 5

e = d[d$flag=="True",]
a = split(e$group, e$disease)
y = sapply(a, length)
f = e[e[[method]]<=cutoff,]
b = split(f$group, f$disease)
x = sapply(b, length)
f = data.frame(disease=names(y), n.known=y, n.close=x, ratio=x/y)

f = f[f$n.known >= n.drug.cutoff,]
n.max = ceiling(max(f$n.known) / 10) * 10
f = f[rev(order(f$ratio, f$n.close, f$n.known)),]

if(draw.plots) {
    #par(mar=c(12, 4, 4, 5) + 0.1)
    a<-barplot(rbind(f$n.close, f$n.known-f$n.close), beside=F, ylab="Number of drugs", xaxt="n", width=1, ylim=c(0,n.max), col=c("blue", "green"))
    x.labels = lapply(f$disease, function(x){ return(gsub("[.]", " ", x)) })

    text(a,  par("usr")[3], labels=x.labels, adj=c(1, 1), srt=45, cex=0.6, xpd=T)
    par(new=T)

    plot(a, 100*f$n.close/f$n.known, col=2, xaxt="n", yaxt="n", xlab="", ylab="", type='b', pch=20, bty="n", lty=2, lwd=2, ylim=c(0,100))
    axis(4, xpd=T, col=2, col.axis=2)
    mtext("Ratio (%)", side=4, line=3, col=2)
    legend("topright", c("Proximal", "Distant", "Ratio"), pch=c(15, 15, 19), pt.cex=2, col=c(c("blue", "green"), 2), lty=c(0,0,1), bty="n")
}

# %% [markdown]
# ***Relative efficacy per disease***

# %%
# Efficacy per disease violin plots
e = d[d$flag=="True",]
e$re = 100*e$re
a = split(e$group, e$disease)
y = sapply(a, length)
f = e[e$z<=cutoff,]
b = split(f$group, f$disease)
x = sapply(b, length)

idx = names(y[y>=n.drug.cutoff])
y = y[idx]
x = x[idx]

idx = rev(order(x/y, x, y))
e$disease = factor(e$disease, levels = factor(names(y[idx])))

if(draw.plots) {
    require(beanplot)
    #par(mar=c(12, 4, 4, 5) + 0.1)
    a = beanplot(re~disease, data=e, col=c("blue", "green"), ylim=c(0,100), ylab="Relative Efficacy (%)", las=2, ll=0.1, cex.axis=0.8, xaxt="n", bw='nrd0')
    x.labels = lapply(names(y[idx]), function(x){ return(gsub("[.]", " ", x)) })
    text(1:length(a$stats), par("usr")[3], labels=x.labels, adj=c(1, 1), srt=45, cex=0.6, xpd=T)
}


library(ggplot2)
library(ggmap)

station <- read.csv('station.csv', header = TRUE)
top5_am <- read.csv('top5_am.csv', header=TRUE)
top5_fm <- read.csv('top5_fm.csv', header=TRUE)

top5_am

top5_fm

station

top_station_am <- merge(top5_am, station, by.x = 'rent_station', by.y = 'no')
top_station_am

map <- ggmap(get_googlemap(center = as.numeric(geocode('Daejeon')), maptype = 'roadmap', zoom = 13))
map + geom_point(data = top_station_am, aes(x = lat, y = lon), colour = 'red', size = top_station_am $ count * 0.01, alpha = 0.5)

top_station_fm <- merge(top5_fm, station, by.x = 'rent_station', by.y = 'no')
top_station_fm

map <- ggmap(get_googlemap(center = as.numeric(geocode('Daejeon')), maptype = 'roadmap', zoom = 13))
map + geom_point(data = top_station_fm, aes(x = lat, y = lon), colour = 'red', size = top_station_fm $ count * 0.006, alpha = 0.5)


#' Fortify methods for objects produced by \pkg{multcomp}
#'
#' @param model an object of class `glht`, `confint.glht`,
#'  `summary.glht` or [multcomp::cld()]
#' @param data,... other arguments to the generic ignored in this method.
#' @name fortify-multcomp
#' @keywords internal
#' @examples
#' if (require("multcomp")) {
#' amod <- aov(breaks ~ wool + tension, data = warpbreaks)
#' wht <- glht(amod, linfct = mcp(tension = "Tukey"))
#'
#' fortify(wht)
#' ggplot(wht, aes(lhs, estimate)) + geom_point()
#'
#' CI <- confint(wht)
#' fortify(CI)
#' ggplot(CI, aes(lhs, estimate, ymin = lwr, ymax = upr)) +
#'    geom_pointrange()
#'
#' fortify(summary(wht))
#' ggplot(mapping = aes(lhs, estimate)) +
#'    geom_linerange(aes(ymin = lwr, ymax = upr), data = CI) +
#'    geom_point(aes(size = p), data = summary(wht)) +
#'    scale_size(trans = "reverse")
#'
#' cld <- cld(wht)
#' fortify(cld)
#' }
NULL

#' @method fortify glht
#' @rdname fortify-multcomp
#' @export
fortify.glht <- function(model, data, ...) {
  unrowname(base::data.frame(
    lhs = rownames(model$linfct),
    rhs = model$rhs,
    estimate = stats::coef(model),
    check.names = FALSE,
    stringsAsFactors = FALSE))
}

#' @rdname fortify-multcomp
#' @method fortify confint.glht
#' @export
fortify.confint.glht <- function(model, data, ...) {
  coef <- model$confint
  colnames(coef) <- to_lower_ascii(colnames(coef))

  unrowname(base::data.frame(
    lhs = rownames(coef),
    rhs = model$rhs,
    coef,
    check.names = FALSE,
    stringsAsFactors = FALSE))
}

#' @method fortify summary.glht
#' @rdname fortify-multcomp
#' @export
fortify.summary.glht <- function(model, data, ...) {
  coef <- as.data.frame(
    model$test[c("coefficients", "sigma", "tstat", "pvalues")])
  names(coef) <- c("estimate", "se", "t", "p")

  unrowname(base::data.frame(
    lhs = rownames(coef),
    rhs = model$rhs,
    coef,
    check.names = FALSE,
    stringsAsFactors = FALSE))
}

#' @method fortify cld
#' @rdname fortify-multcomp
#' @export
fortify.cld <- function(model, data, ...) {
  unrowname(base::data.frame(
    lhs = names(model$mcletters$Letters),
    letters = model$mcletters$Letters,
    check.names = FALSE,
    stringsAsFactors = FALSE))
}


#source("findRoot.r")
#source("AttDicriminant.r")
#' @export
NiarTreeAttDisc <- function(data){
  GeneralList <- list()
  AttDisc <- 0
  if(nrow(data) == 1)
    return()#list(left = NULL, right = NULL, caso = NULL, AttDiscriminant = NULL))
  else{
    if(nrow(data) > 1){
      tdata <- data[,1:ncol(data)-1]
      #AttDisc <- AttDicriminant(tdata)
      AttDisc <- sample(37:42, 1)
      break_at <- findRoot(data,AttDisc)
      dataord<- order(data[,AttDisc])
      data <- data[dataord,]
      if(break_at > 1)
      {
        dataizq = data[1:break_at-1,]
        datader = data[-seq(break_at),]
        breakcase = data[break_at,]
      }
      else{
        dataizq = data[1:break_at,]
        datader = data[-seq(break_at),]
        breakcase = data[break_at,]
      }
      #GeneralList <- list(list(left = dataizq, SonL = list(), right = datader, SonR = list(), caso = breakcase, AttDiscriminant = AttDisc))
      #GeneralList <- list(list(left = dataizq, right = datader, caso = breakcase, AttDiscriminant = AttDisc))
      GeneralList <- list(list(totalleft = nrow(dataizq), totalright = nrow(datader),root = breakcase, AttDiscriminant = AttDisc))
      GeneralList$SonL <- append(GeneralList$SonL,NiarTreeAttDisc(dataizq))
      GeneralList$SonR <- append(GeneralList$SonR,NiarTreeAttDisc(datader))
    }
  }
  return(GeneralList)
}


###Ranking hospitals by outcome in a state

rankhospital <- function(state, outcome, rank = "best"){
    ## Read outcome data
    outcomedata <- read.csv("outcome-of-care-measures.csv", colClasses = "character")
    outcomedataframe   <- as.data.frame(cbind(outcomedata[, 2],  # col 2 for hospital
                                outcomedata[, 7],  # col 7 for state
                               outcomedata[, 11],  # col 11 for heart attack
                               outcomedata[, 17],  # col 17 for heart failure
                               outcomedata[, 23]), # col 23 for pneumonia
                               stringsAsFactors = FALSE)
    colnames(outcomedataframe) <- c("hospital", "state", "heart attack", "heart failure", "pneumonia")

    ## Check that state and outcome are valid
    if (!state %in% outcomedataframe[, "state"]) {
        stop('invalid state')
    } else if (!outcome %in% c("heart attack", "heart failure", "pneumonia")){
        stop('invalid outcome')
    } else if (is.numeric(rank)) {
        s <- which(outcomedataframe[, "state"] == state)
        t <- outcomedataframe[s, ]                     # extracting dataframe for the called state
        t[, eval(outcome)] <- as.numeric(t[, eval(outcome)])
        t <- t[order(t[, eval(outcome)], t[, "hospital"]), ]
        output <- t[, "hospital"][rank]
    } else if (!is.numeric(rank)){
        if (rank == "best") {
             output <- best(state, outcome)
        } else if (rank == "worst") {
                s <- which(outcomedataframe[, "state"] == state)
                t <- outcomedataframe[s, ]
                t[, eval(outcome)] <- as.numeric(t[, eval(outcome)])
                t <- t[order(t[, eval(outcome)], t[, "hospital"], decreasing = TRUE), ]
                output <- t[, "hospital"][1]
        } else {
            stop('invalid rank')
        }
    }
return(output)
}


# NOT RUN; these tests are way too slow. But results are identical to earlier methods, so good to go

# library(data.table)
# library(raster)
# library(sp)
# library(rgrass7)

# gisBase <- "/Applications/GRASS-7.4.1.app/Contents/Resources/"
# ltDat <- readRDS(system.file("testdata/light/lightTestData.rds", package="NSmetabolism"))
# ltPts <- data.frame(site = c("2", "69"), x = c(379210.2, 416118.6), y = c(4490865.8, 4462171.8))
# coordinates(ltPts) <- c(2,3)
# dem <- raster(system.file("testdata/light/FilledDEM.tif", package="NSmetabolism"))

# ltMod <- irradiance(dem, ltPts, unique(ltDat$datetime), newSession = TRUE, timezone = 2)
# # test <- irradiance(dem, ltPts, unique(ltDat$datetime), use_existing = TRUE, timezone = 2)
# rownames(ltMod) <- c("2", "69")
# ltDat$type <- "orig"
# ltMod <- melt(ltMod)
# ltMod$type <- "model"
# ltMod[,2] <- as_datetime(ltMod[,2])
# colnames(ltMod) <- colnames(ltDat)
# tz(ltMod$datetime) <- tz(ltDat$datetime)

# ltFinal <- rbind(ltDat, ltMod)
# ltFinal$type <- factor(ltFinal$type)
# ltFinal[type == 'model', datetime := datetime + hours(1)]
# ggplot(ltFinal, aes(x = datetime, y = light, color = type)) + geom_line() + facet_grid(site ~ .)


#' Making label for Visualization
#'
#' @param label character. Specify label format.
#' @param mean numeric. Specify outcome average.
#' @param se numeric. Specify standard error of outcome average.
#' @param effect numeric. Specify treatment effect.
#' @param p numeric. Specify p-value of treatment effect.
#' @param digits numeric. Specify how many decimal places to display.
#' Default is 3.
#'
#'
ttest_label_maker <- function(label, mean, se, effect, p, digits = 3) {
  decompose <- strsplit(label, "\\{\\{|\\}\\}")[[1]]
  textpart <- decompose[grep("[^'']", decompose)]
  numeric_format <- paste0("%1.", digits, "f")

  textpart[grep("mean", textpart)] <- sprintf(numeric_format, mean)
  textpart[grep("se", textpart)] <- sprintf(numeric_format, se)
  textpart[grep("effect", textpart)] <- sprintf(numeric_format, effect)
  textpart[grep("p.value", textpart)] <- sprintf(numeric_format, p)
  textpart[grep("star", textpart)] <- dplyr::case_when(
    p < .01 ~ "***",
    p < .05 ~ "**",
    p < .1 ~ "*",
    TRUE ~ ""
  )

  paste0(textpart, collapse = "")
}