# 4. faza: Analiza podatkov

#tabela za grupiranje
podatki <- right_join(stevilo_novonastalih_podjetij, stevilo_hitrorastocih_podjetij %>% filter(leto == 2014))

podatki1 <- right_join(podatki, stevilo_podjetij_ki_so_prenehala_z_delovanjem %>% filter(leto == 2014))
podatki1$leto <- NULL
row.names(podatki1) <- podatki1$regije
podatki1$regije <- NULL
podatki.norm <- podatki1 %>% scale()

# graf za grupiranje v shiny

graf.zemljevid <- function(st){
  k <- kmeans(podatki.norm, st, nstart=1000)
  skupine <- data.frame(regije=row.names(podatki.norm), skupine=factor(k$cluster))
  ggplot(right_join(zemljevid,skupine, by=c("NAME_1"="regije"))) + geom_polygon() +
    aes(x=long, y=lat, group=group, fill=skupine) + xlab("") + ylab("") + theme_minimal()

}


# ==== Libraries import ====
library(ggplot2)
library(class)
library(caret)
library(e1071)
library(randomForest)
library(factoextra)

# ==== Test and Train ====
buildTestAndTrain <- function(dataframe, seed_value, percent) {

  # Getting dataframe class
  classes <- as.factor(dataframe[, ncol(dataframe)])

  # Selecting data for test and training
  set.seed(seed_value)

  sample_size <- floor(percent * nrow(dataframe))
  train_index <-
    sample(seq_len(nrow(dataframe)), size = sample_size)

  # Preparing test object and training
  train_without_column <- dataframe[train_index,-ncol(dataframe)]
  train <- dataframe[train_index, ]
  test <- dataframe[-train_index,-ncol(dataframe)]

  # Selecting the test class column and train class column
  trainClass <- classes[train_index]
  testClass <- classes[-train_index]

  return (
    list(
      "train_without_column" = train_without_column,
      "train" = train,
      "test" = test,
      "trainClass" = trainClass,
      "testClass" = testClass
    )
  )
}

# ==== KNN classification ====
knnClassification <- function(train, test, testClass, trainClass, k) {

    # KNN predict
    knn_res <- knn(train, test, trainClass, k)

    # Accuracy of KNN
    cf_knn <- confusionMatrix(knn_res, testClass)

    # Plot expected
    plot(testClass, main = "Expected plot")

    # Plot predict
    plot(knn_res, main = "Predict knn plot")

    return(cf_knn$overall)

}

# ==== SVM classification ====
svmClassification <- function(train, test, testClass) {

  # Build model
  svm_classifier <- svm(
    formula = Class ~ .,
    data = train,
    type = 'C-classification',
    kernel = 'linear'
  )

  # SVM predict
  svm_res <- predict(svm_classifier, newdata = test)

  # Accuracy of SVM
  cf_svm <- confusionMatrix(svm_res, testClass)

  # Plot expected
  plot(testClass, main = "Expected plot")

  # Plot predict
  plot(svm_res, main = "Predict svm plot")

  return(cf_svm$overall)

}

# ==== RF classification ====
rfClassification <- function(train, test, testClass) {

  # Build model
  rf_classifier <- randomForest(
    formula = Class ~ .,
    data = train,
    ntree = 500,
    importance = TRUE
  )

  # RF predict
  rf_res = predict(rf_classifier, newdata = test)

  # Accuracy of RF
  cf_rf <- confusionMatrix(as.factor(rf_res), testClass)

  # Plot expected
  plot(testClass, main = "Expected plot")

  # Plot predict
  plot(rf_res, main = "Predict rf plot")

  return(cf_rf$overall)

}

# ==== Build dataset ====
heartDiseaseDataframe <-
  read.csv( "./dataset/processed.cleveland.data", fileEncoding = "UTF-8", sep = ",", header = FALSE )

# Setting the name of the columns
colnames(heartDiseaseDataframe) <- c( "Age", "Sex", "ChestPainType", "RestBloodPressure", "SerumCholestoral",
                                      "FastingBloodSugar", "ResElectrocardiographic", "MaxHeartRate",
                                      "ExerciseInduced", "Oldpeak", "Slope", "MajorVessels", "Thal", "Class" )

# ==== Dataset preview ====

  # Header of dataset
  head(heartDiseaseDataframe)

  # Dataset structure
  str(heartDiseaseDataframe)

# ==== PLOTS ====

  # General plot
  plot(heartDiseaseDataframe, col = heartDiseaseDataframe$Class)

  # Relationship between specific columns plot

    # Age x RestBloodPressure
    plot(
      heartDiseaseDataframe$Age,
      heartDiseaseDataframe$RestBloodPressure,
      col = heartDiseaseDataframe$Class,
      main = "Relationship between Age and RestBloodPressure",
      ylab = "RestBloodPressure",
      xlab = "Age"
    )

    # Age x SerumCholestoral
    plot(
      heartDiseaseDataframe$Age,
      heartDiseaseDataframe$SerumCholestoral,
      col = heartDiseaseDataframe$Class,
      main = "Relationship between Age and SerumCholestoral",
      ylab = "SerumCholestoral",
      xlab = "Age"
    )

    # Age x MaxHeartRate
    plot(
      heartDiseaseDataframe$Age,
      heartDiseaseDataframe$MaxHeartRate,
      col = heartDiseaseDataframe$Class,
      main = "Relationship between Age and MaxHeartRate",
      ylab = "MaxHeartRate",
      xlab = "Age"
    )

    # Age x Oldpeak
    plot(
      heartDiseaseDataframe$Age,
      heartDiseaseDataframe$Oldpeak,
      col = heartDiseaseDataframe$Class,
      main = "Relationship between Age and Oldpeak",
      ylab = "Oldpeak",
      xlab = "Age"
    )

    # Age x SerumCholestoral
    plot(
      heartDiseaseDataframe$RestBloodPressure,
      heartDiseaseDataframe$SerumCholestoral,
      col = heartDiseaseDataframe$Class,
      main = "Relationship between RestBloodPressure and SerumCholestoral",
      ylab = "SerumCholestoral",
      xlab = "RestBloodPressure"
    )

    # RestBloodPressure x MaxHeartRate
    plot(
      heartDiseaseDataframe$RestBloodPressure,
      heartDiseaseDataframe$MaxHeartRate,
      col = heartDiseaseDataframe$Class,
      main = "Relationship between RestBloodPressure and MaxHeartRate",
      ylab = "MaxHeartRate",
      xlab = "RestBloodPressure"
    )

    # RestBloodPressure x Oldpeak
    plot(
      heartDiseaseDataframe$RestBloodPressure,
      heartDiseaseDataframe$Oldpeak,
      col = heartDiseaseDataframe$Class,
      main = "Relationship between RestBloodPressure and Oldpeak",
      ylab = "Oldpeak",
      xlab = "RestBloodPressure"
    )

    # SerumCholestoral x MaxHeartRate
    plot(
      heartDiseaseDataframe$SerumCholestoral,
      heartDiseaseDataframe$MaxHeartRate,
      col = heartDiseaseDataframe$Class,
      main = "Relationship between SerumCholestoral and MaxHeartRate",
      ylab = "MaxHeartRate",
      xlab = "SerumCholestoral"
    )

    # SerumCholestoral x Oldpeak
    plot(
      heartDiseaseDataframe$SerumCholestoral,
      heartDiseaseDataframe$Oldpeak,
      col = heartDiseaseDataframe$Class,
      main = "Relationship between SerumCholestoral and Oldpeak",
      ylab = "Oldpeak",
      xlab = "SerumCholestoral"
    )

    # MaxHeartRate x Oldpeak
    plot(
      heartDiseaseDataframe$MaxHeartRate,
      heartDiseaseDataframe$Oldpeak,
      col = heartDiseaseDataframe$Class,
      main = "Relationship between MaxHeartRate and Oldpeak",
      ylab = "Oldpeak",
      xlab = "MaxHeartRate"
  )

  # Dataset plots

    # Age
    ggplot(heartDiseaseDataframe) +
      geom_bar(aes(Age), fill = "#006b00") +
      ggtitle("Age")

    # Sex
    ggplot(heartDiseaseDataframe) +
      geom_bar(aes(Sex), fill = "#ffcbdb") +
      ggtitle("Sex")

    # Class
    ggplot(heartDiseaseDataframe) +
      geom_bar(aes(Class), fill = "#000080") +
      ggtitle("Class")

# === Handling data ====

  # Change "?" to NA
  heartDiseaseDataframe[heartDiseaseDataframe == "?"] <- NA

  # Removing NA values
  heartDiseaseDataframe <- na.omit(heartDiseaseDataframe)

  # Handling table columns

    # Class
    heartDiseaseDataframe$Class <- ifelse(test = heartDiseaseDataframe$Class >= 1, yes = "Unhealthy", no = "Healthy")
    heartDiseaseDataframe$Class <- as.factor(heartDiseaseDataframe$Class)

    # Other columns
    heartDiseaseDataframe[, c(1:9, 11:13)] <- sapply(heartDiseaseDataframe[, c(1:9, 11:13)], as.integer)

# ==== Boxplot with all data ====
boxplot(heartDiseaseDataframe[, -ncol(heartDiseaseDataframe)])

# ==== Data classification with all datas ====

  # Create datframe result of classifications #
  first_data <- data.frame()

  # Separate test and train model
  first_model <- buildTestAndTrain(heartDiseaseDataframe, 123, 0.8)

  # KNN classification
  Knn <- knnClassification(
    first_model$train_without_column,
    first_model$test,
    first_model$testClass,
    first_model$trainClass,
    9
  )

  first_data <- rbind(first_data, Knn)

  # SVM classification
  Svm <- svmClassification(first_model$train,
                           first_model$test,
                           first_model$testClass)

  first_data <- rbind(first_data, Svm)

  # RF classification
  Rf <- rfClassification(first_model$train,
                         first_model$test,
                         first_model$testClass)

  first_data <- rbind(first_data, Rf)

  # renaming first data columns
  colnames(first_data) <- c( "Accuracy", "Kappa", "AccuracyLower", "AccuracyUpper", "AccuracyNull", "AccuracyPValue",
                             "McnemarPValue" )

  # Cluster
  cluster_data <- heartDiseaseDataframe[, -ncol(heartDiseaseDataframe)]

  # Elbow method to see number of necessary clusters
  fviz_nbclust(cluster_data, kmeans, method = "wss")

  # Calculate cluster by grouping
  cluster_res_2 <- kmeans(cluster_data, 2)
  cluster_res_19 <- kmeans(cluster_data, 19)

  # Cluster Analysis
  result_2 <- as.data.frame(table(heartDiseaseDataframe$Class, cluster_res_2$cluster))
  result_19 <- as.data.frame(table(heartDiseaseDataframe$Class, cluster_res_19$cluster))

# ==== Handling data 2 ====

  # Removing outliers
  outlier_values <- boxplot.stats(heartDiseaseDataframe[, 1])$out
  heartDiseaseDataframe <- heartDiseaseDataframe[!(heartDiseaseDataframe[, 1] %in% outlier_values),]

  outlier_values <- boxplot.stats(heartDiseaseDataframe[, 4])$out
  heartDiseaseDataframe <- heartDiseaseDataframe[!(heartDiseaseDataframe[, 4] %in% outlier_values),]

  outlier_values <- boxplot.stats(heartDiseaseDataframe[, 5])$out
  heartDiseaseDataframe <- heartDiseaseDataframe[!(heartDiseaseDataframe[, 5] %in% outlier_values),]

  outlier_values <- boxplot.stats(heartDiseaseDataframe[, 8])$out
  heartDiseaseDataframe <- heartDiseaseDataframe[!(heartDiseaseDataframe[, 8] %in% outlier_values),]

  outlier_values <- boxplot.stats(heartDiseaseDataframe[, 10])$out
  heartDiseaseDataframe <- heartDiseaseDataframe[!(heartDiseaseDataframe[, 10] %in% outlier_values),]

# ==== Boxplot without outliers ====
boxplot(heartDiseaseDataframe[, -ncol(heartDiseaseDataframe)])

# ==== Data classification without outliers ====

  # Create datframe result of classifications without dataframe outliers
  second_data <- data.frame()

  # Separate test and train model
  second_model <- buildTestAndTrain(heartDiseaseDataframe, 123, 0.8)

  # KNN classification
  Knn <- knnClassification(
    second_model$train_without_column,
    second_model$test,
    second_model$testClass,
    second_model$trainClass,
    9
  )

  second_data <- rbind(second_data, Knn)

  # SVM classification
  Svm <- svmClassification(second_model$train,
                    second_model$test,
                    second_model$testClass)

  second_data <- rbind(second_data, Svm)

  # RF classification
  Rf <- rfClassification(second_model$train,
                   second_model$test,
                   second_model$testClass)

  second_data <- rbind(second_data, Rf)

  # Renaming dataset columns
  colnames(second_data) <- c( "Accuracy", "Kappa", "AccuracyLower", "AccuracyUpper", "AccuracyNull", "AccuracyPValue",
                              "McnemarPValue" )

  # Cluster
  cluster_data <- heartDiseaseDataframe[, -ncol(heartDiseaseDataframe)]

  # Elbow method to see number of necessary clusters
  fviz_nbclust(cluster_data, kmeans, method = "wss")

  # Calculate cluster by grouping
  cluster_res_2 <- kmeans(cluster_data, 2)
  cluster_res_19 <- kmeans(cluster_data, 19)

  # Cluster Analysis
  result_2_outlier <- as.data.frame(table(heartDiseaseDataframe$Class, cluster_res_2$cluster))
  result_19_outlier <- as.data.frame(table(heartDiseaseDataframe$Class, cluster_res_19$cluster))

# ==== Handling data 3 ====

  # PCA
  dataframe.pca <- prcomp(heartDiseaseDataframe[, -ncol(heartDiseaseDataframe)], center = TRUE, scale. = TRUE)
  newDataframe <- as.data.frame(predict(dataframe.pca, heartDiseaseDataframe))

  # Adding class column to the new dataframe
  newDataframe$Class <- heartDiseaseDataframe$Class

# ==== Data classification with PCA ====

  # Create datframe result of classifications with cleaning data pca
  third_data <- data.frame()

  # Separate test and train model
  third_model <- buildTestAndTrain(newDataframe, 123, 0.8)

  # KNN classification
  Knn <- knnClassification(
    third_model$train_without_column,
    third_model$test,
    third_model$testClass,
    third_model$trainClass,
    9
  )

  third_data <- rbind(third_data, Knn)

  # SVM classification
  Svm <- svmClassification(third_model$train, third_model$test, third_model$testClass)

  third_data <- rbind(third_data, Svm)

  # RF classification
  Rf <- rfClassification(third_model$train, third_model$test, third_model$testClass)

  third_data <- rbind(third_data, Rf)

  # renaming dataset columns
  colnames(third_data) <- c( "Accuracy", "Kappa", "AccuracyLower", "AccuracyUpper", "AccuracyNull", "AccuracyPValue",
                             "McnemarPValue" )

  # Cluster
  cluster_data <- newDataframe[, -ncol(newDataframe)]

  # Elbow method to see number of necessary clusters
  fviz_nbclust(cluster_data, kmeans, method = "wss")

  # Calculate cluster by grouping
  cluster_res_2 <- kmeans(cluster_data, 2)
  cluster_res_11 <- kmeans(cluster_data, 11)

  # Cluster Analysis
  result_2_pca <- as.data.frame(table(newDataframe$Class, cluster_res_2$cluster))
  result_11_pca <- as.data.frame(table(newDataframe$Class, cluster_res_11$cluster))


# Preamble (options, installs, imports & custom functions) ----

options(warn=1) #really should be default in R
`%!in%` = Negate(`%in%`) #should be in base R!

# specify the packages used:
required_packages = c(
	'github.com/rmcelreath/rethinking' # for rlkjcorr & rmvrnom2
	, 'github.com/stan-dev/cmdstanr' #for Stan stuff
	, 'github.com/mike-lawrence/aria/aria' # for aria
	, 'tidyverse' #for all that is good and holy
)

# load the helper functions:
for(file in fs::dir_ls('r')){
	cat('Loading function: ',fs::path_ext_remove(fs::path_file(file)),'()\n',sep='')
	source(file)
}

#install any required packages not already present
install_if_missing(required_packages)

# load tidyverse & aria
library(tidyverse)
library(aria)

# Simulate data ----
set.seed(1) #change this to make different data

#setting the data simulation parameters
sim_pars = lst(

	#parameters you can play with
	num_subj = 30 #number of subjects, must be an integer >1
	, num_vars = 2 #number of 2-level variables manipulated as crossed and within each subject, must be an integer >0
	, num_trials = 10 #number of trials per subject/condition combo, must be an integer >1

	#the rest of these you shouldn't touch
	, num_coef = 2*(2^(num_vars))
	, mu = rnorm(num_coef)
	, sigma = rweibull(num_coef,2,1)
	, r_mat = rethinking::rlkjcorr(1,num_coef,eta=1)
	, noise = rweibull(1,2,1)

	, r = r_mat[lower.tri(r_mat)]
)

#compute the contrast matrix
contrast_matrix =
	(
		1:sim_pars$num_vars
		%>% map(.f=function(x){
			factor(c('lo','hi'))
		})
		%>% (function(x){
			names(x) = paste0('v',1:sim_pars$num_vars)
			return(x)
		})
		%>% cross_df()
		%>% (function(x){
			get_contrast_matrix(
				data = x
				, formula = as.formula(paste('~',paste0('v',1:sim_pars$num_vars,collapse='*')))
				, contrast_kind = halfsum_contrasts
			)
		})
	)

#get coefficients for each subject
subj_coef =
	(
		#subj coefs as mvn
		rethinking::rmvnorm2(
			n = sim_pars$num_subj
			, Mu = sim_pars$mu
			, sigma = sim_pars$sigma
			, Rho = sim_pars$r_mat
		)
		#add names to columns
		%>% (function(x){
			dimnames(x)=list(NULL,paste0('X',1:ncol(x)))
			return(x)
		})
		#make a tibble
		%>% as_tibble(.name_repair='unique')
		#add subject identifier column
		%>% mutate(
			subj = 1:sim_pars$num_subj
		)
	)

# get condition means implied by subject coefficients and contrast matrix
subj_cond =
	(
		subj_coef
		%>% group_by(subj)
		%>% summarise(
			(function(x){
				k2 = ncol(x)
				k = k2/2
				out = attr(contrast_matrix,'data')
				out$loc = as.vector(contrast_matrix %*% t(x[,1:k]))
				out$scale = sqrt(exp(as.vector(contrast_matrix %*% t(x[,(k+1):k2]))))
				return(out)
			})(cur_data())
			, .groups = 'drop'
		)
	)

# get noisy measurements in each condition for each subject
dat =
	(
		subj_cond
		%>% expand_grid(trial = 1:sim_pars$num_trials)
		%>% mutate(
			obs = rnorm(n(),loc,scale)
		)
		%>% select(-loc,-scale)
	)

# Compute inputs to Stan model ----

#if there's no missing data (as in this synthetic example), we could proceed with modelling,
#  but to demonstrate how to handle missing data, we'll do a bit of extra work:

#Uncomment next section to induce data-missingness (causes some Ss to be missing whole conditions)
# (
# 	dat
# 	#first collapse to subject-by-condition stats
# 	%>% group_by(
# 		across(c(
# 			-obs
# 			, -trial
# 		))
# 	)
# 	%>% summarise()
# 	%>% slice_sample(prop=.9)
# 	%>% semi_join(
# 		x = dat
# 		, y = .
# 	)
# ) ->
# 	dat

(
	dat
	#add the contrast matrix columns
	%>% mutate(
		contrasts = get_contrast_matrix_rows_as_list(
			data = .
			# the following compilcated specification of the formula is a by-product of making this example
			# work for any value for sim_pars$num_vars; normally you would do something like this
			# (for 2 variables for example):
			# formula = ~ v1*v2
			, formula = as.formula(paste0('~',paste0('v',1:sim_pars$num_vars,collapse='*')))
			# half-sum contrasts are nice for 2-level variables bc they yield parameters whose value
			# is the difference between conditions
			, contrast_kind = halfsum_contrasts
		)
	)
) ->
	dat_with_contrasts

#We need a tbl containing the combinations of the unique contrasts and subjects

#first get the unique contrasts (will serve as input to Stan)
(
	dat_with_contrasts
	%>% distinct(contrasts)
	%>% arrange(contrasts) #important
) ->
	unique_contrasts

#now cross with unique subjects
(
	unique_contrasts
	%>% expand_grid(
		tibble(subj = unique(dat$subj))
	)
	%>% arrange(contrasts, subj) #important
	# add a column containing the row index
	%>% mutate(
		row = 1:n()
	)
	#join with dat_summary
	%>% right_join(
		dat_with_contrasts
		, by = c('contrasts','subj')
	)
) -> dat_with_contrasts_and_row

#now get the unique contrast matrix
(
	unique_contrasts
	%>% unnest(contrasts)
	%>% as.matrix()
) -> uw

# package for stan & sample ----

data_for_stan = lst( #lst permits later entries to refer to earlier entries

	####
	# Entries we need to specify ourselves
	####

	# uw: unique within predictor matrix
	uw = uw

	# y: observations
	, y = dat_with_contrasts_and_row$obs

	, row = dat_with_contrasts_and_row$row

	####
	# Entries computable from the above
	####

	, k = ncol(uw)
	, n = length(unique(dat_with_contrasts_and_row$subj))
	, m = length(row) # should be n*k, unless missing data

)

# double-check:
glimpse(data_for_stan)

#set the model and posterior paths
mod_path = 'stan/hwgls_nc.stan'
post_path = 'nc/hwgls_nc.nc'

# ensure model is compiled
aria:::check_syntax_and_maybe_compile(mod_path)

# compose
aria::compose(
	data = data_for_stan
	, code_path = mod_path
	, out_path = post_path
	, overwrite = T
)

# check posterior diagnostics ----
post = aria::coda(post_path)

# Check treedepth, divergences, & rebfmi
(
	post$draws(group='sample_stats')
	%>% posterior::as_draws_df()
	%>% group_by(.chain)
	%>% summarise(
		max_treedepth = max(treedepth)
		, num_divergent = sum(divergent)
		, rebfmi = var(energy)/(sum(diff(energy)^2)/n()) #n.b. reciprocal of typical EBFMI, so bigger=bad, like rhat
	)
)

# gather summary for core parameters (inc. r̂ & ess)
(
	case_when(
		str_detect(mod_path,'_nc')
			~ c('mu','sigma','r','z_')
		, T
			~ c('mu','sigma','r','z')
	)
	%>% post$draws()
	%>% posterior::summarise_draws(.cores=parallel::detectCores())
) ->
	par_summary

# show the ranges of r̂/ess's
(
	par_summary
	%>% select(rhat,contains('ess'))
	%>% summary()
)

#View those with suspect r̂
(
	par_summary
	%>% filter(rhat>1.01)
	%>% View()
)

# Viz recovery of non-correlation parameters ----
(
	post$draws(variables=c('mu','sigma'))
	%>% posterior::as_draws_df()
	%>% select(-.draw)
	%>% pivot_longer(
		cols = -c(.chain,.iteration)
		, names_to = 'variable'
	)
	%>% left_join(
		bind_rows(
			tibble(
				true = sim_pars$noise
				, variable = 'noise'
			)
			, tibble(
				true = sim_pars$mu
				, variable = paste0('mu[',1:length(true),']')
			)
			, tibble(
				true = sim_pars$sigma
				, variable = paste0('sigma[',1:length(true),']')
			)
		)
	)
	%>% group_by(variable)
	%>% arrange(variable,.chain,.iteration)
	%>% summarise(
		rhat = 1.01<posterior::rhat(matrix(value,ncol=length(unique(.chain))))
		, ess_bulk = 100>posterior::ess_bulk(matrix(value,ncol=length(unique(.chain))))
		, ess_tail = 100>posterior::ess_tail(matrix(value,ncol=length(unique(.chain))))
		, as_tibble(t(posterior::quantile2(value,c(.05,.25,.5,.75,.95))))
		, true = true[1]
	)
	%>% mutate(variable = factor_1d(variable))
	%>% ggplot()
	+ geom_hline(yintercept = 0)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q5
			, ymax = q95
			, colour = ess_tail
		)
		, alpha = .5
	)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q25
			, ymax = q75
			, colour = ess_bulk
		)
		, size = 3
		, alpha = .5
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = q50
			, fill = rhat
		)
		, shape = 21
		, size = 3
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = true
		)
		, size = 4
		, shape = 4
		, colour = 'blue'
	)
	+ coord_flip()
	+ scale_color_manual(
		values = lst(`TRUE`='red',`FALSE`='black')
		, labels = lst(`TRUE`='<100',`FALSE`='>=100')
	)
	+ scale_fill_manual(
		values = lst(`TRUE`='red',`FALSE`='white')
		, labels = lst(`TRUE`='>1.01',`FALSE`='<=1.01')
	)
	+ labs(
		y = 'True & Posterior Value'
		, x = 'Variable'
		, colour = 'ESS'
		, fill = 'Rhat'
	)
)

# Viz recovery of correlations ----
(
	post$draws(variables='r')
	%>% posterior::as_draws_df()
	%>% select(-.draw)
	%>% pivot_longer(
		cols = -c(.chain,.iteration)
		, names_to = 'variable'
	)
	%>% left_join(
		tibble(
			true = sim_pars$r_mat[lower.tri(sim_pars$r_mat)]
			, variable = case_when(
				length(true)==1 ~ 'r'
				, T ~ paste0('r[',1:length(true),']')
			)
		)
	)
	%>% group_by(variable)
	%>% arrange(variable,.chain,.iteration)
	%>% summarise(
		rhat = 1.01<posterior::rhat(matrix(value,ncol=length(unique(.chain))))
		, ess_bulk = 100>posterior::ess_bulk(matrix(value,ncol=length(unique(.chain))))
		, ess_tail = 100>posterior::ess_tail(matrix(value,ncol=length(unique(.chain))))
		, as_tibble(t(posterior::quantile2(value,c(.05,.25,.5,.75,.95))))
		, true = true[1]
	)
	%>% mutate(variable = factor_1d(variable))
	%>% ggplot()
	+ geom_hline(yintercept = 0)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q5
			, ymax = q95
			, colour = ess_tail
		)
		, alpha = .5
	)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q25
			, ymax = q75
			, colour = ess_bulk
		)
		, size = 3
		, alpha = .5
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = q50
			, fill = rhat
		)
		, shape = 21
		, size = 3
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = true
		)
		, size = 4
		, shape = 4
		, colour = 'blue'
	)
	+ coord_flip()
	+ scale_color_manual(
		values = lst(`TRUE`='red',`FALSE`='black')
		, labels = lst(`TRUE`='<100',`FALSE`='>=100')
	)
	+ scale_fill_manual(
		values = lst(`TRUE`='red',`FALSE`='white')
		, labels = lst(`TRUE`='>1.01',`FALSE`='<=1.01')
	)
	+ labs(
		y = 'True & Posterior Value'
		, x = 'Variable'
		, colour = 'ESS'
		, fill = 'Rhat'
	)
)


#############################################################################
#
# File:    get_relative_error_stats.r
# Author:  Alex Stivala
# Created: July 2011
#
# get_relative_error_stats.r - get stats on relative errors from
#                              compare_pairwise_with_subsets.py output files
#                              and output as LaTeX table
#
# $Id: get_relative_error_stats.r 778 2011-10-03 04:48:19Z astivala $
#############################################################################

rtabs <- c('compare_individual_with_subsets.rtab',
           'compare_pairwise_oneonly.rtab',
           'compare_pairwise_with_subsets.rtab')
# correpsonds to above files NB also used in if statements, careful!
descriptions <- c('individual only', 'significant pairwise',  'all pairwise')

cat('\\begin{tabular}{lrrrr}\n')
cat('\\hline\n')

cat('Data used &  $\\Delta\\mbox{VHT}$ computations  & Mean Error \\% & Num Error $> 10\\%$ \\\\\n')
#cat('Data used &  $\\Delta\\mbox{VHT}$ computations  & Mean Error \\% & Num Error $> 10\\%$ & Max Error \\%\\\\\n')
cat('\\hline\n')

for (i in 1:length(rtabs)) {
  tab <- read.table(rtabs[i], header=T, stringsAsFactors=F)
  numUpgrades <- length(unique(unlist(strsplit(tab$Subset, ','))))
  numDeltaVHT <- NULL
  if (descriptions[i] == 'individual only') {
    numDeltaVHT <- numUpgrades
  }
  else if (descriptions[i] == 'all pairwise') {
    numDeltaVHT <- numUpgrades*(numUpgrades-1)/2 + numUpgrades
  }
  else {
    # FIXME this is really dodgy, just hardcoding these here, should
    # find some way to get it out of data properly
    if (length(which(unique(unlist(strsplit(tab$Subset, ','))) == "03_03_0101")) == 1) {
      # Chicago Regional data
      numDeltaVHT <- numUpgrades + 1
    }
    else if (length(which(unique(unlist(strsplit(tab$Subset, ','))) == "ber01")) == 1) {
      # Berlin Center data
      numDeltaVHT <- numUpgrades + 11
    }
  }
  cat(descriptions[i], ' & ',  numDeltaVHT  , ' & ',
      format(mean(abs(tab$RelDiff))*100, digits=2,nsmall=1), ' & ')
   cat(length(tab$RelDiff[abs(tab$RelDiff)*100 > 10]),' \\\\\n ')
#  cat(length(tab$RelDiff[abs(tab$RelDiff)*100 > 10]),' & ')
#  cat(format(max(abs(tab$RelDiff))*100, digits=2,nsmall=1), '\\\\\n')

}

rtab <- read.table('compare_pairwise_with_subsets.rtab', header=T, stringsAsFactors=F)
numUpgrades <- length(unique(unlist(strsplit(tab$Subset, ','))))
MAXSUBSETSIZE <- numUpgrades
for (i in 3:MAXSUBSETSIZE) {
  numDeltaVHT <- sum(choose(numUpgrades, 1:i))
  relDiffColName <- paste("RelDiff", i, sep="")
  cat(paste("all subsets size $\\leq$", i), '  & ',
      numDeltaVHT, ' & ',
      format(mean(abs(rtab[[relDiffColName]][!is.na(rtab[[relDiffColName]])]))*100, digits=2,nsmall=1), ' & ')

  cat(length(which(abs(rtab[[relDiffColName]][!is.na(rtab[[relDiffColName]])])*100 > 10)) ,' \\\\\n ')
#  cat(format(max(abs(rtab[[relDiffColName]][!is.na(rtab[[relDiffColName]])]))*100, digits=2,nsmall=1), '\\\\\n')
#  cat(format(max(abs(rtab[[relDiffColName]][!is.na(rtab[[relDiffColName]])]))*100, digits=2,nsmall=1), '\\\\\n')
}

cat('\\hline\n')
cat('\\end{tabular}\n')


#Random Forest
library(randomForest)
data <- read.delim("Z:/Ajit/esophagealcancer/TCGA/allsamples/Random forest/top 10 genes.txt", row.names = 1)
fit <- randomForest(Feature ~ ., data, ntree=500)
important= data.frame(importance(fit))
important$dummy = "NA"
colnames(important) = c("Influence", "Dummy")
important= important[order(-important$Influence),]


library(tradepolicy)

# data ----

ch1_application2 <- agtpa_applications %>%
  select(exporter, importer, pair_id, year, trade, dist, cntg, lang, clny) %>%
  # this filter covers both OLS and PPML
  filter(year %in% seq(1986, 2006, 4)) %>%
  mutate(
    # variables for both OLS and PPML
    exp_year = paste0(exporter, year),
    imp_year = paste0(importer, year),
    year = paste0("log_dist_", year),
    log_trade = log(trade),
    log_dist = log(dist),
    smctry = ifelse(importer != exporter, 0, 1),

    # PPML specific variables
    log_dist_intra = log_dist * smctry,
    intra_pair = ifelse(exporter == importer, exporter, "inter")
  ) %>%
  spread(year, log_dist, fill = 0) %>%
  mutate(across(log_dist_1986:log_dist_2006, ~ .x * (1 - smctry)))

# ols ----

ch1_app2_ols <- tp_summary_app2(
  formula = "log_trade ~ 0 + log_dist_1986 + log_dist_1990 + log_dist_1994 +
    log_dist_1998 + log_dist_2002 + log_dist_2006 + cntg +
    lang + clny + exp_year + imp_year",
  data = filter(ch1_application2, importer != exporter, trade > 0),
  method = "lm"
)

# ppml ----

ch1_app2_ppml <- tp_summary_app2(
  formula = "trade ~ 0 + log_dist_1986 + log_dist_1990 +
    log_dist_1994 + log_dist_1998 + log_dist_2002 + log_dist_2006 +
    cntg + lang + clny + exp_year + imp_year",
  data = filter(ch1_application2, importer != exporter),
  method = "glm"
)

# internal distance ----

ch1_app2_intra <- tp_summary_app2(
  formula = "trade ~ 0 + log_dist_1986 + log_dist_1990 +
    log_dist_1994 + log_dist_1998 + log_dist_2002 + log_dist_2006 +
    cntg + lang + clny + exp_year + imp_year + log_dist_intra",
  data = ch1_application2,
  method = "glm"
)

# internal distance and home bias ----

ch1_app2_home <- tp_summary_app2(
  formula = "trade ~ 0 + log_dist_1986 + log_dist_1990 +
    log_dist_1994 + log_dist_1998 + log_dist_2002 + log_dist_2006 +
    cntg + lang + clny + exp_year + imp_year + log_dist_intra + smctry",
  data = ch1_application2,
  method = "glm"
)

# fe ----

ch1_app2_fe <- tp_summary_app2(
  formula = "trade ~ 0 + log_dist_1986 + log_dist_1990 +
    log_dist_1994 + log_dist_1998 + log_dist_2002 + log_dist_2006 +
    cntg + lang + clny + exp_year + imp_year + intra_pair",
  data = ch1_application2,
  method = "glm"
)

save.image("all-models-and-data/02-chapter1-distance-puzzle.RData", compress = "xz")


# Predict a whole tile using extreme gradient boosting

library(xgboost)
library(raster)
source("utils/set-temp-path.r")
source("utils/load-data.r")

OutputDir = "../../userdata/predictions/"

AllData = LoadClassificationData()
TrainData = LoadTrainingData()
Exclude=c("is.water", "osavi", "aspect", "lswi", "swir", "height")
PureData = TrainData@data[AllData@data$pure,GetTrainingNames(exclude=Exclude)]
PureLabels = AllData@data[AllData@data$pure,]$dominant
TrainingRasters = LoadTrainingRasters()

TrainMatrix = xgb.DMatrix(as.matrix(PureData), label=as.numeric(PureLabels)-1)
Model = xgboost(TrainMatrix, nrounds=5, objective="multi:softprob", num_class = 9)

GBP = function(Model, blockvals, ...)
{
    PredRaw = predict(Model, newdata=as.matrix(blockvals), ...)
    Prediction = matrix(PredRaw, byrow=TRUE, ncol=9, dimnames=list(list(), levels(PureLabels)))
    Prediction = data.frame(Prediction)[GetValidationNames()]*100
    return(Prediction)
}

print(system.time(predicted <- predict(TrainingRasters, Model, fun=GBP, index=1:9, progress="text")))

writeRaster(predicted, filename=paste0(OutputDir, "gradientboosting.tif"), progress="text", overwrite=TRUE,
    datatype="INT1U", options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4"))


# shuffle theta values across sites and calculate windowed averages to get a null distribution of max genome-wide thetas

#################################
# read command line arguments
#################################
args <- commandArgs(trailingOnly = TRUE)
print(args)

if (length(args) != 2) stop("Have to specify whether all loci (0) or GATK nodam2 unlinked loci (1), and which pop (1=Can, 2=Lof0711, 3=Lof0714, 4=Lof1114)", call.=FALSE)

gatkflag <- as.numeric(args[1])
popflag <- as.numeric(args[2])

if(gatkflag == 1){
  print('Using GATK nodam2 unlinked loci')
} else if(gatkflag == 0){
  print('Using all loci')
} else {
	stop(paste(gatkflag, ' is not 0 or 1. Please only specify 0 (all loci) or 1 (gatk loci).'))
}
if(!(popflag %in% 1:4)) stop('Have to specify pop in 1, 2, 3 or 4 (1=Can, 2=Lof0711, 3=Lof0714, 4=Lof1114)')

#################################
# parameters
#################################
winsz <- 50000 # window size
winstp <- 10000 # window step
nrep <- 1000 # number of reshuffles

####################
# load functions
require(data.table)

# after https://github.com/ANGSD/angsd/blob/master/misc/stats.cpp
a1f <- function(nsam) return(sum(1/seq(1, nsam-1)))
a2f <- function(nsam) return(sum(1/(seq(1, nsam-1)*seq(1, nsam-1))))
b1f <- function(nsam) return((nsam + 1)/(3*(nsam-1)))
b2f <- function(nsam) return((2*(nsam*nsam + nsam + 3))/(9*nsam*(nsam - 1)))
c1f <- function(a1, b1) return(b1 - (1/a1))
c2f <- function(nsam, a1, a2, b2) return(b2 - ((nsam + 2)/(a1*nsam)) + (a2/(a1 * a1)))
e1f <- function(a1, c1) return(c1/a1)
e2f <- function(a1, a2, c2) return(c2/((a1*a1) + a2))

# Tajima's D calculation
# nsam: sample size
# thetaW: Watterson's theta (# segregating sites / a1)
# sumk: theta pi (average number of SNPs in pairwise comparisons)
# after https://github.com/ANGSD/angsd/blob/master/misc/stats.cpp
tajd <- function(nsam, thetaW, sumk){
	a1 <- a1f(nsam)
	segsites <- thetaW * a1
	if(segsites == 0) return(0)
	a2 <- a2f(nsam)
	b1 <- b1f(nsam)
  	b2 <- b2f(nsam)
	c1 <- c1f(a1, b1)
	c2 <- c2f(nsam, a1, a2, b2)
	e1 <- e1f(a1, c1)
	e2 <- e2f(a1, a2, c2)
	res <- (sumk - (thetaW))/sqrt((e1*segsites) + ((e2*segsites)*(segsites-1)))
	return(res)
}

# calculate thetas in windows from data
calcstat <- function(temp1, temp2, nchr1, nchr2){
  # create new columns as indices for windows
  # need multiple columns because overlapping windows
  for(j in 1:(winsz/winstp)){
    temp1[, (paste0('win_', j)) := floor((Pos - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
    temp2[, (paste0('win_', j)) := floor((Pos - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
  }

  # calc ave theta for each window
  for(j in 1:(winsz/winstp)){
    nm1 <- paste0('win_', j)
    if(j ==1){
      bins1 <- temp1[, .(Chromo, Watterson, Pairwise, WinCenter = get(nm1))][, .(tW1 = sum(exp(Watterson), na.rm = TRUE),
                                                                                tP1 = sum(exp(Pairwise), na.rm = TRUE)),
                                                                             by = .(Chromo, WinCenter)]
      bins2 <- temp2[, .(Chromo, Watterson, Pairwise, WinCenter = get(nm1))][, .(tW2 = sum(exp(Watterson), na.rm = TRUE),
                                                                                tP2 = sum(exp(Pairwise), na.rm = TRUE)),
                                                                             by = .(Chromo, WinCenter)]
    }
    if(j > 1){
      bins1 <- rbind(bins1, temp1[, .(Chromo, Watterson, Pairwise, WinCenter = get(nm1))][, .(tW1 = sum(exp(Watterson), na.rm = TRUE),
                                                                                tP1 = sum(exp(Pairwise), na.rm = TRUE)),
                                                                                by = .(Chromo, WinCenter)])
      bins2 <- rbind(bins2, temp2[, .(Chromo, Watterson, Pairwise, WinCenter = get(nm1))][, .(tW2 = sum(exp(Watterson), na.rm = TRUE),
                                                                                tP2 = sum(exp(Pairwise), na.rm = TRUE)),
                                                                                by = .(Chromo, WinCenter)])
    }
  }

  # calculate Tajima's D
  bins1[, tD1 := tajd(nchr1, tW1, tP1), by = 1:nrow(bins1)]
  bins2[, tD2 := tajd(nchr2, tW2, tP2), by = 1:nrow(bins2)]

  # merge by window and calculate change
  bins <- merge(bins1, bins2, by = c("Chromo", "WinCenter"))
  bins[, ':='(tWd = tW2 - tW1, tPd = tP2 - tP1, tDd = tD2 - tD1)]

  return(bins)
}

# calculate min and max change from reshuffled data
shufflestat <- function(dat1, dat2, nchr1, nchr2){
	inds1 <- sample(1:nrow(dat1), nrow(dat1), replace = FALSE)
	temp1 <- cbind(dat1[, .(Chromo, Pos)], dat1[inds1, .(Watterson, Pairwise)]) # shuffle theta across position pairs
	inds2 <- sample(1:nrow(dat2), nrow(dat2), replace = FALSE)
	temp2 <- cbind(dat2[, .(Chromo, Pos)], dat2[inds2, .(Watterson, Pairwise)]) # second time-point

	bins <- calcstat(temp1, temp2, nchr1, nchr2)

	# return the max and min windowed change
	# exclude windows with negative midpoints
	return(bins[WinCenter >= winsz/2, .(mintWd = min(tWd, na.rm = TRUE),
	                                    maxtWd = max(tWd, na.rm = TRUE),
	                                    mintPd = min(tPd, na.rm = TRUE),
	                                    maxtPd = max(tPd, na.rm = TRUE),
	                                    mintDd = min(tDd, na.rm = TRUE),
	                                    maxtDd = max(tDd, na.rm = TRUE))])

}

######################
# Load data
######################

# load all loci theta calcs if requested
if(gatkflag == 0){
	if(popflag == 1){
		print('Starting Can')
		dat1 <- fread('analysis/thetas.Can_40.pestPG.gz')
		dat2 <- fread('analysis/thetas.Can_14.pestPG.gz')
		nchr1 <- 42 # sample size in # chromosomes
		nchr2 <- 48
		outfilesuff <- 'Can_40.Can_14'
	}
	if(popflag == 2){
		print('Starting Lof0711')
		dat1 <- fread('analysis/thetas.Lof_07.pestPG.gz')
		dat2 <- fread('analysis/thetas.Lof_11.pestPG.gz')
		nchr1 <- 44
		nchr2 <- 48
		outfilesuff <- 'Lof_07.Lof_11'
	}
	if(popflag == 3){
		print('Starting Lof0714')
		dat1 <- fread('analysis/thetas.Lof_07.pestPG.gz')
		dat2 <- fread('analysis/thetas.Lof_14.pestPG.gz')
		nchr1 <- 44
		nchr2 <- 44
		outfilesuff <- 'Lof_07.Lof_14'
	}
	if(popflag == 4){
		print('Starting Lof1114')
		dat1 <- fread('analysis/thetas.Lof_11.pestPG.gz')
		dat2 <- fread('analysis/thetas.Lof_14.pestPG.gz')
		nchr1 <- 48
		nchr2 <- 44
		outfilesuff <- 'Lof_11.Lof_14'
	}
}

if(gatkflag == 1){
	if(popflag == 1){
		print('Starting Can')
		dat1 <- fread('analysis/thetas.Can_40.gatk.pestPG.gz')
		dat2 <- fread('analysis/thetas.Can_14.gatk.pestPG.gz')
		nchr1 <- 42 # sample size in # chromosomes
		nchr2 <- 48
		outfilesuff <- 'Can_40.Can_14.gatk'
	}
	if(popflag == 2){
		print('Starting Lof0711')
		dat1 <- fread('analysis/thetas.Lof_07.gatk.pestPG.gz')
		dat2 <- fread('analysis/thetas.Lof_11.gatk.pestPG.gz')
		nchr1 <- 44
		nchr2 <- 48
		outfilesuff <- 'Lof_07.Lof_11.gatk'
	}
	if(popflag == 3){
		print('Starting Lof0714')
		dat1 <- fread('analysis/thetas.Lof_07.gatk.pestPG.gz')
		dat2 <- fread('analysis/thetas.Lof_14.gatk.pestPG.gz')
		nchr1 <- 44
		nchr2 <- 44
		outfilesuff <- 'Lof_07.Lof_14.gatk'
	}
	if(popflag == 4){
		print('Starting Lof1114')
		dat1 <- fread('analysis/thetas.Lof_11.gatk.pestPG.gz')
		dat2 <- fread('analysis/thetas.Lof_14.gatk.pestPG.gz')
		nchr1 <- 48
		nchr2 <- 44
		outfilesuff <- 'Lof_11.Lof_14.gatk'
	}
}

# fix name
setnames(dat1, '#Chromo', 'Chromo')
setnames(dat2, '#Chromo', 'Chromo')

# remove unplaced
dat1 <- dat1[grep('Unplaced', Chromo, invert = TRUE), ]
dat2 <- dat2[grep('Unplaced', Chromo, invert = TRUE), ]

# trim to nodam2 loci if gatk
if(gatkflag == 1){
  print('Trimming to nodam2 loci')
  nodam2 <- fread('data_2020.05.07/GATK_filtered_SNP_no_dam2.tab') # list of loci that pass nodam2 filter
	setnames(nodam2, c('Chromo', 'Pos', 'REF', 'ALT'))
	dat1 <- merge(dat1, nodam2[, .(Chromo, Pos)])
	dat2 <- merge(dat2, nodam2[, .(Chromo, Pos)])
}

# mark unlinked loci if gatk
if(gatkflag == 1){
  print('Trimming to unlinked loci')
	if(popflag == 1) unl <- fread('analysis/ld.unlinked.Can.gatk.nodam.csv.gz') # list of unlinked loci for Canada
	if(popflag %in% 2:4) unl <- fread('analysis/ld.unlinked.Lof.gatk.nodam.csv.gz') # for Lofoten
	dat1 <- merge(dat1, unl[, .(Chromo = CHROM, Pos = POS, keep = 1)], all.x = TRUE)
	dat2 <- merge(dat2, unl[, .(Chromo = CHROM, Pos = POS, keep = 1)], all.x = TRUE)
	dat1[is.na(keep), keep := 0]
	dat2[is.na(keep), keep := 0]
}

#######################################
# Calculate change on unshuffled data
#######################################

# full dataset
out <- calcstat(dat1, dat2, nchr1, nchr2)
outfile1 <- paste0('analysis/theta_change_region_', winsz, '.', outfilesuff, '.csv.gz')
write.csv(out, file = gzfile(outfile1))
print(paste0('Wrote ', outfile1))

# unlinked (if GATK)
if(gatkflag == 1){
  out2 <- calcstat(dat1[keep == 1, ], dat2[keep == 1, ], nchr1, nchr2)
  outfile2 <- paste0('analysis/theta_change_region_', winsz, '.', outfilesuff, '.unlinked.csv.gz')
  write.csv(out2, file = gzfile(outfile2))
  print(paste0('Wrote ', outfile2))
}

#################################
# Trim to unlinked sites if GATK
#################################

if(gatkflag == 1){
  dat1 <- dat1[keep == 1, ]
  dat2 <- dat2[keep == 1, ]
}

################################
# Run reshuffle calculations
# shuffle and recalc windowed thetas
################################

for(i in 1:nrep){
	cat(i); cat(' ')
	tempminmax <- shufflestat(dat1, dat2, nchr1, nchr2)

	if(i == 1) minmax <- tempminmax # save the results from this iteration
	if(i > 1) minmax <- rbind(minmax, tempminmax)
}

write.csv(minmax, gzfile(paste0('analysis/theta.siteshuffle.', outfilesuff, '.csv.gz')), row.names = FALSE) # write out all iterations

rm(minmax)


#' @export
accel.str <- function (x.str) {
	#for BCa conf.intervals
    if (any(x.str$nh <= 1)) {
        return(NA)
    }
    else {
        temp <- accel.est(x.str)
        fh <- x.str$nh/x.str$Nh
        accel <- sum(x.str$Wh^3 * (1 - fh) * (1 - 2 * fh) * temp[1,
            ])
        acceld <- sum((x.str$Nh * (x.str$Nh - x.str$nh) * temp[2,
            ])/sum(x.str$Nh)^2)
        accel/(6 * acceld^(3/2))
    }
}


library(raster)
library(watershed)
library(Matrix)
library(sf)
library(WatershedTools)

ca = raster("output/catchment.tif")
neretva = stack("output/neretva.grd")
ner_ws = readRDS("output/neretva_ws.rds")
neretva = crop(neretva, ca)
neretva = addLayer(neretva, ca)
Tp = pixel_topology(neretva)
Tp = as(Tp, "dgTMatrix")
Tp_df = data.frame(us = Tp@i+ 1, ds = Tp@j + 1, length_m = Tp@x)

ner_pts = rasterToPoints(neretva)
ner_pts = as.data.frame(ner_pts)
ner_pts = ner_pts[complete.cases(ner_pts),]
ner_pts = merge(ner_pts, Tp_df, by.x = "id", by.y = "us", all.x = TRUE)

i = which(is.na(ner_pts$ds))
# distance across a pixel in a cardinal direction
straight = min(ner_pts$length_m, na.rm=TRUE)
# distance across a pixel diagonally
diagon = max(ner_pts$length_m, na.rm=TRUE)

out_direction = ner_pts[i,"drainage"]
# even number drainages are straight, odd diagonal
# divide by two because only half a pixel for the outlet
ner_pts$length_m[i] = ifelse(out_direction %% 2, diagon, straight)/2

# drop and rename columns
cols = c("id", 'stream', 'x', 'y', 'accum', 'drainage', 'catchment.2', 'length_m', 'ds')
ner_pts = ner_pts[, cols]
colnames(ner_pts)[c(2, 7, 9)] = c("reach_id", "catch_area_km2", "downstream_id")
ner_pts$catch_area_km2 = ner_pts$catch_area_km2 / (1000^2)

# merge with reaches
vv = st_read("output/neretva.gpkg")
vvtab = vv[,1:21]
st_geometry(vvtab) = NULL

ner_pts = merge(ner_pts, vvtab, by = "reach_id", all.x = TRUE)

wsdat = as.data.frame(ner_ws$data)[, c("pixel_id", "elevation", "dist")]
colnames(wsdat) = c("id", "elevation_m", "outlet_distance_km")

ner_pts = merge(ner_pts, wsdat, by = "id")

saveRDS(ner_pts, "output/neretva_pixels.rds")


#===============================================================================
#  File:    07-other-appendix-graphs.R
#  Date:    Feb 3, 2021
#  Purpose: replicate appendix analyses: graphs with HTE
#  Data In:
#           ./data/survey_data.csv
#           ./data/daily_pulse_data.csv
#===============================================================================

# PACKAGES
#===============================================================================
library(tidyverse)
library(estimatr)
library(glmnet)
library(powerLATE)
library(haven)
source('code/functions.r')

# DATA
#===============================================================================
pulse <- read_csv("data/daily_pulse_data.csv")
svy <- read_csv("data/survey_data.csv")

# Dropping observations where treatment is missing
svy <- svy[!is.na(svy$W3_PATA306_treatment_w3),]

# Analysis ----------------------------------------------------------------

# https://declaredesign.org/blog/biased-fixed-effects.html

vars <- c("party7", "age", "agesq", "female", "raceeth", "educ",
          "ideo", "income", "employ", "state", "polint", "freq_tv", "freq_np",
          "freq_rad", "freq_net", "freq_disc", "log_news_pre", "diet_mean_pre")

########################################################
### Issue RQ1: heterogeneous treatment effects
########################################################

dv <- 'issue_scale'
dv_pre <- 'issue_scale_pre'
moderator <- 'ideo'
trt <- 'HuffPost'

# H2
heterogeneous_effect(dv = dv, dv_pre = dv_pre,
                     moderator = moderator, trt = trt)

# compute standard itt
itt <- run_model(dv = dv, dv_pre = dv_pre, trt = trt, verbose=FALSE)
vars <- unique(c(extract_covariates(itt), moderator))
# now compute itt but adding moderator (if it wasn't included)
lin_formula <- formula(paste0(dv, " ~ W3_PATA306_treatment_w3"))
lin_covars <- formula(paste0(" ~ ", paste(vars, collapse = " + ")))
res <- lm_lin(lin_formula, covariates = lin_covars,
              data=svy[svy$W3_PATA306_treatment_w3 %in% c("Control", trt),])

# computing marginal effects
main <- "W3_PATA306_treatment_w3HuffPost"
inter <- "W3_PATA306_treatment_w3HuffPost:ideo_c"
xvars <- ((1:5)-res$scaled_center['ideo'])
ideo_cats <- c("Very liberal", "Liberal", "Moderate", "Conservative", "Very conservative")

marg.effects <- coef(res)[main] +
  coef(res)[inter] *
  xvars
sd <- sqrt(
  vcov(res)[main, main] +
    vcov(res)[inter, inter] * xvars^2 +
    2 * xvars * vcov(res)[main, inter]
)
df <- data.frame(
  ideo = xvars,
  ideo_ct = factor(ideo_cats, levels=ideo_cats),
  mean = marg.effects,
  sd = sd
)

p <- ggplot(df, aes(x=ideo_ct, y=mean))
pq <- p + theme_minimal() +
  geom_pointrange(aes(ymin = mean - 1.96 * sd,
                      ymax = mean + 1.96 * sd)) +
  scale_x_discrete("Self-reported ideology") +
  scale_y_continuous("Estimated marginal effect (95% CI)") +
  geom_hline(yintercept = 0, size=1, color="blue", linetype=6)
pq

ggsave(pq,
       file="graphs/appendix_fig14.pdf",
       height=5, width=7)

########################################################
### Media Trust RQ1
########################################################

#### PARTY ID

dv <- 'bias'
moderator <- 'party7'
trt <- 'FoxNews'

# H2
heterogeneous_effect(dv = dv,
                     moderator = moderator, trt = trt)

# compute standard itt
itt <- run_model(dv = dv, trt = trt, verbose=FALSE)
vars <- unique(c(extract_covariates(itt), moderator))
# now compute itt but adding moderator (if it wasn't included)
lin_formula <- formula(paste0(dv, " ~ W3_PATA306_treatment_w3"))
lin_covars <- formula(paste0(" ~ ", paste(vars, collapse = " + ")))
res <- lm_lin(lin_formula, covariates = lin_covars,
              data=svy[svy$W3_PATA306_treatment_w3 %in% c("Control", trt),])
res <- lm_robust(bias ~ party7 * W3_PATA306_treatment_w3,
                 data=svy[svy$W3_PATA306_treatment_w3 %in% c("Control", trt),])

# computing marginal effects
main <- "W3_PATA306_treatment_w3FoxNews"
inter <- "W3_PATA306_treatment_w3FoxNews:party7_c"
inter <- "party7:W3_PATA306_treatment_w3FoxNews"
xvars <- ((1:7)-res$scaled_center['party7'])
xvars <- 1:7
ideo_cats <- c("Strong\nDemocrat", "Not very\nstrong\nDemocrat",
               "Lean\nDemocrat", "Independent",
               "Lean\nRepublican", "Not very\nstrong\nRepublican",
               "Strong\nRepublican")

marg.effects <- coef(res)[main] +
  coef(res)[inter] *
  xvars
sd <- sqrt(
  vcov(res)[main, main] +
    vcov(res)[inter, inter] * xvars^2 +
    2 * xvars * vcov(res)[main, inter]
)
df <- data.frame(
  facet = "interaction with party ID",
  ideo = xvars,
  ideo_ct = factor(ideo_cats, levels=ideo_cats),
  mean = marg.effects,
  sd = sd
)

library(margins)
res <- lm(bias ~ party7 * W3_PATA306_treatment_w3,
          data=svy[svy$W3_PATA306_treatment_w3 %in% c("Control", trt),])
margins(res, variables = "party7")
cplot(res, "party7", what = "effect")

#### IDEOLOGY

dv <- 'bias'
moderator <- 'ideo'
trt <- 'FoxNews'

# H2
heterogeneous_effect(dv = dv,
                     moderator = moderator, trt = trt)

# compute standard itt
itt <- run_model(dv = dv, trt = trt, verbose=FALSE)
vars <- unique(c(extract_covariates(itt), moderator))
# now compute itt but adding moderator (if it wasn't included)
lin_formula <- formula(paste0(dv, " ~ W3_PATA306_treatment_w3"))
lin_covars <- formula(paste0(" ~ ", paste(vars, collapse = " + ")))
res <- lm_lin(lin_formula, covariates = lin_covars,
              data=svy[svy$W3_PATA306_treatment_w3 %in% c("Control", trt),])
res <- lm_robust(bias ~ ideo * W3_PATA306_treatment_w3,
                 data=svy[svy$W3_PATA306_treatment_w3 %in% c("Control", trt),])

# computing marginal effects
main <- "W3_PATA306_treatment_w3FoxNews"
inter <- "W3_PATA306_treatment_w3FoxNews:ideo_c"
inter <- "ideo:W3_PATA306_treatment_w3FoxNews"
xvars <- ((1:5)-res$scaled_center['ideo'])
xvars <- (1:5)
ideo_cats <- c("Very\nliberal", "Liberal", "Moderate", "Conservative", "Very\nconservative")

marg.effects <- coef(res)[main] +
  coef(res)[inter] *
  xvars
sd <- sqrt(
  vcov(res)[main, main] +
    vcov(res)[inter, inter] * xvars^2 +
    2 * xvars * vcov(res)[main, inter]
)
df <- rbind(df, data.frame(
  facet = "Interaction with ideology",
  ideo = xvars,
  ideo_ct = factor(ideo_cats, levels=ideo_cats),
  mean = marg.effects,
  sd = sd
))

p <- ggplot(df, aes(x=ideo_ct, y=mean))
pq <- p + theme_minimal() +
  geom_pointrange(aes(ymin = mean - 1.96 * sd,
                      ymax = mean + 1.96 * sd)) +
  facet_wrap(~facet, scales="free_x") +
  scale_x_discrete("Self-reported party ID or ideology") +
  scale_y_continuous("Estimated marginal effect (95% CI)") +
  geom_hline(yintercept = 0, size=1, color="blue", linetype=6)
pq

ggsave(pq,
       file="graphs/appendix_fig15.pdf",
       height=5, width=12)

########################################################
### Media Trust RQ1 (W5)
########################################################

#### PARTY ID

dv <- 'trust_hp_w5'
moderator <- 'party7'
trt <- 'FoxNews'

# H2
heterogeneous_effect(dv = dv,
                     moderator = moderator, trt = trt)

# compute standard itt
itt <- run_model(dv = dv, trt = trt, verbose=FALSE)
vars <- unique(c(extract_covariates(itt), moderator))
# now compute itt but adding moderator (if it wasn't included)
lin_formula <- formula(paste0(dv, " ~ W3_PATA306_treatment_w3"))
lin_covars <- formula(paste0(" ~ ", paste(vars, collapse = " + ")))
res <- lm_lin(lin_formula, covariates = lin_covars,
              data=svy[svy$W3_PATA306_treatment_w3 %in% c("Control", trt),])

# computing marginal effects
main <- "W3_PATA306_treatment_w3FoxNews"
inter <- "W3_PATA306_treatment_w3FoxNews:party7_c"
xvars <- ((1:7)-res$scaled_center['party7'])
ideo_cats <- c("Strong\nDemocrat", "Not very\nstrong\nDemocrat",
               "Lean\nDemocrat", "Independent",
               "Lean\nRepublican", "Not very\nstrong\nRepublican",
               "Strong\nRepublican")

marg.effects <- coef(res)[main] +
  coef(res)[inter] *
  xvars
sd <- sqrt(
  vcov(res)[main, main] +
    vcov(res)[inter, inter] * xvars^2 +
    2 * xvars * vcov(res)[main, inter]
)
df <- data.frame(
  facet = "interaction with party ID",
  ideo = xvars,
  ideo_ct = factor(ideo_cats, levels=ideo_cats),
  mean = marg.effects,
  sd = sd
)

p <- ggplot(df, aes(x=ideo_ct, y=mean))
pq <- p + theme_minimal() +
  geom_pointrange(aes(ymin = mean - 1.96 * sd,
                      ymax = mean + 1.96 * sd)) +
  #facet_wrap(~facet, scales="free_x") +
  scale_x_discrete("Self-reported party ID") +
  scale_y_continuous("Estimated marginal effect (95% CI)") +
  geom_hline(yintercept = 0, size=1, color="blue", linetype=6)
pq

ggsave(pq,
       file="graphs/appendix_fig16.pdf",
       height=5, width=12)

########################################################
### MEDIA TRUST -- SINGLE GRAPH WITH ALL RESULTS ACROSS WAVES
########################################################

# wave 4
wave <- "Wave 4"
est <- c(-0.123, -0.081, -0.538, -0.378)
se <- c(0.052, 0.054, 0.232, 0.223)
trt <- c("Fox News", "HuffPost", "Fox News", "HuffPost")
method <- c("ITT", "ITT", "CACE", "CACE")

df1 <- data.frame(
  est, se, trt, method, wave
)

# wave 7
wave <- "Wave 7"
est <- c(-0.129, -0.154, -0.557, -0.701)
se <- c(0.058, 0.060, 0.262, 0.276)
trt <- c("Fox News", "HuffPost", "Fox News", "HuffPost")
method <- c("ITT", "ITT", "CACE", "CACE")

df2 <- data.frame(
  est, se, trt, method, wave
)

# wave 8
wave <- "Wave 8"
est <- c(-0.091, -0.105, -0.512, -0.565)
se <- c(0.057, 0.060, 0.267, 0.267)
trt <- c("Fox News", "HuffPost", "Fox News", "HuffPost")
method <- c("ITT", "ITT", "CACE", "CACE")

df3 <- data.frame(
  est, se, trt, method, wave
)

df <- rbind(df1, df2, df3)

p <- ggplot(df, aes(x=trt, y=est, group=method, color=method))
pq <- p + geom_point(position = position_dodge(width = 0.5), size=5) +
  geom_linerange(aes(ymin=est-1*se, ymax=est+1*se), size=3,
                 position = position_dodge(width = 0.5)) +
  geom_linerange(aes(ymin=est-1.96*se, ymax=est+1.96*se), size=1,
                 position = position_dodge(width = 0.5)) +
  scale_color_manual(values=c("black", "gray80")) +
  facet_grid(~wave) +
  theme_minimal() +
  geom_hline(yintercept=0, size=1) +
  theme(axis.title.y = element_blank(),
        axis.title = element_blank(),
        legend.position="none",
        panel.grid.major = element_blank()) +
  ggtitle("Media trust")
pq

ggsave(pq, file="graphs/appendix_fig17.pdf", height=4, width=6)


ExtractEffectSize <- function(data, preference) {

  N1 <- data[gender == 0 & GDPquant == 4, .N]
  N2 <- data[gender == 1 & GDPquant == 4, .N]

  M1 <- data[gender == 0 & GDPquant == 4, mean(eval(as.name(preference)))]
  M2 <- data[gender == 1 & GDPquant == 4, mean(eval(as.name(preference)))]
  S1 <- data[gender == 0 & GDPquant == 4, sd(eval(as.name(preference)))]
  S2 <- data[gender == 1 & GDPquant == 4, sd(eval(as.name(preference)))]
  Sp <- sqrt( ( (N1 - 1) * S1^2 + (N2 - 1) * S2^2 ) / (N1 + N2 -2) )
  d_cohen <- M1 - M2 / Sp

  return(d_cohen)
}


# Rui Qiu (rq47)
# 2021-09-27

# For this part, I aim to retrieve some soccer players' advanced statistics from understat.com

###########################
#                         #
#      ATTENTION!!!       #
#                         #
###########################

# The package used here is {understatr} which is not hosted on CRAN.
# The only installation approach is to install it directly from GitHub.

# If you don't want to install this, that's ok. Just load the CSV data.
remotes::install_github('ewenme/understatr', force = TRUE)

# The good old setup I use for all my R scripts,
# {pacman} will check if a package is installed and try to load it.
# if not: install and load it.

if (!require("pacman")) install.packages("pacman")
pacman::p_load(tidyverse, understatr, ggthemes, cluster,
               ggrepel, ggpubr, factoextra, glue)

big_six <- c("Manchester United", "Manchester City",
             "Liverpool", "Chelsea", "Arsenal", "Tottenham")

# TIL: top_n is superseded, just use slice_min() and slice_max() instead

roaster_of_six <- tibble()

for (club in big_six) {
    team <- get_team_players_stats(club, year = 2021) %>%
        slice_max(time, n = 10) %>%
        select(player_name, xG, xGChain, xGBuildup)
    roaster_of_six <- roaster_of_six %>%
        bind_rows(team)
}

# take a glimpse()
glimpse(roaster_of_six)

# save it to a csv
write_csv(roaster_of_six, "q2-data.csv")

# hey, if you didn't install that understatr pacakge, load the file here:
roaster_of_six <- read_csv("q2-data.csv")

# Ideally, the cluster number k = 3 which categorizes the players into forward, midfielder and defender. But we all know this is not how modern soccer works. Still, we move on to the clustering.

roaster_of_six <- roaster_of_six %>%
    column_to_rownames(var="player_name")

km <- kmeans(roaster_of_six, centers = 3, nstart = 25)
glimpse(km)

factormap <- fviz_cluster(km, data = roaster_of_six,
                          repel = TRUE, # avoid label overlapping
                          show.clust.cent = TRUE, # show cluster centers
                          palette = "lancet") + # see ?ggpubr::ggpar for more palette options
    theme_fivethirtyeight() +
    theme(
        text = element_text(family = "Roboto Condensed"),
        title = element_text(size = 18),
        plot.subtitle = element_text(size = 16),
        plot.caption = element_text(size = 10),
        axis.title = element_text(size = 14),
        axis.text = element_text(size = 12),
        panel.grid.minor.x = element_blank()
    ) +
    labs(
        title = "Big-Six's Players Statistics Clustering",
        subtitle = "Primier League 2021-2022 Season (until 2021-09-27)",
        caption = glue("
                      * Only picked 10 players from each team ranking by playing time.
                      Source: understat.com
                      By: Rui Qiu (rq47)")
    )

factormap

# wanna save it? save it
ggsave(factormap, filename = "q2.png", device = "png",
       height = 9, width = 11, dpi = 100)


# generic fitting routine for fixed vs collapsing bound models #
#
#
#
#
# simulate contaminant trials, for plotting output
contaminantmixresps=function(preds,contp,nmc) {
  contn=floor(contp$p*nmc)
  if(contn>0) {
    preds$rts[1:contn]=runif(n=contn,min=contp$minrt,max=contp$maxrt)
    preds$resps[1:contn]=sample(x=c(1,2),size=contn,replace=TRUE)
  }
  preds
}

qmpouts=function(qs,preds,pred=F,qps,contp,nmc) {
  # get probability of correct[1] or error[2]
  out=list(p=numeric(2))
  out$p[1]=sum(preds$resps==1)/nmc
  out$p[2]=1-out$p[1]

  nbins=length(qps)+1
  if(!pred) {
    # Calculate probability masses in inter-quantile ranges.
    out$predp=array(dim=c(nbins,2))
    for (i in 1:2) {
      # correct probabilities for total probability of response
      userts=preds$rts[preds$resps==i]
      if(length(userts)==0) {
        out$predp[,i]=(.5/nbins)/nmc
      } else {
        out$predp[,i]=table(cut(x=userts,breaks=c(0,qs[,i],Inf)))/nmc
      }
    }
    # contaminant mixture process
    out$predp=out$predp*(1-contp)+(contp/(nbins*2))
  } else {
    # calculate predicted quantile values
    out$predq=cbind(quantile(preds$rts[preds$resps==1],probs=qps),
                    quantile(preds$rts[preds$resps==2],probs=qps))
  }
  out
}

getpreds=function(x,dat,nmc,contp,ncohs,fitUGM,pred=F,gub,
                  qps,stepsize,stoch.s,timecons,usign,parnames,maxTimeStep) {
  # pred=F returns chi-squared, pred=T returns a list like dat with predicted
  # quantiles and probabilities (for later plotting)
  # - don't need dat for fitting, but use it to get shape for model preds
  names(x)=parnames

  z=makeparamlist(params=x,fitUGM=fitUGM,ncohs=ncohs)

  #  maxiter=as.double(length(seq(0,bailouttime,stepsize)))  # bailouttime for C code
  mod=list(p=vector(length=length(dat$p)))
  if(pred) mod$q=array(dim=dim(dat$q)) else mod$q=array(dim=dim(dat$pb))

  interval=0.00001;
  LUT=qnorm(seq(interval,1-interval,interval));
  nLUT = length(LUT);

  for(N in 1:length(ncohs)){
    tmp=diffusionC(v=z$v[N],eta=z$eta,aU=z$aU,aL=z$aL,Ter=z$Ter,
                   intercept=z$intercept, ieta=z$ieta, st0=z$st0,
                   z=z$z, zmin=z$zmin,zmax=z$zmax,timecons_var = z$timecons_var, usign_var = z$usign_var, usigneta = z$usigneta,
                   sx = z$sx, sy=z$sy, delay=z$delay,lambda = z$lambda, aprime = z$aprime, k = z$k,
                   nmc=nmc,dt=stepsize,stoch.s=stoch.s,maxTimeStep=maxTimeStep,fitUGM=fitUGM, timecons=timecons,usign=usign,
                   nLUT=nLUT, LUT=LUT)
              # remove trials slower than gub
              use=tmp$rts<gub
              # with no between trial variability, can get stuck in bad parameter space
              #   sub in a single dud RT, so there's something there to prevent optimiser crashing
            if(sum(use)==0) {
              tmp$resps=2 ; tmp$rts=runif(1,0,gub) ; use=T
            } else {
              tmp$resps=tmp$resps[use] ; tmp$rts=tmp$rts[use]
            }
    # use function qmpouts for simulation models
    tmp=qmpouts(qs=dat$q[,,N],preds=tmp,pred=pred,qps=qps,contp=contp$p,nmc=sum(use))
    mod$p[N]=tmp$p[1]   # correct stored in p[1], error in p[2]
    mod$q[,,N]=switch(pred+1,tmp$predp,tmp$predq)
  }
  mod
}

obj=function(x,dat,nmc,contp,ncohs,fitUGM,pred=F,gub,
             qps,stepsize,stoch.s,timecons,usign,parnames,maxTimeStep) {
    preds=getpreds(x=x,dat=dat,nmc=nmc,contp=contp,ncohs=ncohs,fitUGM=fitUGM,
    pred=pred,gub=gub,qps=qps,stepsize=stepsize,stoch.s=stoch.s,
    timecons=timecons,usign=usign,parnames=parnames,maxTimeStep=maxTimeStep)
  if(!pred) {
    -sum(dat$pb*log(pmax(preds$q,1e-10)))
   } else {
     preds
   }
}

objPerQ=function(x,dat,nmc,contp,ncohs,fitUGM,pred=F,gub,
                 qps,stepsize,stoch.s,timecons,usign,parnames,maxTimeStep) {
  preds=getpreds(x=x,dat=dat,nmc=nmc,contp=contp,ncohs=ncohs,fitUGM=fitUGM,
                 pred=pred,gub=gub,qps=qps,stepsize=stepsize,stoch.s=stoch.s,
                 timecons=timecons,usign=usign,parnames=parnames,maxTimeStep=maxTimeStep)
  if(!pred) {
    -dat$pb*log(pmax(preds$q,1e-10))
  } else {
    preds
  }
}


# -*- 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: Mendes R.
#' @author: Santos R.
#' @author: Martins T.
#'

# 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'))

normalizedDataset <- xlsx::read.xlsx('datasets/normalizedDataset.xlsx',1, header= TRUE)

set.seed(333)
trainingRowIndex <- sample(1:nrow(normalizedDataset), 0.7*nrow(normalizedDataset))
trainData <- normalizedDataset[trainingRowIndex, ]
testData <- normalizedDataset[-trainingRowIndex, ]
prop.table(table(trainData$isChurn))
prop.table(table(testData$isChurn))

train_labels <- as.factor(trainData$isChurn)
test_labels <- as.factor(testData$isChurn)

drops <- c("isChurn")
trainData <- trainData[ , !(names(trainData) %in% drops)]
testData <- testData[ , !(names(testData) %in% drops)]

c5_model <- C5.0(trainData, train_labels)
c5_model
summary(c5_model)
c5_pred <- predict(c5_model, testData)
gmodels::CrossTable(test_labels, c5_pred,
                    prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
                    dnn = c('actual default', 'predicted default'))

caret::confusionMatrix(c5_pred, test_labels, positive = "1")


#!/usr/bin/env Rscript

data = read.csv("hw1_data.csv")
highOzoneFilter = data[['Ozone']] > 31
highTempFilter = data[['Temp']] > 90
filteredData = data[highOzoneFilter,][highTempFilter,]
nonMissingFilter = !is.na(filteredData[['Solar.R']])
# Interestingly, we get an integer (212) instead of the float (212.8) provided
# as a multiple-choice answer.  Probably doing something wrong.
mean(filteredData[['Solar.R']][nonMissingFilter])


#' Random Corpus
#'
#' Generate a corpus of random "words".
#'
#' @param nwords
#' Number of words to generate.
#' @param alphabet
#' The pool of "letters" that word generation coes from.  By default,
#' it is the lowercase roman alphabet.
#' @param minwordlen,maxwordlen
#' The min/max length of words in the generated corpus.
#'
#' @return
#' A string.
#'
#' @examples
#' rcorpus(10)
#'
#' @importFrom stats runif
#'
#' @keywords Utility
#' @export
rcorpus = function(nwords=50, alphabet=letters, minwordlen=1, maxwordlen=6)
{
  check.is.posint(nwords)
  check.is.strings(alphabet)
  check.is.posint(minwordlen)
  check.is.posint(maxwordlen)

  if (minwordlen > maxwordlen)
    stop("Argument 'maxwordlen' must be at least 'minwordlen'.")

  sizes = as.integer(runif(nwords, minwordlen, maxwordlen+1))
  words = sapply(sizes, function(size) paste0(sample(alphabet, size=size, replace=TRUE), collapse=""))

  paste0(words, collapse=" ")
}


library(plotly, warn.conflicts = FALSE)

make_bin_bounds <- function(bins, axis_name) {
    bin_bounds <- get_bin_bounds(
        get_property_value(bins, axis_name)
    )

    names(bin_bounds)[1:2] <- c(
        paste(axis_name, "bin_left_bound", sep="_"),
        paste(axis_name, "bin_right_bound", sep="_")
    )

    return(bin_bounds)
}

visualize_as_3d_accumulative_mesh <- function(corpus) {
    data <- corpus$data
    manifest <- corpus$manifest

    bins <- get_property_value(manifest, 'bins')
    grid_bins = merge(make_bin_bounds(bins, 'x'), make_bin_bounds(bins, 'y'))

    bin_counts = c()
    x_bin_labels = c()
    y_bin_labels = c()

    for (i in 1:nrow(grid_bins)) {
        x_bin_left_boundary <- grid_bins[i, "x_bin_left_bound"]
        x_bin_right_boundary  <- grid_bins[i, "x_bin_right_bound"]

        y_bin_left_boundary <- grid_bins[i, "y_bin_left_bound"]
        y_bin_right_boundary  <- grid_bins[i, "y_bin_right_bound"]

        bin_counts[i] = nrow(
            data[
                which(
                    data$x > x_bin_left_boundary &
                    data$x <= x_bin_right_boundary &
                    data$y > y_bin_left_boundary &
                    data$y <= y_bin_right_boundary
                ),
            ]
        )

        x_bin_labels[i] = paste("(", x_bin_left_boundary, ";", x_bin_right_boundary, "]", sep="")
        y_bin_labels[i] = paste("(", y_bin_left_boundary, ";", y_bin_right_boundary, "]", sep="")
    }

    grid_bins$z <- bin_counts
    grid_bins$x_bin_labels <- x_bin_labels
    grid_bins$y_bin_labels <- y_bin_labels

    grid_bins %>% plot_ly(x = ~x_bin_labels, y = ~y_bin_labels, z = ~z, width = 1024, height = 720, type="mesh3d") %>% layout(
        scene = list(
            xaxis = list(title = manifest['labels'][[1]]['x-axis'][[1]]),
            yaxis = list(title = manifest['labels'][[1]]['y-axis'][[1]]),
            zaxis = list(title = manifest['labels'][[1]]['z-axis'][[1]])
        )
    ) %>% return
}


###############################################################
# Function to create Variable Selection using only SVD based
# analysis.  Variables are selected based on the Total
# Variability of any Normally-scaled variable
# given a Dataset
#
# Usage: selectVariablesViaSVD ( formulaForSVD ,
#                                inputForSVD ,
#                                feedback = FALSE ,
#                                varianceExplainedCutoff=0.90,
#                                minSignificanceEigenVectors = 0.20
#                               )
#
# Copyright (c) 2020 Oracle Corporation
# The Universal Permissive License (UPL), Version 1.0
#
# https://oss.oracle.com/licenses/upl/
#
###############################################################

##########################################################
### VARIABLE SELECTION WITH SINGLE VALUE DECOMPOSITION ###
### WITH SUPPORT FOR NUMERICALS AND FACTORS            ###
### ONLY BASED ON OVERALL VARIABILITY, NOT THE TARGET  ###
##########################################################

### Principal Components Analysis for Variable Selection

## INPUT IS ORIGINAL DATASET AND FORMULA
## OPTIONAL INPUTS ARE: CUMULATIVE PERCENT VARIANCE EXPLANATION, CORRELATION
selectVariablesViaSVD <- function(formulaForSVD,
                                  inputForSVD,
                                  feedback=FALSE,
                                  varianceExplainedCutoff=0.90 ,
                                  minSignificanceEigenVectors = 0.20 )
{

  formulaForSVD <- paste0('~ ',gsub(".*~","",Reduce(paste, deparse(formulaForSVD))))

  if (!(grepl(Reduce(paste, deparse(formulaForSVD)),"-1"))) {
    formulaForSVD <- paste0(formulaForSVD," -1")
  }

  if (grepl(feedback, "FULL", fixed = TRUE))
  {verbose_user <- TRUE
  } else {verbose_user <- FALSE}

  dmm <- orch.model.matrix(formulaForSVD, data=inputForSVD,
                           type = 'dmm', factorMode = "none",
                           verbose = verbose_user)

  eigenVectorNames <- dmm$getCoefName()
  if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) {
    cat('\n')
    cat(paste0('\n ',length(eigenVectorNames),' total Eigenvector Levels\n'))
    print(eigenVectorNames)
  }

  # Build the PCA Model asking for 10 Components

  # Need to scale variables first.
  scaledData <- orch.df.scale(data=inputForSVD, method = 'unitization_zero_minimum')
  # Review the Scaled Data
  scaledData$show(5L)

  # Run the PCA requesting up to 100 Components
  model_dspca <- orch.dspca(formula = formulaForSVD, data=scaledData,
                            k = min(length(eigenVectorNames),100),
                            formU = FALSE,
                            verbose = verbose_user)

  # Get the coefficients and output
  coef_pca <- coef(model_dspca)

  # Capture Partial Eigenvalues
  eigenValues <- coef_pca$s

  # Number of computed SVD Components
  numComputedComponents <- length(eigenValues)

  # IF necessary, let's complement the rest of the estimated Eigenvalues
  # by using an Exponential Decay (-log) to simulate the rest of the Eigenvalues
  if (numComputedComponents < length(eigenVectorNames)) {
    numTotalVariables <- length(eigenVectorNames)
    # Build the Log Range necessary based on Number of Eigenvalues
    logRange <- abs(-log(numTotalVariables-numComputedComponents))
    # Fill-in the rest of the Eigenvalues with the decay values which go to 0.
    eigenValues[(numComputedComponents+1):numTotalVariables] <- -log(1:(numTotalVariables-numComputedComponents))*
      eigenValues[numComputedComponents]/logRange+
      eigenValues[numComputedComponents]
    # Preview the Eigenvalues + Computed numbers
    if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) {
      cat('\n')
      cat(paste0('\n ',numComputedComponents,' Total Eigenvalues + Computed Eigenvalues \n'))
      print(eigenValues)
    }
  } else {
    # Preview the Eigenvalues numbers
    if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) {
      cat('\n')
      cat(paste0('\n ',numComputedComponents,' Total Eigenvalues \n'))
      print(eigenValues)
    }

  }

  # Compute the proportion of variance explained by each of the original Eigenvalues
  propVarianceExplainedEigenValues <- eigenValues^2/sum(eigenValues^2)
  # Preview the Eigenvalues numbers
  if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) {
    cat('\n')
    cat(paste0('\n ',length(propVarianceExplainedEigenValues),
               ' Proportions of Variance Explained by Eigenvalues and Scree Plot \n'))
    print(propVarianceExplainedEigenValues)
    plot(propVarianceExplainedEigenValues)
  }

  # Evaluate the cumulative Sum of the Variance Explained
  evaluationVariance <- cumsum(propVarianceExplainedEigenValues)
  EigenvaluesIdx <- which(evaluationVariance<=varianceExplainedCutoff)
  reducedEigenvaluesIdx <- c(EigenvaluesIdx, (length(EigenvaluesIdx)+1))

  if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) {
    cat('\n')
    cat(paste0('\n ',length(reducedEigenvaluesIdx),
               ' Reduced Number of Eigenvalues with a minimum of ',
               varianceExplainedCutoff*100,' % of Total Cumulative Variance \n'))
    print(formatC(propVarianceExplainedEigenValues[reducedEigenvaluesIdx],format='fg', digits=4))
    print(formatC(evaluationVariance[reducedEigenvaluesIdx],format='fg', digits=4))
  }

  # Capture the final Eigenvectors
  eigenVectors <- as.matrix(coef_pca$V)
  # Apply the names of the Vectors
  row.names(eigenVectors) <- eigenVectorNames

  # From EigenVectors, select the Reduced Set
  significantVectors <- eigenVectors[,1:length(reducedEigenvaluesIdx)]

  finalListSignificantLevels <- character()
  for (x in 1:length(eigenVectorNames)) {
    if (any(abs(significantVectors[x,]) >= minSignificanceEigenVectors)) {
      finalListSignificantLevels <- rbind(finalListSignificantLevels,as.character(eigenVectorNames[x]))
    }
  }
  finalListSignificantLevels <- as.character(finalListSignificantLevels)

  # Print the list of Levels found significant
  if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) {
    cat('\n')
    cat(paste0('\n ',length(finalListSignificantLevels),
               ' Reduced Number of Levels \n'))
    print(as.character(finalListSignificantLevels))
  }
  originalColumnNames <- scaledData$columns()

  # Look for the matching Columns used from the original Dataset
  matchingCols <- as.data.frame(sapply(originalColumnNames, grepl,
                                       as.character(finalListSignificantLevels),
                                       ignore.case=TRUE))

  # Get the final list of significant columns
  finalListSignificantVars <- colnames(matchingCols[,(colSums(matchingCols)>0)])

  if (grepl(feedback, "FULL|TRUE", fixed = TRUE)) {
    cat('\n')
    cat(paste0('\n ',length(finalListSignificantVars),
               ' Reduced Set of Variables \n'))
    print(as.character(finalListSignificantVars))
  }

  return(as.character(finalListSignificantVars))

}


# Day 11: Dumbo Octopus

get_day11_input_path <- function() {
    paste(getwd(), "/2021/Day 11/Day11_input.txt", sep = "")
}

part1 <- function() {
    readings <- readLines(get_day11_input_path())

    cave_rows <- length(readings)
    cave_cols <- nchar(readings[1])
    cave <- matrix(ncol = cave_cols)[-1, ]
    num_steps <- 100
    total_flashes <- 0

    for (i in seq_len(length(readings))) {
        cave <- rbind(cave, strtoi(unlist(strsplit(readings[i], ""))))
    }

    for (i in 1:num_steps) {
        cave <- cave + 1
        ready_to_flash <- which(cave > 9, arr.ind = TRUE)

        if (length(ready_to_flash) > 0) {
            total_flashes <- total_flashes + length(ready_to_flash) / 2
            cave[ready_to_flash] <- 0

            while (length(ready_to_flash) > 0) {
                adj_octs <- get_adj_points(ready_to_flash[1, 1],
                                            ready_to_flash[1, 2],
                                            cave_rows, cave_cols)

                adj_octs_to_inc <- rbind(
                                    which(cave > 0, arr.ind = TRUE),
                                    adj_octs)
                adj_octs_to_inc <- adj_octs_to_inc[duplicated(adj_octs_to_inc),
                                                    ,
                                                    drop = FALSE]

                cave[adj_octs_to_inc] <- cave[adj_octs_to_inc] + 1
                ready_to_flash <- ready_to_flash[-1, ]

                if (length(ready_to_flash) > 0) {
                    ready_to_flash <- rbind(ready_to_flash)
                }

                adj_to_flash <- which(cave > 9, arr.ind = TRUE)

                if (length(adj_to_flash) > 0) {
                    total_flashes <- total_flashes + length(adj_to_flash) / 2
                    cave[adj_to_flash] <- 0
                    ready_to_flash <- rbind(ready_to_flash, adj_to_flash)
                }
            }
        }
    }
    print(cave)
    print(total_flashes)
}

part2 <- function() {
    readings <- readLines(get_day11_input_path())

    cave_rows <- length(readings)
    cave_cols <- nchar(readings[1])
    cave <- matrix(ncol = cave_cols)[-1, ]
    total_flashes <- 0
    num_steps <- 0
    super_flash <- FALSE

    for (i in seq_len(length(readings))) {
        cave <- rbind(cave, strtoi(unlist(strsplit(readings[i], ""))))
    }

    while (!super_flash) {
        num_steps <- num_steps + 1
        cave <- cave + 1
        ready_to_flash <- which(cave > 9, arr.ind = TRUE)

        if (length(ready_to_flash) > 0) {
            total_flashes <- total_flashes + length(ready_to_flash) / 2
            cave[ready_to_flash] <- 0

            while (length(ready_to_flash) > 0) {
                adj_octs <- get_adj_points(ready_to_flash[1, 1],
                                            ready_to_flash[1, 2],
                                            cave_rows, cave_cols)

                adj_octs_to_inc <- rbind(
                                    which(cave > 0, arr.ind = TRUE),
                                    adj_octs)
                adj_octs_to_inc <- adj_octs_to_inc[duplicated(adj_octs_to_inc),
                                                    ,
                                                    drop = FALSE]

                cave[adj_octs_to_inc] <- cave[adj_octs_to_inc] + 1
                ready_to_flash <- ready_to_flash[-1, ]

                if (length(ready_to_flash) > 0) {
                    ready_to_flash <- rbind(ready_to_flash)
                }

                adj_to_flash <- which(cave > 9, arr.ind = TRUE)

                if (length(adj_to_flash) > 0) {
                    total_flashes <- total_flashes + length(adj_to_flash) / 2
                    cave[adj_to_flash] <- 0
                    ready_to_flash <- rbind(ready_to_flash, adj_to_flash)
                }
            }
        }
        super_flash <- sum(cave == 0) == cave_rows * cave_cols
    }
    print(cave)
    cat("Total flashes: ", total_flashes, "\n")
    cat("Steps til super flash: ", num_steps, "\n")
}

get_adj_points <- function(row, col, max_row, max_col) {
    adj_points <- matrix(ncol = 2)[-1, ]

    # Up Value
    if (row > 1) {
        adj_points <- rbind(adj_points, c(row - 1, col))
    }

    # Up Left Value
    if (row > 1 && col > 1) {
        adj_points <- rbind(adj_points, c(row - 1, col - 1))
    }

    # Up Right Value
    if (row > 1 && col < max_col) {
        adj_points <- rbind(adj_points, c(row - 1, col + 1))
    }

    # Down Value
    if (row < max_row) {
        adj_points <- rbind(adj_points, c(row + 1, col))
    }

    # Down Left Value
    if (row < max_row && col > 1) {
        adj_points <- rbind(adj_points, c(row + 1, col - 1))
    }

    # Down Right Value
    if (row < max_row && col < max_col) {
        adj_points <- rbind(adj_points, c(row + 1, col + 1))
    }

    # Left Value
    if (col > 1) {
        adj_points <- rbind(adj_points, c(row, col - 1))
    }

    # Right Value
    if (col < max_col) {
        adj_points <- rbind(adj_points, c(row, col + 1))
    }

    adj_points
}

part1()
part2()