 ZHBGVD Example Program Results

 Eigenvalues
       -6.6089    -2.0416     0.1603     1.7712


require(rms)
n <- 1e6
set.seed(8)
y <- sample(1:5, n, prob=c(.1, .2, .35, .35, .05), replace=TRUE)
table(y)
x <- sample(0:1, n, replace=TRUE)
means <- tapply(y, x, mean)
means
dd <- datadist(x); options(datadist='dd')
f <- orm(y ~ x)
M <- Mean(f)
lp <- Predict(f)   # same as Predict(f, x=0:1) here
lp
lp <- lp$yhat
lp
M(lp)
X <- predict(f, data.frame(x=0:1), type='x')
M(lp, X, conf.int=0.95)


normalize_counts <- function(features){
  # Normalize the matrix with the user counts
  # Summary  matrix
  cat("\nMotifs counts:", colSums(features))

  # Normalize user activity (make the analysis independent of number of posts)
  features <- t(apply(features, 1, function(x) x/sum(x)))

  #as.data.frame(t(apply(user.motifs, 1, function(x) x/sum(x))))
  cat("\nMotifs % of active users:", colSums(features))

  # Center and scale data
  # warning: it can create NA if feature count is 0
  features <- scale(features)
  cat("\nMotifs % of active users (z-score):", colSums(features))

  # Some NA because no active user has these neighborhoods.
  #user.motifs[is.na(user.motifs)] <- 0
  #features[,is.na(colSums(features))] <- 0
  return(features)
}


# Rebuttal figure 1c analysis of data and perform Test for Significance on EPSC
# amplitude across conditions
# Requires installation of packages: 'Skillings.Mack'
library(Skillings.Mack)
library(ggplot2)
df = read.csv('data/data_rebuttal_fig1.csv')

# subset for all DPDPE experiments with a baseline value
df_DPDPE = df[rep(!is.nan(df$effect_amplitude[grep('baseNaltrindole', df$conditionDPDPE)]),3),c('effect_amplitude', 'conditionDPDPE','cellDPDPE','expDPDPE')]
print('Naltrindole-DPDPE effect on baseline EPSC Skillings-Mack analysis')
Ski.Mack(df_DPDPE$effect_amplitude,df_DPDPE$conditionDPDPE,df_DPDPE$cellDPDPE)
print('Paired Wilcoxon signed rank test baseline vs Naltrindole')
# define here the two groups to compare
first_group = df_DPDPE$effect_amplitude[df_DPDPE$conditionDPDPE=='baseNaltrindole']
second_group = df_DPDPE$effect_amplitude[df_DPDPE$conditionDPDPE=='Naltrindole']
# Below is required to calculate n and statistic in a sequence independent way
# (first vs second group and second vs first group)
wilcox_antero = wilcox.test(first_group, second_group, paired = TRUE)
wilcox_retro = wilcox.test(second_group, first_group, paired = TRUE)
statistic = min(c(wilcox_antero$statistic, wilcox_retro$statistic))
diff = c(first_group-second_group)
n = length(na.omit(diff[diff != 0]))
print(paste('W(', n, ') = ', statistic, '. p = ', wilcox_antero$p.value))

print('Paired Wilcoxon signed rank test Naltrindole vs DPDPENaltrindole')
# define here the two groups to compare
first_group = df_DPDPE$effect_amplitude[df_DPDPE$conditionDPDPE=='Naltrindole']
second_group = df_DPDPE$effect_amplitude[df_DPDPE$conditionDPDPE=='DPDPENaltrindole']
# Below is required to calculate n and statistic in a sequence independent way
# (first vs second group and second vs first group)
wilcox_antero = wilcox.test(first_group, second_group, paired = TRUE)
wilcox_retro = wilcox.test(second_group, first_group, paired = TRUE)
statistic = min(c(wilcox_antero$statistic, wilcox_retro$statistic))
diff = c(first_group-second_group)
n = length(na.omit(diff[diff != 0]))
print(paste('W(', n, ') = ', statistic, '. p = ', wilcox_antero$p.value))

# Rebuttal figure 2 Analysis of data and perform plotting for DAMGO effect on
# thalamostriatal projections, to check whether there is a potential
# heterogeneity in the data that would suggest that inputs to D1 and D2 MSNs in
# the striatum may be modulated differently.
#import packages
library(ggplot2)
library(reshape2)
library(cowplot)
require(cowplot)
library(tidyverse)  # data manipulation
library(cluster)    # clustering algorithms
library(factoextra) # clustering visualization
library(dendextend) # for comparing two dendrograms
library(heatmap.plus) # clustering visualization
library(colorspace) # colors
library(RColorBrewer)
library(colorRamps)
library(gplots)
library(plyr)
library(Skillings.Mack)

df=read.csv('data/effectdataset.csv')
df$X = NULL
msn_df=subset(df, cellType=='MSN' & drugGroup==2)
setHook(packageEvent("grDevices", "onLoad"),
function(...) grDevices::X11.options(type='cairo'))
options(device='x11')
# subset data for thalamostriatal projections only (including MD and AM)
thal_df = subset(msn_df, (stimSource=='MD' | stimSource=='AM'))

# Rebuttal figure 2a, plot distribution of DAMGO effect on thalamostriatal
# projections.

ggplot(data=subset(thal_df, parameter=='amplitude'), aes(agonistEffect)) +
    geom_histogram(binwidth=25/4)+
    ylim(0,10)+
    xlim(0,100)

print('damgoEffect normality test')
shapiro.test(subset(thal_df, parameter=='amplitude')$agonistEffect)

# First re-organize the df to allow for subsetting
sthal_df = thal_df[,c(1:12, 20, 15)]
tthal_df <- subset(sthal_df, parameter=='amplitude')
colnames(tthal_df)[colnames(tthal_df)=='baseValue'] <- 'amplitude'
colnames(tthal_df)[colnames(tthal_df)=='agonistEffect'] <- 'damgoEffect'
tthal_df$parameter <- NULL
tthal_df$onset <- subset(sthal_df, parameter=='onset')$baseValue
tthal_df$risetime <- subset(sthal_df, parameter=='risetime')$baseValue
tthal_df$slope <- subset(sthal_df, parameter=='slope')$baseValue
tthal_df$onset2peakTime <- subset(sthal_df, parameter=='onset2peakTime')$baseValue
tthal_df$halfwidth <- subset(sthal_df, parameter=='halfwidth')$baseValue
tthal_df$decay <- subset(sthal_df, parameter=='decay')$baseValue
tthal_df$area <- subset(sthal_df, parameter=='area')$baseValue
tthal_df$chargeOAmplitude <- subset(sthal_df, parameter=='chargeOAmplitude')$baseValue
# fill out NA for onset of will20180705_732c002 with median of onset
tthal_df[tthal_df$cellID == 'will20180705_732c002',]$onset = median(tthal_df$onset, na.rm=TRUE)
rownames(tthal_df) = 1:nrow(tthal_df)
tthal_df_ref = tthal_df
tthal_df = tthal_df[,-12]

# Rebuttal figure 2b, plot distribution of baseline EPSC risetime vs DAMGO
# effect for thalamostriatal inputs. Perform linear regression to check for
# correlation between effect of DAMGO and risetime of the baseline EPSC.
ggplot(data=tthal_df_ref, aes(risetime, damgoEffect))+
    geom_point(size=5)+
    geom_smooth(method=lm, se=TRUE)+
    ylim(0,100)+
    xlim(0,3)
model = lm(risetime ~ damgoEffect, data=tthal_df_ref)
summary(model)

# Rebuttal figure 2c-d, define two subpopulations based on the baseline EPSC
# parameters. Based on those two subpopulations, test whether DAMGO effect on
# baseline is significantly different between the two populations.

#Generate a matrix with all parameters and make sure that no constant or zero
# columns are present
input_thal = tthal_df[12:ncol(tthal_df)]
which(apply(input_thal, 2, var)==0) # some variables have a constant or zero column, those need to be removed
input_thal = input_thal[, apply(input_thal, 2, var)!=0]
input_thal = scale(input_thal, center=TRUE, scale=TRUE) # center to the mean value and divide by standard deviation
# rownames(input_thal) = 1:nrow(input_thal)

# generate distance matrixes for the cells and parameters:
d_HCA_thal_param = get_dist(t(input_thal), method="pearson")
d_HCA_thal_cell = get_dist((input_thal), method="euclidean")
# Check that for both matrixes which clustering methods produces the strongest
# clusters
m <- c( "average", "single", "complete", "ward")
names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(d_HCA_thal_cell, method = x)$ac
}
map_dbl(m, ac)
m <- c( "average", "single", "complete", "ward")
names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(d_HCA_thal_param, method = x)$ac
}
map_dbl(m, ac)

# Based on the comparison of methods it turns out that Ward provides the strongest
# clusters for both cell and parameter clustering. So continue with Ward.
HCA_thal_cell = agnes(d_HCA_thal_cell, method = "ward")
HCA_thal_param = agnes(d_HCA_thal_param, method = "ward")
heatmap(t(input_thal), Colv=as.dendrogram(HCA_thal_cell), Rowv=as.dendrogram(HCA_thal_param), scale='none', labRow = TRUE, labCol = TRUE, xlab="cells", ylab="parameters")
HCA_thal_cell$order[1:15]
HCA_thal_param$order.lab

# Plot and test whether the two putative subpopulations have a difference in DAMGO effect on Baseline
tthal_df_ref$cluster = rep(1,nrow(tthal_df_ref))
tthal_df_ref[clust1,]$cluster = 1
tthal_df_ref[clust2,]$cluster = 2
ggplot(tthal_df_ref, aes(damgoEffect)) +
    geom_histogram(data=subset(tthal_df_ref,cluster==1), alpha = 0.5, fill='red', binwidth=25/4)+
    geom_histogram(data=subset(tthal_df_ref,cluster==2), alpha = 0.5, fill='blue',  binwidth=25/4)+
    ylim(0,10)
print('Warning, if alpha in the above plot is not allowed, this will stall the plotting and subsequent stats')
print('please remove the alpha=0.5 from the above ggplot section')
clust1 = HCA_thal_cell$order[1:16]
clust2 = HCA_thal_cell$order[17:nrow(input_thal)]
thal_clust1 = tthal_df_ref$damgoEffect[clust1]
thal_clust2 = tthal_df_ref$damgoEffect[clust2]
wilcox.test(x=thal_clust1,
            y=thal_clust2,
            paired=FALSE)


Call:
lm(formula = y ~ x)

Residuals:
1       2       3       4       5       6
3.3333 -0.6667 -2.6667 -2.6667 -0.6667  3.3333

Coefficients:
            Estimate Std. Error t value Pr(>|t|)
(Intercept)  -9.3333     2.8441  -3.282 0.030453 *
x             7.0000     0.7303   9.585 0.000662 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 3.055 on 4 degrees of freedom
Multiple R-squared: 0.9583,     Adjusted R-squared: 0.9478
F-statistic: 91.88 on 1 and 4 DF,  p-value: 0.000662

> par(mfrow=c(2, 2))     # Request 2x2 plot layout
> plot(lm_1)             # Diagnostic plot of regression model


library(Matrix)
a <- queens(8)
as(a[, 1], "pMatrix")


 C05AZJ Example Program Results

 Iterations

  X = 0.00000   FX =  1.0000E+00   IND = 2
  X = 1.00000   FX = -6.3212E-01   IND = 3
  X = 0.61270   FX = -7.0814E-02   IND = 4
  X = 0.56707   FX =  1.1542E-04   IND = 4
  X = 0.56714   FX = -9.4481E-07   IND = 4
  X = 0.56713   FX =  1.4727E-05   IND = 4
  X = 0.56714   FX = -9.4481E-07   IND = 4

 Solution

 X =  0.56714 Y =  0.56713


# This code computes the IR/IFR rates
# for COVID-19 pandemic in Saint Petersburg, Russia
# paper with Bayesian evidence synthesis
#
# Code builds on https://github.com/harlanhappydog/BayesianSeroMetaAnalysis
# by Campbell and Gustafson (2021, https://www.medrxiv.org/content/10.1101/2021.05.12.21256975v2)
library(data.table)
library(stringi)
library(stringr)
library(lubridate)
library(binom)
library(rjags)
library(hBayesDM)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

#######
# Load and prepare the estimated prevalence across waves
# (see the estimation code in analysis/wave*/estimate_prevalence_by_{model,variable}.r)
waves <- c(1, 1.5, 2, 3)

# Init an object to store the results
# of prevalence computations
perwave_prevalence_by_model_list <- list()

# Load the per-wave estimates and store them in one object
for(w in waves) {

	load(paste0("estimates/wave", w, "/prevalence_by_model.rdata"))

	perwave_prevalence_by_model_list[[ as.character(w) ]] <- prevalence_by_model

	rm(prevalence_by_model)

}

# Aggregate the results
perwave_prevalence_by_model <- rbindlist(perwave_prevalence_by_model_list, idcol = "wave")

# We are interested in per-wave 95% confidence intervals for ELISA Coronapass
# adjusted for non-response and test characteristics
model_data <- perwave_prevalence_by_model[ serotest == "IgA_or_G_or_M_testC" & prevalence_type == "univariate" & surveyweight == "no" & sensitivity != 1 & scenario == "basic", c("wave", "lowerbound", "upperbound")]
setnames(model_data, "wave", "k")

# Manually add wave start and end dates
model_data[ k == 1, start_date := ymd("2020-05-25") ]
model_data[ k == 1, end_date := ymd("2020-06-28") ]
model_data[ k == 1.5, start_date := ymd("2020-07-20") ]
model_data[ k == 1.5, end_date := ymd("2020-08-16") ]
model_data[ k == 2, start_date := ymd("2020-10-12") ]
model_data[ k == 2, end_date := ymd("2020-12-06") ]
model_data[ k == 3, start_date := ymd("2021-02-15") ]
model_data[ k == 3, end_date := ymd("2021-04-04") ]

# Manually add populations
## Adult population
model_data[ k %in% c(1, 1.5), p_k_adult := 4451025 ]
model_data[ k %in% c(2, 3), p_k_adult := 4439897 ]
#
model_data[ k %in% c(1, 1.5), p_k_all := 5398064 ]
model_data[ k %in% c(2, 3), p_k_all := 5384342 ]

#######
# Find the parameters of the binomial distribution that
# correspond to a given CI for seroprevalence (with given tolerance)

# Compute CIs space with all combinations
# of cc_k and t_k and their CI
ci_space <- CJ(cc_k = 1:1000, t_k = 2:1000)
ci_space <- ci_space[ cc_k < t_k]
# NB: the below takes time and memory
ci_space[, c("lower", "upper") := binom::binom.bayes(x = cc_k, n = t_k, type = "central", conf.level = 0.95, maxit = 200)[, c("lower", "upper")]]

search_binomial_parameters <- function(search_space, lowerbound, upperbound) {

	# Euclidean distance from the target
	search_space[, eucl_dist := sqrt((lower - lowerbound)^2 + (upper - upperbound)^2)]
	# Sort from smallest distance
	setorderv(search_space, "eucl_dist", 1)
	# Return the parameters producing the smallest distance
	smallest_distance_params <- unlist(search_space[1, c("cc_k", "t_k")])
	return(smallest_distance_params)

}

# Run and assign the corresponding values
model_data[, c("cc_k", "t_k") := NA_real_]

for(i in 1:nrow(model_data) ) {

	search_results <- search_binomial_parameters(search_space = ci_space,
												lowerbound = model_data[i]$lowerbound/100,
												upperbound = model_data[i]$upperbound/100)

	set(model_data, i = i, j = "cc_k", value = search_results["cc_k"])
	set(model_data, i = i, j = "t_k", value = search_results["t_k"])

}

# Clean up
rm(ci_space)
gc()

#model_data[, c("k", "lowerbound", "upperbound", "t_k", "cc_k")]
#     k lowerbound upperbound t_k cc_k
#1:   1        7.7       11.7 827   79
#2: 1.5        9.9       16.6 385   50
#3:   2       20.3       25.5 999  228
#4:   3       39.7       48.0 550  241

#######
# Get the data on COVID or excess deaths

# Daily covid deaths from stopcoronavirus.rf
stopcoronavirus_deaths <- fread("https://raw.githubusercontent.com/alexei-kouprianov/COVID-19.SPb/main/data/primary/covid.SPb.stopkoronavirus.rf.txt")
stopcoronavirus_deaths <- stopcoronavirus_deaths[, c("TIME", "d")]
setnames(stopcoronavirus_deaths, c("TIME", "d"), c("day", "covid_deaths"))
setorderv(stopcoronavirus_deaths, "day")

# Monthly excess deaths from https://doi.org/10.1111/1740-9713.01486
excess_deaths <- fread("https://raw.githubusercontent.com/dkobak/excess-mortality/main/russia_excess_deaths.csv", encoding = "UTF-8")[ V1 == "Санкт-Петербург"]
excess_deaths <- melt(excess_deaths, id.vars = "V1", variable.name = "month", value.name = "excess_deaths", variable.factor = F)
excess_deaths[, V1 := NULL]
excess_deaths[, month := gsub("Январь ", "01.01.", month)]
excess_deaths[, month := gsub("Февраль ", "01.02.", month)]
excess_deaths[, month := gsub("Март ", "01.03.", month)]
excess_deaths[, month := gsub("Апрель ", "01.04.", month)]
excess_deaths[, month := gsub("Май ", "01.05.", month)]
excess_deaths[, month := gsub("Июнь ", "01.06.", month)]
excess_deaths[, month := gsub("Июль ", "01.07.", month)]
excess_deaths[, month := gsub("Август ", "01.08.", month)]
excess_deaths[, month := gsub("Сентябрь ", "01.09.", month)]
excess_deaths[, month := gsub("Октябрь ", "01.10.", month)]
excess_deaths[, month := gsub("Ноябрь ", "01.11.", month)]
excess_deaths[, month := gsub("Декабрь ", "01.12.", month)]
excess_deaths[, month := dmy(month)]
setorderv(excess_deaths, "month")

# Compute the respective D^upper/lower_k for each wave
for(i in 1:nrow(model_data) ) {

	wave_start <- model_data$start_date[i]
	wave_end <- model_data$end_date[i]

	d_deaths_lower <- sum(stopcoronavirus_deaths[ day < wave_start + 14 ]$covid_deaths, na.rm = T)
	d_deaths_upper <- sum(stopcoronavirus_deaths[ day < wave_end + 14 ]$covid_deaths, na.rm = T)

	d_excess_lower <- sum(excess_deaths[ month <= floor_date(wave_start, "month") ]$excess_deaths, na.rm = T)
	d_excess_upper <- sum(excess_deaths[ month <= floor_date(wave_end, "month") ]$excess_deaths, na.rm = T)

	set(model_data, i = i, j = "d_deaths_lower", value = d_deaths_lower)
	set(model_data, i = i, j = "d_deaths_upper", value = d_deaths_upper)

	set(model_data, i = i, j = "d_excess_lower", value = d_excess_lower)
	set(model_data, i = i, j = "d_excess_upper", value = d_excess_upper)

}

#######
# Build and estimate the evidence synthesis model
# (borrows from https://github.com/harlanhappydog/BayesianSeroMetaAnalysis)

# Number of periods in the data
K <- nrow(model_data)

# JAGS model likelihood and summary
model_likelihood <- "

# Likelihood:

for(k in 1:K){
	cc[k] ~ dbin(ir[k], tests[k]);
	censor.index[k] ~ dinterval(deaths[k], c(deaths_lower[k], deaths_upper[k]))
	deaths[k] ~ dbin(ifr[k]*ir[k], pop[k]);
	cloglog(ir[k]) <- cloglog_ir[k];
	cloglog(ifr[k]) <- cloglog_ifr[k];

	cloglog_ir[k] ~ dnorm(beta, inv.var_sig);
	cloglog_ifr[k] ~ dnorm(theta, inv.var_tau);

}

# Summary:

g_IFR = theta;
IFR <- 1 - exp(-exp(g_IFR))
g_IR = beta;
IR <- 1 - exp(-exp(g_IR))
"

# Two types of priors
model_weakly_informative_priors <- "

# Weakly informative priors:
	icloglog_theta ~ dbeta(0.3, 30);
	icloglog_beta  ~ dbeta(1, 30);
	theta <- log(-log(1-icloglog_theta));
	beta  <- log(-log(1-icloglog_beta));
	inv.var_sig   <- (1/sigma)^2 ;
	inv.var_tau   <- (1/tau)^2 ;
	sigma     ~ dnorm(0, 1/10) T(0,);
	tau     ~ dnorm(0, 1/10) T(0,);

"

model_non_informative_priors <- "

# Non-informative priors:
	icloglog_theta ~ dunif(0, 1);
	icloglog_beta  ~ dunif(0, 1);
	theta <- log(-log(1-icloglog_theta));
	beta  <- log(-log(1-icloglog_beta));
	inv.var_sig   <- (1/sigma)^2 ;
	inv.var_tau   <- (1/tau)^2 ;
	sigma     ~ dnorm(0, 1/100) T(0,);
	tau     ~ dnorm(0, 1/100) T(0,);

"

# Gather into the full JAGS model statements
model_statement_weakly_priors <- paste0("model {", model_weakly_informative_priors, model_likelihood, "\n}")
model_statement_noninformative_priors <- paste0("model {", model_non_informative_priors, model_likelihood, "\n}")

# Build the models
## Weakly informative priors, official deaths
jags.model_weakly_priors_official_deaths <- jags.model(textConnection(model_statement_weakly_priors),
	data = list(
		K = K,
		tests = model_data$t_k,
		cc = model_data$cc_k,
		pop = model_data$p_k_adult,
		deaths_lower = model_data$d_deaths_lower,
		deaths_upper = model_data$d_deaths_upper,
		deaths = rep(NA, K),
		censor.index = rep(1, K)
	),
	n.chains = 5,
	n.adapt = 5000,
	inits = list(
		deaths = round(apply(cbind(model_data$d_deaths_lower, model_data$d_deaths_upper), 1, mean))
	)
)

## Weakly informative priors, excess deaths
jags.model_weakly_priors_excess_deaths <- jags.model(textConnection(model_statement_weakly_priors),
	data = list(
		K = K,
		tests = model_data$t_k,
		cc = model_data$cc_k,
		pop = model_data$p_k_adult,
		deaths_lower = model_data$d_excess_lower,
		deaths_upper = model_data$d_excess_upper,
		deaths = rep(NA, K),
		censor.index = rep(1, K)
	),
	n.chains = 5,
	n.adapt = 5000,
	inits = list(
		deaths = round(apply(cbind(model_data$d_excess_lower, model_data$d_excess_upper), 1, mean))
	)
)

# Non-informative priors, official deaths
jags.model_noninformative_priors_official_deaths <- jags.model(textConnection(model_statement_noninformative_priors),
	data = list(
		K = K,
		tests = model_data$t_k,
		cc = model_data$cc_k,
		pop = model_data$p_k_adult,
		deaths_lower = model_data$d_deaths_lower,
		deaths_upper = model_data$d_deaths_upper,
		deaths = rep(NA, K),
		censor.index = rep(1, K)
	),
	n.chains = 5,
	n.adapt = 5000,
	inits = list(
		deaths = round(apply(cbind(model_data$d_deaths_lower, model_data$d_deaths_upper), 1, mean))
	)
)

# Non-informative priors, excess deaths
jags.model_noninformative_priors_excess_deaths <- jags.model(textConnection(model_statement_noninformative_priors),
	data = list(
		K = K,
		tests = model_data$t_k,
		cc = model_data$cc_k,
		pop = model_data$p_k_adult,
		deaths_lower = model_data$d_excess_lower,
		deaths_upper = model_data$d_excess_upper,
		deaths = rep(NA, K),
		censor.index = rep(1, K)
	),
	n.chains = 5,
	n.adapt = 5000,
	inits = list(
		deaths = round(apply(cbind(model_data$d_excess_lower, model_data$d_excess_upper), 1, mean))
	)
)

## Weakly informative priors, excess deaths, all population
jags.model_weakly_priors_excess_deaths_all_pop <- jags.model(textConnection(model_statement_weakly_priors),
	data = list(
		K = K,
		tests = model_data$t_k,
		cc = model_data$cc_k,
		pop = model_data$p_k_all,
		deaths_lower = model_data$d_excess_lower,
		deaths_upper = model_data$d_excess_upper,
		deaths = rep(NA, K),
		censor.index = rep(1, K)
	),
	n.chains = 5,
	n.adapt = 5000,
	inits = list(
		deaths = round(apply(cbind(model_data$d_excess_lower, model_data$d_excess_upper), 1, mean))
	)
)

params <- c("theta", "ir", "ifr", "tau", "sigma", "IFR", "IR")

# Set the number of iterations
MCMCn <- 2e6

# Sample from the models

sample_weakly_priors_official_deaths <- coda.samples(jags.model_weakly_priors_official_deaths, params,
				n.iter = MCMCn, thin = 100, n.adapt = round(MCMCn*0.20))

sample_weakly_priors_excess_deaths <- coda.samples(jags.model_weakly_priors_excess_deaths, params,
				n.iter = MCMCn, thin = 100, n.adapt = round(MCMCn*0.20))

sample_noninformative_priors_official_deaths <- coda.samples(jags.model_noninformative_priors_official_deaths, params,
				n.iter = MCMCn, thin = 100, n.adapt = round(MCMCn*0.20))

sample_noninformative_priors_excess_deaths <- coda.samples(jags.model_noninformative_priors_excess_deaths, params,
				n.iter = MCMCn, thin = 100, n.adapt = round(MCMCn*0.20))

sample_weakly_priors_excess_deaths_all_pop <- coda.samples(jags.model_weakly_priors_excess_deaths_all_pop, params,
				n.iter = MCMCn, thin = 100, n.adapt = round(MCMCn*0.20))

# Save the estimation results
save(sample_weakly_priors_official_deaths, file = "estimates/pandemic_course_paper/sample_weakly_priors_official_deaths.rdata", compress = "gzip")
save(sample_weakly_priors_excess_deaths, file = "estimates/pandemic_course_paper/sample_weakly_priors_excess_deaths.rdata", compress = "gzip")
save(sample_noninformative_priors_official_deaths, file = "estimates/pandemic_course_paper/sample_noninformative_priors_official_deaths.rdata", compress = "gzip")
save(sample_noninformative_priors_excess_deaths, file = "estimates/pandemic_course_paper/sample_noninformative_priors_excess_deaths.rdata", compress = "gzip")
save(sample_weakly_priors_excess_deaths_all_pop, file = "estimates/pandemic_course_paper/sample_weakly_priors_excess_deaths_all_pop.rdata", compress = "gzip")

#######
# Report the results
load("estimates/pandemic_course_paper/sample_weakly_priors_official_deaths.rdata")
load("estimates/pandemic_course_paper/sample_weakly_priors_excess_deaths.rdata")
load("estimates/pandemic_course_paper/sample_noninformative_priors_official_deaths.rdata")
load("estimates/pandemic_course_paper/sample_noninformative_priors_excess_deaths.rdata")
load("estimates/pandemic_course_paper/sample_weakly_priors_excess_deaths_all_pop.rdata")

# Model summary function
summary_md_ci <- function(xx, samps) {
	c(	md = summary(samps)$quantiles[xx, "50%"],
		lower = HDIofMCMC(unlist(((samps[[1]])[,xx])), credMass = 0.95)[1],
		higher = HDIofMCMC(unlist(((samps[[1]])[,xx])), credMass = 0.95)[2]
	)
}

# Create the confidence intervals
ir_irf_results_object <- CJ(k = 1:K, type = c("ir", "ifr"), deaths = c("official", "excess"), priors = c("weakly", "noninformative"), population = c("", "_all_pop"))
ir_irf_results_object[, c("pointest", "lower", "upper", "ir_overall", "ir_overall_lower", "ir_overall_upper", "ifr_overall", "ifr_overall_lower", "ifr_overall_upper") := NA_real_ ]

for(i in 1:nrow(ir_irf_results_object)) {

	# Compute the confidence intervals programmatically
	results_object_name <- paste0("sample_", ir_irf_results_object$priors[i], "_priors_", ir_irf_results_object$deaths[i], "_deaths", ir_irf_results_object$population[i])

	if( exists(results_object_name) ) {

		# Example: summary_md_ci('ir[1]', sample_weakly_priors_official_deaths)
		# Per-wave IR/IFR
		eval(parse(text = paste0("res <- summary_md_ci('", ir_irf_results_object$type[i], "[", ir_irf_results_object$k[i], "]', ", results_object_name, ")")))
		set(ir_irf_results_object, i = i, j = "pointest", value = res["md"])
		set(ir_irf_results_object, i = i, j = "lower", value = res["lower"])
		set(ir_irf_results_object, i = i, j = "upper", value = res["higher"])
		# Overall IR
		eval(parse(text = paste0("ir_overall <- summary_md_ci('IR', ", results_object_name, ")")))
		set(ir_irf_results_object, i = i, j = "ir_overall", value = ir_overall["md"])
		set(ir_irf_results_object, i = i, j = "ir_overall_lower", value = ir_overall["lower"])
		set(ir_irf_results_object, i = i, j = "ir_overall_upper", value = ir_overall["higher"])
		# Overall IFR
		eval(parse(text = paste0("ifr_overall <- summary_md_ci('IFR', ", results_object_name, ")")))
		set(ir_irf_results_object, i = i, j = "ifr_overall", value = ifr_overall["md"])
		set(ir_irf_results_object, i = i, j = "ifr_overall_lower", value = ifr_overall["lower"])
		set(ir_irf_results_object, i = i, j = "ifr_overall_upper", value = ifr_overall["higher"])

	}
}

# Fix the waves
ir_irf_results_object[, k := as.numeric(k)]
ir_irf_results_object[ k == 2, k := 1.5 ]
ir_irf_results_object[ k == 3, k := 2 ]
ir_irf_results_object[ k == 4, k := 3 ]

# To percentages and round
ir_irf_results_object[, c("pointest", "lower", "upper", "ir_overall", "ir_overall_lower", "ir_overall_upper", "ifr_overall", "ifr_overall_lower", "ifr_overall_upper") := lapply(.SD, function(x) round(100*x, 2)), .SDcols = c("pointest", "lower", "upper", "ir_overall", "ir_overall_lower", "ir_overall_upper", "ifr_overall", "ifr_overall_lower", "ifr_overall_upper")]

# Remove empty
ir_irf_results_object <- ir_irf_results_object[!is.na(pointest)]

# Save point
save(ir_irf_results_object, file = "estimates/pandemic_course_paper/ir_irf_results_object.rdata", compress = "gzip")

############################################################################
# Per agegroup-sex analysis

# Load the per-age group/sex seroprevalence estimates
# created by estimate_prevalence_by_agegroup_sex.r
load("estimates/pandemic_course_paper/prevalence_by_agegroup_sex.rdata")
model_data_agesex <- prevalence_by_agegroup_sex[ prevalence_type == "univariate" ]

# Create new CI search space
# with all combinations
# of cc_k and t_k and their CI
ci_space <- CJ(cc_k = 1:1000, t_k = 2:1000)
ci_space <- ci_space[ cc_k < t_k]
# NB: the below takes time and memory
ci_space[, c("lower", "upper") := binom::binom.bayes(x = cc_k, n = t_k, type = "central", conf.level = 0.95, maxit = 200)[, c("lower", "upper")]]

# Run and assign the corresponding values
model_data_agesex[, c("cc_k", "t_k") := NA_real_]

for(i in 1:nrow(model_data_agesex) ) {

	search_results <- search_binomial_parameters(search_space = ci_space,
												lowerbound = model_data_agesex[i]$lowerbound/100,
												upperbound = model_data_agesex[i]$upperbound/100)

	set(model_data_agesex, i = i, j = "cc_k", value = search_results["cc_k"])
	set(model_data_agesex, i = i, j = "t_k", value = search_results["t_k"])

}

# Add population data
model_data_agesex[ agegroup == "18-29" & male == 0, p_k := 419516]
model_data_agesex[ agegroup == "30-39" & male == 0, p_k := 543892]
model_data_agesex[ agegroup == "40-49" & male == 0, p_k := 432308]
model_data_agesex[ agegroup == "50-59" & male == 0, p_k := 418371]
model_data_agesex[ agegroup == "60-69" & male == 0, p_k := 437588]
model_data_agesex[ agegroup == "70+" & male == 0, p_k := 482856]

model_data_agesex[ agegroup == "18-29" & male == 1, p_k := 413098]
model_data_agesex[ agegroup == "30-39" & male == 1, p_k := 527930]
model_data_agesex[ agegroup == "40-49" & male == 1, p_k := 404853]
model_data_agesex[ agegroup == "50-59" & male == 1, p_k := 342243]
model_data_agesex[ agegroup == "60-69" & male == 1, p_k := 281789]
model_data_agesex[ agegroup == "70+" & male == 1, p_k := 241605]

# Add excess deaths data
model_data_agesex[ agegroup == "18-29" & male == 0, d_excess_lower := 0]
model_data_agesex[ agegroup == "18-29" & male == 0, d_excess_upper := 36]
model_data_agesex[ agegroup == "30-39" & male == 0, d_excess_lower := 57]
model_data_agesex[ agegroup == "30-39" & male == 0, d_excess_upper := 182]
model_data_agesex[ agegroup == "40-49" & male == 0, d_excess_lower := 167]
model_data_agesex[ agegroup == "40-49" & male == 0, d_excess_upper := 341]
model_data_agesex[ agegroup == "50-59" & male == 0, d_excess_lower := 367]
model_data_agesex[ agegroup == "50-59" & male == 0, d_excess_upper := 596]
model_data_agesex[ agegroup == "60-69" & male == 0, d_excess_lower := 1412]
model_data_agesex[ agegroup == "60-69" & male == 0, d_excess_upper := 1755]
model_data_agesex[ agegroup == "70+" & male == 0, d_excess_lower := 7679]
model_data_agesex[ agegroup == "70+" & male == 0, d_excess_upper := 8509]

model_data_agesex[ agegroup == "18-29" & male == 1, d_excess_lower := 0]
model_data_agesex[ agegroup == "18-29" & male == 1, d_excess_upper := 105]
model_data_agesex[ agegroup == "30-39" & male == 1, d_excess_lower := 161]
model_data_agesex[ agegroup == "30-39" & male == 1, d_excess_upper := 352]
model_data_agesex[ agegroup == "40-49" & male == 1, d_excess_lower := 528]
model_data_agesex[ agegroup == "40-49" & male == 1, d_excess_upper := 791]
model_data_agesex[ agegroup == "50-59" & male == 1, d_excess_lower := 856]
model_data_agesex[ agegroup == "50-59" & male == 1, d_excess_upper := 1167]
model_data_agesex[ agegroup == "60-69" & male == 1, d_excess_lower := 2111]
model_data_agesex[ agegroup == "60-69" & male == 1, d_excess_upper := 2527]
model_data_agesex[ agegroup == "70+" & male == 1, d_excess_lower := 5330]
model_data_agesex[ agegroup == "70+" & male == 1, d_excess_upper := 5928]

# Add the row index
model_data_agesex[, k := 1:.N ]

# Define the models
K <- nrow(model_data_agesex)

# Set the number of iterations
MCMCn <- 2e6

# Model parameters
params <- c("theta", "ir", "ifr", "tau", "sigma", "IFR", "IR")

## Weakly informative priors, excess deaths
jags.model_weakly_priors_excess_deaths_agesex <- jags.model(textConnection(model_statement_weakly_priors),
	data = list(
		K = K,
		tests = model_data_agesex$t_k,
		cc = model_data_agesex$cc_k,
		pop = model_data_agesex$p_k,
		deaths_lower = model_data_agesex$d_excess_lower,
		deaths_upper = model_data_agesex$d_excess_upper,
		deaths = rep(NA, K),
		censor.index = rep(1, K)
	),
	n.chains = 5,
	n.adapt = 5000,
	inits = list(
		deaths = round(apply(cbind(model_data_agesex$d_excess_lower, model_data_agesex$d_excess_upper), 1, mean))
	)
)

# Non-informative priors, excess deaths
jags.model_noninformative_priors_excess_deaths_agesex <- jags.model(textConnection(model_statement_noninformative_priors),
	data = list(
		K = K,
		tests = model_data_agesex$t_k,
		cc = model_data_agesex$cc_k,
		pop = model_data_agesex$p_k,
		deaths_lower = model_data_agesex$d_excess_lower,
		deaths_upper = model_data_agesex$d_excess_upper,
		deaths = rep(NA, K),
		censor.index = rep(1, K)
	),
	n.chains = 5,
	n.adapt = 5000,
	inits = list(
		deaths = round(apply(cbind(model_data_agesex$d_excess_lower, model_data_agesex$d_excess_upper), 1, mean))
	)
)

# Sample from the models
sample_weakly_priors_excess_deaths_agesex <- coda.samples(jags.model_weakly_priors_excess_deaths_agesex, params,
				n.iter = MCMCn, thin = 100, n.adapt = round(MCMCn*0.20))

sample_noninformative_priors_excess_deaths_agesex <- coda.samples(jags.model_noninformative_priors_excess_deaths_agesex, params,
				n.iter = MCMCn, thin = 100, n.adapt = round(MCMCn*0.20))

# Save the estimation results
save(sample_weakly_priors_excess_deaths_agesex, file = "estimates/pandemic_course_paper/sample_weakly_priors_excess_deaths_agesex.rdata", compress = "gzip")
save(sample_noninformative_priors_excess_deaths_agesex, file = "estimates/pandemic_course_paper/sample_noninformative_priors_excess_deaths_agesex.rdata", compress = "gzip")

#######
# Report the results
load("estimates/pandemic_course_paper/sample_weakly_priors_excess_deaths_agesex.rdata")
load("estimates/pandemic_course_paper/sample_noninformative_priors_excess_deaths_agesex.rdata")

# Model summary function
summary_md_ci <- function(xx, samps) {
	c(	md = summary(samps)$quantiles[xx, "50%"],
		lower = HDIofMCMC(unlist(((samps[[1]])[,xx])), credMass = 0.95)[1],
		higher = HDIofMCMC(unlist(((samps[[1]])[,xx])), credMass = 0.95)[2]
	)
}

# Create the confidence intervals
ir_irf_agesex_results_object <- CJ(k = 1:K, type = c("ir", "ifr"), deaths = c("excess"), priors = c("weakly", "noninformative"))
ir_irf_agesex_results_object[, c("pointest", "lower", "upper") := NA_real_ ]

# Add agegroup and sex
ir_irf_agesex_results_object <- merge(ir_irf_agesex_results_object, model_data_agesex[, c("k", "agegroup", "male"), with = F], by = "k", all.x = T, all.y = F)

for(i in 1:nrow(ir_irf_agesex_results_object)) {

	# Compute the confidence intervals programmatically
	results_object_name <- paste0("sample_", ir_irf_agesex_results_object$priors[i], "_priors_", ir_irf_agesex_results_object$deaths[i], "_deaths_agesex")

	if( exists(results_object_name) ) {

		# Example: summary_md_ci('ir[1]', sample_weakly_priors_official_deaths)
		# Per-wave IR/IFR
		eval(parse(text = paste0("res <- summary_md_ci('", ir_irf_agesex_results_object$type[i], "[", ir_irf_agesex_results_object$k[i], "]', ", results_object_name, ")")))
		set(ir_irf_agesex_results_object, i = i, j = "pointest", value = res["md"])
		set(ir_irf_agesex_results_object, i = i, j = "lower", value = res["lower"])
		set(ir_irf_agesex_results_object, i = i, j = "upper", value = res["higher"])

	}
}

# To percentages and round
ir_irf_agesex_results_object[, c("pointest", "lower", "upper") := lapply(.SD, function(x) round(100*x, 2)), .SDcols = c("pointest", "lower", "upper")]

# Remove empty
ir_irf_agesex_results_object <- ir_irf_agesex_results_object[!is.na(pointest)]

# Save point
save(ir_irf_agesex_results_object, file = "estimates/pandemic_course_paper/ir_irf_agesex_results_object.rdata", compress = "gzip")


source("init if necessary.r")

library(dplyr)

# number/proportion of Saami herders we have herd size data for
people %>%
  filter(Pop %in% c("karasjok", "kautokeino")) %>%
  mutate(HerdData = ifelse(is.na(HerdSize), 0, 1)) %>%
  summarise(Data_for = sum(HerdData), N = n(), percent = (sum(HerdData) / n()) * 100)

# minimum herd sizes in each site
people %>%
  group_by(Pop) %>%
  filter(HerdSize > 0) %>%
  summarise(min_herd = min(HerdSize))

# sex ratios by country
# we don't know the gender of one person in Kautokeino - they are coded as 'o' for 'other'
people %>%
  mutate(Country = ifelse(str_sub(Pop, start=1, end=1) == "k", "Norway", "China")) %>%
  group_by(Country, Sex) %>%
  ftable(Sex ~ Country, data=.) %>%
  prop.table(margin=1) %>%
  round(4)

# sex ratios by site
people %>%
  group_by(Pop, Sex) %>%
  ftable(Sex ~ Pop, data=.) %>%
  prop.table(margin=1) %>%
  round(4)

# age histograms
people %>%
  mutate(Country = ifelse(str_sub(Pop, start=1, end=1) == "k", "Norway", "China")) %>%
  ggplot(aes(x=Age)) +
  geom_histogram(binwidth=5) +
  facet_wrap(~Country, scales="free_y")


#'@title calcHMWakeFraction
#'
#'@description Calculate wake fraction (\code{wakeFraction}) (dimensionless)
#'using the Holtrop & Mennen method.
#'
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param wettedSA Wetted hull surface area (vector of numericals, m^2) (see
#' \code{\link{calcHMWettedSA}})
#'@param maxDraft Maximum summer load line draft (vector of numericals, m)
#'@param nProp Number of propellers (vector of numericals, see
#' \code{\link{calcPropNum}})
#'@param lwl Waterline Length (vector of numericals, m) (see \code{\link{calclwl}})
#'@param propDiam Propeller diameter (vector of numericals, m) (see
#' \code{\link{calcPropDia}})
#'@param formFactor Form factor (1+k) (vector of numericals, dimensionless) (see
#' \code{\link{calcHMFormFactor}})
#'@param Cf Frictional resistance coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCf}})
#'@param Ca Incremental hull (roughness) resistance coefficient (vector of
#' numericals, dimensionless) (see \code{\link{calcHMCa}})
#'@param Cbw Waterline block coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCbw}})
#'@param Cp Prismatic coefficient (vector of numericals, dimensionless) (see
#' \code{\link{calcCp}})
#'@param Cm Midship section coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCm}})
#'@param aftDraft Aft draft (deviation from actual draft indicates trim)
#' (vector of numericals, m)
#'@param Cstern Afterbody form coefficient: \itemize{\item V-shaped Hull = -10
#'         \item U-Shaped Hull =  10
#'         \item Normal Hull = 0 (default)}
#' Can supply either a vector of numericals, a single number, or rely on the default
#'@param lcb Longitudinal position of center of buoyancy (vector of numericals,
#' see \code{\link{calclcb}})
#'
#'@details
#' "The speed of advance of the propeller relative to the water in which it is working is
#'  lower than the observed speed of the vessel. This difference in speed,
#'  expressed as a percentage of the ship speed, is known as the wake fraction coefficient".
#'  \url{https://www.wartsila.com/encyclopedia/term/wake-fraction-coefficient}
#'
#'Wake fraction is a component of hull efficiency as well as a component of
#'propeller efficiency.
#'
#'Actual draft is typically obtained from sources such as AIS messages or ship
#'records.
#'
#'Note: In "A Statistical Re-Analysis of Resistance and Propulsion Data", the
#'authors re-analyze with the inclusion of Series 64 hull forms for a total of
#'334 models included in the analysis. They suggest an update of the single
#'screw wake fraction equation but that the original equations should be used
#'for twin screw ships.
#'
#'Viscous resistance coefficient: \code{Cv = (1+k) * Cf + Ca}
#'
#'We are assuming here that \code{1+k = 1+k_1} from \code{\link{calcHMFormFactor}}.
#'
#'Additionally, we are assuming conventional stern for all single screw ships.
#'Holtrop & Mennen also include an estimation for wake fraction for single screw
#'ships with open stern for fast sailing ships, but that is not included here.
#'
#'@return \code{wakeFraction} (vector of numericals, dimensionless)
#'
#'@references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'Holtrop, J. and Mennen, G. G. J. 1984. "A Statistical Re-Analysis of Resistance
#'and Propulsion Data'.
#'
#'@seealso \itemize{
#'\item \code{\link{calcPropNum}}
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcPropDia}}
#'\item \code{\link{calcCf}}
#'\item \code{\link{calcCbw}}
#'\item \code{\link{calcCp}}
#'\item \code{\link{calcCm}}
#'\item \code{\link{calclcb}}
#'}
#'
#'@family Holtrop-Mennen Calculations
#'
#'@examples
#' calcHMWakeFraction(c(32.25,32.20),
#'                    c(10746.28,8669.7),
#'                    c(13.57,11.49),
#'                    c(1,1),
#'                    c(218.75,209.25),
#'                    c(6.7,7),
#'                    c(1.27,1.18),
#'                    c(0.0015,0.0014),
#'                    c(0.00033,0.00035),
#'                    c(0.81,0.65),
#'                    c(0.81,0.67),
#'                    c(0.99,0.98),
#'                    c(13.57,11.49))
#'@export

calcHMWakeFraction<- function(breadth, wettedSA,maxDraft,nProp,
                              lwl,propDiam,formFactor,Cf,Ca,Cbw,
                    Cp,Cm,aftDraft=maxDraft,Cstern=0,lcb=0){

    c8<-ifelse(breadth/aftDraft<5,#case 1
      breadth*wettedSA/(lwl*propDiam*aftDraft)
    ,#case 2
      wettedSA*(7*breadth/aftDraft-25)/(lwl*propDiam*(breadth/aftDraft-3))
    )
#================
    c9<- ifelse(c8<28,#case 1
    c8,#case 2
      32-(16/(c8-24 ))
    )
#================
    c11<- ifelse(aftDraft/propDiam<2,#case 1
      aftDraft/propDiam
   , #case 2
    0.0833333*((aftDraft/propDiam)^3)+1.33333
    )
#================
c19<-ifelse(Cp<0.7,
            0.12997/(0.95-Cbw)-0.11056/(0.95-Cp),
            0.18567/(1.3571-Cm)-0.71276+0.38648*Cp
            )
#================

# wakeFraction<- ifelse(nProp==1,#begin single screw estimation using [2] method
#   c9*(#c20
#     1+0.015*Cstern
#   )*
#     (#Cv
#       formFactor*Cf+Ca
#     )*(lwl/aftDraft)*(0.050776+0.93405*c11*(
#       (#Cv
#         formFactor*Cf+Ca
#       )/(1-(#Cp1
#         1.45*Cp-0.315-0.0225*lcb
#       ))
#     )
#     )+0.27915*(#c20
#       1+0.015*Cstern
#     )*sqrt(
#       breadth/(lwl*(1-(#Cp1
#         1.45*Cp-0.315-0.0225*lcb
#       )))
#     )+c19*
#     (#c20
#       1+0.015*Cstern
#     )
# #end single screw estimation
# ,#begin twin screw estimation using [1] method
#  0.3095*Cbw+10*
#     (#Cv
#       formFactor*Cf+Ca
#     )*Cbw-(0.23*propDiam/sqrt(breadth*maxDraft))
# )#end twin screw estimation

wakeFraction<-Cp

#single propeller and will not create error by square rooting negative values
index<-which(nProp==1 & (breadth/(lwl*(1-(1.45*Cp-0.315-0.0225*lcb))))>0)
wakeFraction[index]<- c9[index]*(#c20
                1+0.015*Cstern
              )*
              (#Cv
                formFactor[index]*Cf[index]+Ca[index]
              )*(lwl[index]/aftDraft[index])*(0.050776+0.93405*c11[index]*(
                (#Cv
                  formFactor[index]*Cf[index]+Ca[index]
                )/(1-(#Cp1
                  1.45*Cp[index]-0.315-0.0225*lcb[index]
                ))
              )
              )+0.27915*(#c20
                1+0.015*Cstern
              )*sqrt(
                breadth[index]/(lwl[index]*(1-(#Cp1
                  1.45*Cp[index]-0.315-0.0225*lcb[index]
                )))
              )+c19[index]*
              (#c20
                1+0.015*Cstern
              )

#twin propeller or those that will create errors with single propeller method
index<-which(nProp==2 | (breadth/(lwl*(1-(1.45*Cp-0.315-0.0225*lcb))))<0)
wakeFraction[index]<- 0.3095*Cbw[index]+10*
            (#Cv
              formFactor[index]*Cf[index]+Ca[index]
            )*Cbw[index]-(0.23*propDiam[index]/sqrt(breadth[index]*maxDraft[index]))

return(wakeFraction)
}


#Feature Engineering con variables extendidas y manuales
#creo nuevas variables dentro del mismo mes
#Condimentar a gusto con nuevas variables

#este script esta pensado para correr en la nube

#limpio la memoria
rm( list=ls() )
gc()

library( "data.table" )
library( "Rcpp" )

#------------------------------------------------------------------------------
#se calculan para los 6 meses previos el minimo, maximo y tendencia calculada con cuadrados minimos
#la formual de calculo de la tendencia puede verse en https://stats.libretexts.org/Bookshelves/Introductory_Statistics/Book%3A_Introductory_Statistics_(Shafer_and_Zhang)/10%3A_Correlation_and_Regression/10.04%3A_The_Least_Squares_Regression_Line
#para la maxíma velocidad esta funcion esta escrita en lenguaje C, y no en la porqueria de R o Python

cppFunction('NumericVector fhistC(NumericVector pcolumna, IntegerVector pdesde )
{
  /* Aqui se cargan los valores para la regresion */
  double  x[100] ;
  double  y[100] ;

  int n = pcolumna.size();
  NumericVector out( 4*n );

  for(int i = 0; i < n; i++)
  {

    int  libre    = 0 ;
    int  xvalor   = 1 ;

    for( int j= pdesde[i]-1;  j<=i; j++ )
    {
       double a = pcolumna[j] ;

       if( !R_IsNA( a ) )
       {
          y[ libre ]= a ;
          x[ libre ]= xvalor ;
          libre++ ;
       }

       xvalor++ ;
    }

    /* Si hay al menos dos valores */
    if( libre > 1 )
    {
      double  xsum  = x[0] ;
      double  ysum  = y[0] ;
      double  xysum = xsum * ysum ;
      double  xxsum = xsum * xsum ;
      double  vmin  = y[0] ;
      double  vmax  = y[0] ;

      for( int h=1; h<libre; h++)
      {
        xsum  += x[h] ;
        ysum  += y[h] ;
        xysum += x[h]*y[h] ;
        xxsum += x[h]*x[h] ;

        if( y[h] < vmin )  vmin = y[h] ;
        if( y[h] > vmax )  vmax = y[h] ;
      }

      out[ i ]  =  (libre*xysum - xsum*ysum)/(libre*xxsum -xsum*xsum) ;
      out[ i + n ]    =  vmin ;
      out[ i + 2*n ]  =  vmax ;
      out[ i + 3*n ]  =  ysum / libre ;
    }
    else
    {
      out[ i       ]  =  NA_REAL ;
      out[ i + n   ]  =  NA_REAL ;
      out[ i + 2*n ]  =  NA_REAL ;
      out[ i + 3*n ]  =  NA_REAL ;
    }
  }

  return  out;
}')
#------------------------------------------------------------------------------
t0      <-  Sys.time()

setwd( "~/buckets/b1/" )
#lectura rapida del dataset  usando fread  de la libreria  data.table
dataset <- fread( "./datasets/paquete_premium.txt.gz")

columnas_originales <-  copy(colnames( dataset ))

#acomodo los errores del dataset
dataset[ foto_mes==201701,  ccajas_consultas   := NA ]
dataset[ foto_mes==201702,  ccajas_consultas   := NA ]

dataset[ foto_mes==201801,  internet   := NA ]
dataset[ foto_mes==201801,  thomebanking   := NA ]
dataset[ foto_mes==201801,  chomebanking_transacciones   := NA ]
dataset[ foto_mes==201801,  tcallcenter   := NA ]
dataset[ foto_mes==201801,  ccallcenter_transacciones   := NA ]
dataset[ foto_mes==201801,  cprestamos_personales   := NA ]
dataset[ foto_mes==201801,  mprestamos_personales   := NA ]
dataset[ foto_mes==201801,  mprestamos_hipotecarios  := NA ]
dataset[ foto_mes==201801,  ccajas_transacciones   := NA ]
dataset[ foto_mes==201801,  ccajas_consultas   := NA ]
dataset[ foto_mes==201801,  ccajas_depositos   := NA ]
dataset[ foto_mes==201801,  ccajas_extracciones   := NA ]
dataset[ foto_mes==201801,  ccajas_otras   := NA ]

dataset[ foto_mes==201806,  tcallcenter   :=  NA ]
dataset[ foto_mes==201806,  ccallcenter_transacciones   :=  NA ]

dataset[ foto_mes==201904,  ctarjeta_visa_debitos_automaticos  :=  NA ]
dataset[ foto_mes==201904,  mttarjeta_visa_debitos_automaticos  := NA ]

dataset[ foto_mes==201905,  mrentabilidad     := NA ]
dataset[ foto_mes==201905,  mrentabilidad_anual     := NA ]
dataset[ foto_mes==201905,  mcomisiones       := NA ]
dataset[ foto_mes==201905,  mpasivos_margen  := NA ]
dataset[ foto_mes==201905,  mactivos_margen  := NA ]
dataset[ foto_mes==201905,  ctarjeta_visa_debitos_automaticos  := NA ]
dataset[ foto_mes==201905,  ccomisiones_otras := NA ]
dataset[ foto_mes==201905,  mcomisiones_otras := NA ]

dataset[ foto_mes==201910,  mpasivos_margen  := NA ]
dataset[ foto_mes==201910,  mactivos_margen  := NA ]
dataset[ foto_mes==201910,  ccomisiones_otras := NA ]
dataset[ foto_mes==201910,  mcomisiones_otras := NA ]
dataset[ foto_mes==201910,  mcomisiones       := NA ]
dataset[ foto_mes==201910,  mrentabilidad     := NA ]
dataset[ foto_mes==201910,  mrentabilidad_annual     := NA ]
dataset[ foto_mes==201910,  chomebanking_transacciones   := NA ]
dataset[ foto_mes==201910,  ctarjeta_visa_descuentos   := NA ]
dataset[ foto_mes==201910,  ctarjeta_master_descuentos   := NA ]
dataset[ foto_mes==201910,  mtarjeta_visa_descuentos   := NA ]
dataset[ foto_mes==201910,  mtarjeta_master_descuentos    := NA ]
dataset[ foto_mes==201910,  ccajeros_propios_descuentos   := NA ]
dataset[ foto_mes==201910,  mcajeros_propios_descuentos   := NA ]

dataset[ foto_mes==202001,  cliente_vip   := NA ]

cat('arreglos hechos.\n')

#INICIO de la seccion donde se deben hacer cambios con variables nuevas
#se crean los nuevos campos para MasterCard  y Visa, teniendo en cuenta los NA's
#varias formas de combinar Visa_status y Master_status
dataset[ , mv_status01       := pmax( Master_status,  Visa_status, na.rm = TRUE) ]
dataset[ , mv_status02       := Master_status +  Visa_status ]
dataset[ , mv_status03       := pmax( ifelse( is.na(Master_status), 9, Master_status) , ifelse( is.na(Visa_status), 9, Visa_status) ) ]
dataset[ , mv_status04       := ifelse( is.na(Master_status), 9, Master_status)  +  ifelse( is.na(Visa_status), 9, Visa_status)  ]
dataset[ , mv_status05       := ifelse( is.na(Master_status), 9, Master_status)  +  10*ifelse( is.na(Visa_status), 9, Visa_status)  ]

dataset[ , mv_status06       := ifelse( is.na(Visa_status),
                                        ifelse( is.na(Master_status), 9, Master_status),
                                        Visa_status)  ]

dataset[ , mv_status07       := ifelse( is.na(Master_status),
                                        ifelse( is.na(Visa_status), 9, Visa_status),
                                        Master_status)  ]

#combino MasterCard y Visa
# dataset[ , mv_default              := pmax( Master_default, Visa_default, na.rm = TRUE) ]
dataset[ , mv_mfinanciacion_limite := rowSums( cbind( Master_mfinanciacion_limite,  Visa_mfinanciacion_limite) , na.rm=TRUE ) ]

dataset[ , mv_Fvencimiento         := pmin( Master_Fvencimiento, Visa_Fvencimiento, na.rm = TRUE) ]
dataset[ , mv_Finiciomora          := pmin( Master_Finiciomora, Visa_Finiciomora, na.rm = TRUE) ]
dataset[ , mv_msaldototal          := rowSums( cbind( Master_msaldototal,  Visa_msaldototal) , na.rm=TRUE ) ]
dataset[ , mv_msaldopesos          := rowSums( cbind( Master_msaldopesos,  Visa_msaldopesos) , na.rm=TRUE ) ]
dataset[ , mv_msaldodolares        := rowSums( cbind( Master_msaldodolares,  Visa_msaldodolares) , na.rm=TRUE ) ]
dataset[ , mv_mconsumospesos       := rowSums( cbind( Master_mconsumospesos,  Visa_mconsumospesos) , na.rm=TRUE ) ]
dataset[ , mv_mconsumosdolares     := rowSums( cbind( Master_mconsumosdolares,  Visa_mconsumosdolares) , na.rm=TRUE ) ]
dataset[ , mv_mlimitecompra        := rowSums( cbind( Master_mlimitecompra,  Visa_mlimitecompra) , na.rm=TRUE ) ]
dataset[ , mv_madelantopesos       := rowSums( cbind( Master_madelantopesos,  Visa_madelantopesos) , na.rm=TRUE ) ]
dataset[ , mv_madelantodolares     := rowSums( cbind( Master_madelantodolares,  Visa_madelantodolares) , na.rm=TRUE ) ]
dataset[ , mv_fultimo_cierre       := pmax( Master_fultimo_cierre, Visa_fultimo_cierre, na.rm = TRUE) ]
dataset[ , mv_mpagado              := rowSums( cbind( Master_mpagado,  Visa_mpagado) , na.rm=TRUE ) ]
dataset[ , mv_mpagospesos          := rowSums( cbind( Master_mpagospesos,  Visa_mpagospesos) , na.rm=TRUE ) ]
dataset[ , mv_mpagosdolares        := rowSums( cbind( Master_mpagosdolares,  Visa_mpagosdolares) , na.rm=TRUE ) ]
dataset[ , mv_fechaalta            := pmax( Master_fechaalta, Visa_fechaalta, na.rm = TRUE) ]
dataset[ , mv_mconsumototal        := rowSums( cbind( Master_mconsumototal,  Visa_mconsumototal) , na.rm=TRUE ) ]
dataset[ , mv_cconsumos            := rowSums( cbind( Master_cconsumos,  Visa_cconsumos) , na.rm=TRUE ) ]
dataset[ , mv_cadelantosefectivo   := rowSums( cbind( Master_cadelantosefectivo,  Visa_cadelantosefectivo) , na.rm=TRUE ) ]
dataset[ , mv_mpagominimo          := rowSums( cbind( Master_mpagominimo,  Visa_mpagominimo) , na.rm=TRUE ) ]

#a partir de aqui juego con la suma de Mastercard y Visa
dataset[ , mvr_Master_mlimitecompra:= Master_mlimitecompra / mv_mlimitecompra ]
dataset[ , mvr_Visa_mlimitecompra  := Visa_mlimitecompra / mv_mlimitecompra ]
dataset[ , mvr_msaldototal         := mv_msaldototal / mv_mlimitecompra ]
dataset[ , mvr_msaldopesos         := mv_msaldopesos / mv_mlimitecompra ]
dataset[ , mvr_msaldopesos2        := mv_msaldopesos / mv_msaldototal ]
dataset[ , mvr_msaldodolares       := mv_msaldodolares / mv_mlimitecompra ]
dataset[ , mvr_msaldodolares2      := mv_msaldodolares / mv_msaldototal ]
dataset[ , mvr_mconsumospesos      := mv_mconsumospesos / mv_mlimitecompra ]
dataset[ , mvr_mconsumosdolares    := mv_mconsumosdolares / mv_mlimitecompra ]
dataset[ , mvr_madelantopesos      := mv_madelantopesos / mv_mlimitecompra ]
dataset[ , mvr_madelantodolares    := mv_madelantodolares / mv_mlimitecompra ]
dataset[ , mvr_mpagado             := mv_mpagado / mv_mlimitecompra ]
dataset[ , mvr_mpagospesos         := mv_mpagospesos / mv_mlimitecompra ]
dataset[ , mvr_mpagosdolares       := mv_mpagosdolares / mv_mlimitecompra ]
dataset[ , mvr_mconsumototal       := mv_mconsumototal  / mv_mlimitecompra ]
dataset[ , mvr_mpagominimo         := mv_mpagominimo  / mv_mlimitecompra ]

cat('nuevas combinaciones creadas.\n')
#FIN de la seccion donde se deben hacer cambios con variables nuevas

columnas_extendidas <-  copy( setdiff(  colnames(dataset), columnas_originales ) )

#grabo con nombre extendido
fwrite( dataset,
        file="./datasets/paquete_premium_ext_corregido.txt.gz",
        sep= "\t" )

#------------------------------------------------------------------------------
#Aqui comienza la creación de variables historicas

#ordeno por  numero_de_cliente y foto_mes
setorder( dataset,  numero_de_cliente, foto_mes )

#Esta es la cantidad de meses que utilizo para la historia
ventana_regresion  <- 6

last <- nrow( dataset )
kcampo_id_idx  <-  match( "numero_de_cliente", names(dataset) )
#----------

#creo el vector_desde que indica cada ventana
#de esta forma se acelera el procesamiento ya que lo hago una sola vez

vector_ids   <- dataset[[  kcampo_id_idx  ]]

vector_desde <- seq( -ventana_regresion+2,  nrow(dataset)-ventana_regresion+1 )
vector_desde[ 1:ventana_regresion ]  <-  1

for( i in 2:last )  if( vector_ids[ i-1 ] !=  vector_ids[ i ] ) {  vector_desde[i] <-  i }
for( i in 2:last )  if( vector_desde[i] < vector_desde[i-1] )  {  vector_desde[i] <-  vector_desde[i-1] }

columnas_no_procesar  <- c( "numero_de_cliente", "foto_mes", "clase_ternaria" )

#agrego al dataset las TENDENCIAS
columnas_originales_a_procesar  <- setdiff( columnas_originales,  columnas_no_procesar  )

cat('procesando tendencias, min, max y avg para originales.\n')
for(  campo  in  columnas_originales_a_procesar )
{
   campo_idx     <-   match( campo,  names(dataset) )
   col_original  <-   dataset[[  campo_idx  ]]

   nueva_col     <- fhistC( col_original, vector_desde )

   #agrego las nuevas columnas al dataset
   dataset[ , paste( campo, "__tend", sep="" ):= nueva_col[ (0*last +1):(1*last) ]  ]
   dataset[ , paste( campo, "__min" , sep="" ):= nueva_col[ (1*last +1):(2*last) ]  ]
   dataset[ , paste( campo, "__max" , sep="" ):= nueva_col[ (2*last +1):(3*last) ]  ]

   #Por ahora, no agrego el promedio
   dataset[ , paste( campo, "__avg" , sep="" ):= nueva_col[ (3*last +1):(4*last) ]  ]

   cat(campo,' lista.\n')
}

cat('tendencias, min, max y avg para originales creadas.\n')

#dejo la clase como ultimo campo
nuevo_orden <-  c( setdiff( colnames( dataset ) , "clase_ternaria" ) , "clase_ternaria" )
setcolorder( dataset, nuevo_orden )

#grabo el archivo completo
#al  agregarle el .gz  al final del nombre del archivo,  data.table sabe que debe comprimir el archivo
fwrite( dataset,
        file= "./datasets/paquete_premium_hist_corregido.txt.gz",
        sep="\t" )

gc()
#ahora agrego tendencias TAMBIEN  para las variables nuevas

columnas_extendidas_a_procesar  <- setdiff( columnas_extendidas,  columnas_no_procesar  )

cat('procesando tendencias, min, max y avg para nuevas/extendidas.\n')
for(  campo  in  columnas_extendidas_a_procesar )
{
   campo_idx     <-   match( campo,  names(dataset) )
   col_original  <-   dataset[[  campo_idx  ]]

   nueva_col     <- fhistC( col_original, vector_desde )

   #agrego las nuevas columnas al dataset
   dataset[ , paste( campo, "__tend", sep="" ):= nueva_col[ (0*last +1):(1*last) ]  ]
   dataset[ , paste( campo, "__min" , sep="" ):= nueva_col[ (1*last +1):(2*last) ]  ]
   dataset[ , paste( campo, "__max" , sep="" ):= nueva_col[ (2*last +1):(3*last) ]  ]

   #Por ahora, no agrego el promedio
   dataset[ , paste( campo, "__avg" , sep="" ):= nueva_col[ (3*last +1):(4*last) ]  ]

   cat(campo,' lista.\n')
}
cat('tendencias, min, max y avg para originales creadas.\n')

#dejo la clase como ultimo campo
nuevo_orden <-  c( setdiff( colnames( dataset ) , "clase_ternaria" ) , "clase_ternaria" )
setcolorder( dataset, nuevo_orden )

#grabo el archivo completo
#al  agregarle el .gz  al final del nombre del archivo,  data.table sabe que debe comprimir el archivo
fwrite( dataset,
        file= "./datasets/paquete_premium_exthist_corregido.txt.gz",
        sep="\t" )

t1      <-  Sys.time()
tiempo  <-  as.numeric(  t1 - t0, units = "secs")

cat( "El Feature Engineering ha corrido en :", tiempo, "  segundos.\n" )

#limpio la memoria
rm( list=ls() )
gc()

quit( save="no")


\name{discretize}
\alias{discretize}
\title{
Discretize a Continuous Matrix to a Discrete Matrix
}
\description{
Discretize a Continuous Matrix to a Discrete Matrix
}
\usage{
discretize(mat, rule, right_closed = FALSE)
}
\arguments{

  \item{mat}{A normalize matrix from \code{\link{normalizeToMatrix}}.}
  \item{rule}{A list of intervals which provide mapping between continuous values to discrete values. Note the order of intervals determines the order of corresponding discrete levels.}
  \item{right_closed}{Is the interval right closed?}

}
\details{
Assuming we have a normalized matrix with both positive values and negative values, we only
want to see the enrichment of the windows/regions showing significant positive values and
negative values and we are only interested in the direction of the values while not the value itself,
then we can define the rule as:

  \preformatted{
    rule = list(
        "positive" = c(0.5, Inf),
        "negative" = c(-Inf, -0.5)
    )  }

And we can convert the continuous matrix to a discrete matrix and visualize it:

  \preformatted{
    mat2 = discretize(mat, rule)
    EnrichedHeatmap(mat2, col = c("positive" = "red", "negative" = "green"))  }

Another example is to discretize the signals to discrete levels according to the intensities:

  \preformatted{
    rule = list(
        "very_high" = c(100, Inf),
        "high" = c(50, 100),
        "intermediate" = c(25, 50),
        "low" = c(1e-6, 25)
    )  }
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
# There is no example
NULL

}


library(incon)
library(reticulate)
use_python("/c/Users/Marco/Anaconda3/python")

folders <- list.dirs('features/chords_and_times', recursive=FALSE)
systems <- c('kelz', 'lisu', 'google', 'cheng', 'target')
models <- c("hutch_78_roughness", "har_18_harmonicity", "har_19_corpus")

py_save_object <- function(object, filename, pickle = "pickle", ...) {
    builtins <- import_builtins()
    pickle <- import(pickle)
    handle <- builtins$open(filename, "wb")
    on.exit(handle$close(), add = TRUE)
    pickle$dump(object, handle, protocol = pickle$HIGHEST_PROTOCOL, ...)
}

weighted_std <- function(values, weighted_mean, weights) {
    sigma <- 0.0
    for (i in 1:length(values)) {
        sigma <- sigma + ((values[i] - weighted_mean) ^ 2) * weights[i]
    }
    std <- sqrt(sigma / sum(weights))
    return(std)
}

for (folder in folders) {
    example <- substring(folder, 27)
    print(example)
    for (system in systems) {

        chords <- read.csv(paste(folder, "/", system, "_chords.csv", sep=""))
        durations <- read.csv(paste(folder, "/", system, "_durations.csv", sep=""))
        durations <- as.vector(t(durations[1]))
        # event_times <- read.csv(paste(folder, "/", system, "_event_times.csv", sep=""))

        hutch_78_roughness <- c()
        har_18_harmonicity <- c()
        har_19_corpus <- c()
        # loop over all the chords
        empty_chord_indexs <- c()
        for (idx in 1:dim(chords)[1]) {
            chord <- as.vector(t(chords[idx,]))
            chord <- chord[chord!=-1] # unpad
            duration <- durations[idx]

            if (length(chord) > 0) {
                consenance_values <- incon(chord, models)
                hutch_78_roughness <- append(hutch_78_roughness, unname(consenance_values[1]))
                har_18_harmonicity <- append(har_18_harmonicity, unname(consenance_values[2]))
                har_19_corpus <- append(har_19_corpus, unname(consenance_values[3]))
            } else {
                empty_chord_indexs <- append(empty_chord_indexs, idx)
                # consenance_values <- incon(c(90), models)
                # hutch_78_roughness <- append(hutch_78_roughness, unname(consenance_values[1]))
                # har_18_harmonicity <- append(har_18_harmonicity, unname(consenance_values[2]))
                # har_19_corpus <- append(har_19_corpus, unname(consenance_values[3]))
            }

        }
        if (length(empty_chord_indexs) > 0) {
            durations <- durations[-(empty_chord_indexs)]
        }

        hutch_78_roughness_weighted_mean <- weighted.mean(hutch_78_roughness, durations)
        har_18_harmonicity_weighted_mean <- weighted.mean(har_18_harmonicity, durations)
        har_19_corpus_weighted_mean <- weighted.mean(har_19_corpus, durations)

        hutch_78_roughness_weighted_std <- weighted_std(hutch_78_roughness, hutch_78_roughness_weighted_mean, durations)
        har_18_harmonicity_weighted_std <- weighted_std(har_18_harmonicity, har_18_harmonicity_weighted_mean, durations)
        har_19_corpus_weighted_std <- weighted_std(har_19_corpus, har_19_corpus_weighted_mean, durations)

        consenance_statistics <- c(hutch_78_roughness_weighted_mean, har_18_harmonicity_weighted_mean, har_19_corpus_weighted_mean, hutch_78_roughness_weighted_std, har_18_harmonicity_weighted_std, har_19_corpus_weighted_std, max(hutch_78_roughness), max(har_18_harmonicity), max(har_19_corpus), min(hutch_78_roughness), min(har_18_harmonicity), min(har_19_corpus))

        path = paste("features/consonance_statistics_no_empty_chords/", example, sep="")
        if (!file.exists("features/consonance_statistics_no_empty_chords")) {
            dir.create("features/consonance_statistics_no_empty_chords")
        }
        if (!file.exists(path)) {
            dir.create(path)
        }

        py_save_object(consenance_statistics, paste("features/consonance_statistics_no_empty_chords/", example, "/", system, ".pkl", sep=""))

    }
}


plot(unigrams_freq_single_good$value, unigrams_freq_single_good$frequency)
model = lm(unigrams_freq_single_good$frequency ~ unigrams_freq_single_good$value)
abline(model, col = "green")
summary(model)
coef(model)

plot(unigrams_freq_single_bad$value, unigrams_freq_single_bad$frequency)
model = lm(unigrams_freq_single_bad$value ~ unigrams_freq_single_bad$frequency)
abline(model, col = "red")

plot(unigrams_freq_single_try$value, unigrams_freq_single_try$frequency)
model = lm(unigrams_freq_single_try$frequency ~ unigrams_freq_single_try$value)
abline(model, col = "blue")

plot(unigrams_freq_summary$frequency, unigrams_freq_summary$mean)
stripchart(unigrams_freq_summary$mean, method = 'jitter')

par(mfrow=c(2,1))
plot(floor(tips_ratings$value), tips_ratings$frequency, col='red', pch = 19)
lines(tips_ratings$value, tips_ratings$frequency, type='b')
text(tips_ratings$value, tips_ratings$frequency, labels=tips_ratings$frequency, cex= 0.7, pos=3)
model = lm(tips_ratings$frequency ~ tips_ratings$value)
abline(model, col = "blue")

plot(tips_ratings_2$value, tips_ratings_2$frequency, col='red', pch = 19)
text(tips_ratings_2$value, tips_ratings_2$frequency, labels=tips_ratings_2$frequency, cex= 0.7, pos=3)

plot(tips_ratings_3$value, tips_ratings_3$frequency, col='red', pch = 19)
text(tips_ratings_3$value, tips_ratings_3$frequency, labels=tips_ratings_3$frequency, cex= 0.7, pos=3)

plot(tips_ratings_4$value, tips_ratings_4$frequency, col='red', pch = 19)
text(tips_ratings_4$value, tips_ratings_4$frequency, labels=tips_ratings_4$frequency, cex= 0.7, pos=3)

plot(tips_ratings_5$value, tips_ratings_5$frequency, col='red', pch = 19)
text(tips_ratings_5$value, tips_ratings_5$frequency, labels=tips_ratings_5$frequency, cex= 0.7, pos=3)

par(mfrow=c(2,1))
plot(tips_ratings$value, tips_ratings$frequency, col='red', pch = 19)
text(tips_ratings$value, tips_ratings$frequency, labels=tips_ratings$frequency, cex= 0.7, pos=3)

plot(tips_ratings_7$value, tips_ratings_7$frequency, col='red', pch = 19)
text(tips_ratings_7$value, tips_ratings_7$frequency, labels=tips_ratings_7$frequency, cex= 0.7, pos=3)

plot(tips_ratings_8$value, tips_ratings_8$frequency, col='red', pch = 19)
text(tips_ratings_8$value, tips_ratings_8$frequency, labels=tips_ratings_8$frequency, cex= 0.7, pos=3)


wtd.cor <- function(x, y=NULL, weight=NULL, collapse=TRUE){
  x <- as.matrix(x)
  if(is.null(weight)){
    weight <- rep(1, dim(x)[1])
  }
  if(is.null(y)){
    y <- x
  }
  y <- as.matrix(y)
  materset <- lapply(as.data.frame(x), function(x) lapply(as.data.frame(y), function(y) onecor.wtd(x, y, weight)))
  est <- sapply(materset, function(q) sapply(q, function(g) g[1]))
  se <- sapply(materset, function(q) sapply(q, function(g) g[2]))
  tval <- sapply(materset, function(q) sapply(q, function(g) g[3]))
  pval <- sapply(materset, function(q) sapply(q, function(g) g[4]))
  out <- list(correlation=est, std.err=se, t.value=tval, p.value=pval)
  if(is.vector(est) & collapse==TRUE || (1 %in% dim(est)) & collapse==TRUE){
    out <- matrix(unlist(out), ncol=4, byrow=FALSE)
    rownames(out) <- names(est)
    colnames(out) <- c("correlation", "std.err", "t.value", "p.value")
  }
  out
}


x <- rep(1, 100)
for (i in 1:100-1) {
    x <- xor(x, rep(c(rep(0,i),1), length.out=100))
}
which(!x)


# Get uncorrelated covars by dropping the correlated ones
# Input into lasso later on
library(caret)
#library(reshape2)
library(corrr) # Should be in CRAN but had problems, so devtools::install_github("drsimonj/corrr")

source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")

Data.df = as.data.frame(LoadTrainingAndCovariates())
length(GetAllPixelCovars()) # Start: 313
# Automated selection based on correlations
PairwiseCor = cor(Data.df[,GetAllPixelCovars()], use="pairwise.complete.obs")
CorrColumns = findCorrelation(PairwiseCor)
names(Data.df[,GetAllPixelCovars()])[-CorrColumns] # 88 left, but choice is spurious (e.g. no slope)

# Case by case
# Base R is a bit annoying to melt with having to deal with duplicates
#PairedCor = melt(PairwiseCor)
#nrow(PairedCor)
#length(unique(PairedCor$value))*2
#PairedCor[PairedCor$Var1]
#PairwiseCorrr = correlate(Data.df[,GetAllPixelCovars()])
#CorLong = stretch(shave(PairwiseCorrr), TRUE) # Remove a triangle, and diagonals, then make it a long format

# Remove one and recalculate
# Amplitude: a few values way above reasonable limits, log-transformed looks OK
#CorLong[order(abs(CorLong$r), decreasing=TRUE),][1,]
#plot(amplitude1~amplitude2, Data.df, xlim=c(0, 1000), ylim=c(0, 1000))
#plot(log(amplitude1)~log(amplitude2), Data.df)
#Data.df$amplitude1[Data.df$amplitude1 > 100] = NA
#Data.df$amplitude2[Data.df$amplitude2 > 100] = NA
# Decision: log-transform always

RecalcCor = function(covars = GetAllPixelCovars(), ...)
{
    PairwiseCorrr = correlate(Data.df[,covars], ...)
    CorLong = stretch(shave(PairwiseCorrr), TRUE)
    CorLongOrder = as.data.frame(CorLong[order(abs(CorLong$r), decreasing=TRUE),])
    print(CorLongOrder[1,])
    CorSum1 = sum(abs(CorLongOrder[CorLongOrder$x == CorLongOrder[1,1] | CorLongOrder$y == CorLongOrder[1,1],"r"][-1]))
    CorSum2 = sum(abs(CorLongOrder[CorLongOrder$x == CorLongOrder[1,2] | CorLongOrder$y == CorLongOrder[1,2],"r"][-1]))
    print(paste("Correlation sum of", CorLongOrder[1,1], "is", CorSum1))
    print(paste("Correlation sum of", CorLongOrder[1,2], "is", CorSum2))
    print(plot(Data.df[[CorLongOrder[1,1]]], Data.df[[CorLongOrder[1,2]]], xlab=CorLongOrder[1,1], ylab=CorLongOrder[1,2], main=CorLongOrder[1,3]))
    return(CorLongOrder)
}

# start with Pearson to rule out linear correlations, then go for Spearman for the non-linear ones (Kendall is too slow)
CorLong = RecalcCor() # Soil PH
plot(sol_ph.0cm~sol_ph.10cm, Data.df) # True high correlation, pick one
RemainingCovars = GetAllPixelCovars()[!GetAllPixelCovars() %in% "sol_ph.0cm"] # Vegetation not likely to be affected by topsoil, choose 10cm

CorLong = RecalcCor(RemainingCovars) # Soil sand, same
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_sand.0cm"]

CorLong = RecalcCor(RemainingCovars) # Soil PH, same
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_ph.200cm"]

CorLong = RecalcCor(RemainingCovars) # KCL, deepest layer is not overly useful
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIKCL.M.sl7"]

CorLong = RecalcCor(RemainingCovars) # KCL, deepest layer is still not overly useful
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIKCL.M.sl4"]

CorLong = RecalcCor(RemainingCovars) ## PHIHOX, hard to tell whether 2 or 3 is better
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIHOX.M.sl3"]

CorLong = RecalcCor(RemainingCovars) # Remove 7
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIHOX.M.sl7"]

CorLong = RecalcCor(RemainingCovars) ## SLTPPT, hard to choose between level 1 and 2; go with 2 as it's not the very surface
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SLTPPT.M.sl1"]

CorLong = RecalcCor(RemainingCovars) # SNDPPT, hard to choose between level 2 and 3; decided on keeping 2 so keep consistent
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SNDPPT.M.sl3"]

CorLong = RecalcCor(RemainingCovars) # Soil PH, same
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_ph.100cm"]

RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_ph.30cm"] # Consistency also across SoilGrids
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_sand.100cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIKCL.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIKCL.M.sl3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIHOX.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIHOX.M.sl1"] # Consistency to choose level 2
plot(wc2.0_30s_tmin_01~wc2.0_30s_tmin_02, Data.df)
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_vapr_02"] ## Water vapour of Jan or Feb. Jan works slightly better and it's actually colder.
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_clay.0cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_clay.100cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CECSOL.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SLTPPT.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SLTPPT.M.sl3"] # Choice between 2 and 3
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIHOX.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CLYPPT.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SNDPPT.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SNDPPT.M.sl1"] # Same
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_bulkdens.200cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_sand.30cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIHOX.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CECSOL.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "WWP.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_01"] ## Average temperature of Jan vs Dec. Dec works much better.
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_ph.60cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CLYPPT.M.sl3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CRFVOL.M.sl1"] # Same
RemainingCovars = RemainingCovars[!RemainingCovars %in% "WWP.M.sl3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIKCL.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SLTPPT.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SNDPPT.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_sand.60cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_vapr_07"] # Vapour for 08 or 07, 08 is slightly better
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_clay.200cm"] # At this point we're getting meaningful cor differences between paired variables
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CECSOL.M.sl7"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "bio13"] # bio13 vs bio16: precipitation of wettest month or quarter; we have months already, keep quarter; also needs a log-transform
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIKCL.M.sl1"] # Level 2 again
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_02"] # Min temperature Jan/Feb, Jan is the coldest month so use that
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_srad_12"] # Solar radiation between Jan and Dec
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SNDPPT.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "WWP.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_07"] # 7 vs 8 and 8 is warmer...
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_bulkdens.100cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_bulkdens.0cm"]
#RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_ph.0cm"] # Prefer 1 over 0
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_07"] # Same with tmax
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_07"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SLTPPT.M.sl7"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_12"] # 12 vs 02: going for colder 02
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_02"] # 02 vs 01: 01 is colder
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_clay.60cm"]
Data.df = as.data.frame(LoadTrainingAndCovariates())
CorLong = RecalcCor(RemainingCovars)
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SLTPPT.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CLYPPT.M.sl2"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "ndvi.75"] # Mean NDVI vs 75th percentile; we're in 98% now
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CLYPPT.M.sl7"]
Data.df = as.data.frame(LoadTrainingAndCovariates())
CorLong = RecalcCor(RemainingCovars)
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CLYPPT.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_vapr_03"] # Vapour 12 vs 03; we'd want 1 for coldest, 4 for midpoint, so doesn't matter
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_vapr_12"] # Vapour for 01 vs 12
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_clay.30cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CECSOL.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "ndvi"] ## NDVI vs OSAVI. Oof. OSAVI is less correlated overall though, and we have mean NDVI
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CECSOL.M.sl3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CRFVOL.M.sl3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "WWP.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_prec_02"] # Precipitation: most in 01/least in 07 in south, most in 08/least in 01 in the north, can keep 01/08 consistently; bioclimatic make more sense
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_bulkdens.30cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CRFVOL.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Jan"] # PREMRG from SG covars vs worldclim data
RemainingCovars = RemainingCovars[!RemainingCovars %in% "OCSTHA.M.sd3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_06"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_02"] ## Average vs max temp in winter. 02 not interesting so get rid of it
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_12"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Sep"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Aug"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "WWP.M.sl1"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_03"] ## 03 vs 11. 04 and 10 are useful so these don't matter
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_04"] ## bio1 vs 04tavg; mean is more meaningful
RemainingCovars = RemainingCovars[!RemainingCovars %in% "bio16"] ## bio12 vs bio16. bio12 is annual so keep that
RemainingCovars = RemainingCovars[!RemainingCovars %in% "osavi"] ## EVI vs OSAVI. EVI is less correlated and more common
RemainingCovars = RemainingCovars[!RemainingCovars %in% "bio6"] ## bio11 vs bio6. bio11 is mean so keep that
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_prec_07"] # we are now at 0.97
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_08"] # average vs max, keep average
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_12"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_11"] # same
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_08"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_03"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_06"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_vapr_11"] # Vapour 04 vs 11
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Jun"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CLYPPT.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "ndvi.25"] # mean NDVI vs 25th percentile
RemainingCovars = RemainingCovars[!RemainingCovars %in% "BLDFIE.M.sl7"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh3.M.sl2"] ## AWCh2.M.sl2 vs AWCh3.M.sl2, prefer 2 because it's in the middle
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_vapr_09"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_03"] # temperature 11 vs 03, doesn't matter
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_11"] # vs avg
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_srad_06"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_05"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_09"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_10"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_organic.0cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_sand.200cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Oct"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Mar"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh3.M.sl3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_10"] # vs bio1
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh3.M.sl1"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "ORCDRC.M.sl2"] ## OCSTHA vs OCDRC, OCSTHA is easier to interpret
RemainingCovars = RemainingCovars[!RemainingCovars %in% "BLDFIE.M.sl1"] ## water content vs bulk density; the denser the less water. Water has direct influence and density not so much
RemainingCovars = RemainingCovars[!RemainingCovars %in% "intercept"] ## trend vs intercept
RemainingCovars = RemainingCovars[!RemainingCovars %in% "BLDFIE.M.sl2"] # we are now in the 0.96s
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CRFVOL.M.sl7"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "roughness"] ## tri vs roughness, that's max distance vs mean distance, keep mean
RemainingCovars = RemainingCovars[!RemainingCovars %in% "OCSTHA.M.sd6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_vapr_10"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "BLDFIE.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "OCSTHA.M.sd5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CRFVOL.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "ORCDRC.M.sl7"] # Also need to log ORCDRC and OCSTHA
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_vapr_04"] # vapour 04 vs mean
#RemainingCovars = RemainingCovars[!RemainingCovars %in% "SNDPPT.M.sl7"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_09"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_05"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_srad_02"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_srad_11"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCtS.M.sl7"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_vapr_05"] # 05 vs 10
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TEXMHT.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_06"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_06"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Feb"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh1.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TMDMOD_2001.M.May"] ## MODIS 2001 vs 2011, we use TS from 2014-2017
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_organic.100cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SNDPPT.M.sl7"] # Water vs sand, remove sand
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCtS.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_bulkdens.60cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "ORCDRC.M.sl3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "bio5"] ## bio5 vs bio10, bio10 is mean so keep it
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_srad_07"] # 0.95s
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Nov"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "mean.wind"] ## Mean wind vs min wind; if we can we should keep min and max both, otherwise mean
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh2.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIHOX.M.sl2"] ## SoilGrids vs LandGIS: keep 10cm
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCtS.M.sl3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "WWP.M.sl7"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh3.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "bio7"] ## bio4 vs bio7, seasonality vs range; seasonality has a better interpretability
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh3.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TEXMHT.M.sl1"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Apr"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "swir"] ## red vs swir; lasso sugests that red is the most important, yet swir is less correlated
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmax_04"] # vs bio1
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_wind_05"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "SNDPPT.M.sl2"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Dec"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCtS.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "bio14"] ## bio14 vs bio17; 14 is month
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_vapr_06"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "ORCDRC.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_wind_06"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.May"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "BLDFIE.M.sl3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Jul"] # 0.94s
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_prec_12"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_wind_07"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh2.M.sl3"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "BLDFIE.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TEXMHT.M.sl7"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh3.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_wind_12"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "bio3"] ## bio4 vs bio3; seasonality is easier to explain
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_wind_03"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TMDMOD_2011.M.Feb"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_10"] # vs bio1
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh2.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_04"] # vs bio1
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCtS.M.sl1"]
#RemainingCovars = RemainingCovars[!RemainingCovars %in% "SNDPPT.M.sl1"] ## Water until wilting vs sand, water is more direct for vegetation
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh1.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "ORCDRC.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CRFVOL.M.sl6"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_wind_08"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TEXMHT.M.sl5"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_organic.60cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "tri"] ## tri vs slope. The plot is art. tri is harder to interpret. But slope needs a log-transform.
#RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh2.M.sl7"]
#RemainingCovars = RemainingCovars[!RemainingCovars %in% "BLDFIE.M.sl1"]
#RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIKCL.M.sl2"] ## PHIHOX vs PHIKCL, keep H2O
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_09"] # 0.93s
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TEXMHT.M.sl2"] # clay vs texture, keep clay since it's not categorical
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_wind_02"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh3.M.sl7"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "OCSTHA.M.sd4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_11"] # vs bio11
RemainingCovars = RemainingCovars[!RemainingCovars %in% "mean.vapr"] # Mean vapour vs min, try to keep min/max
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh1.M.sl2"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tmin_01"] ## tmin vs tmax of Jan; it's either coldest or warmest, so just go with less correlation
RemainingCovars = RemainingCovars[!RemainingCovars %in% "BLDFIE.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TEXMHT.M.sl3"] # 0.92s
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_wind_11"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "blue"] # red vs blue, we know blue is not as accurate
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TMNMOD_2011.M.May"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TEXMHT.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TMDMOD_2001.M.Feb"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_prec_09"] # 06 vs 09, significant correlation difference
RemainingCovars = RemainingCovars[!RemainingCovars %in% "min"] # min vs mean ndvi
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PHIKCL.M.sl2"] ## Soil pH from SoilGrids vs LandGIS. SG has two types, so remove that
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TMNMOD_2011.M.Jul"] # Temperature from MODIS vs WolrdClim
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh2.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "max"] # max vs mean ndvi
RemainingCovars = RemainingCovars[!RemainingCovars %in% "PREMRG.M.Jun"] # 0.91s
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TMDMOD_2001.M.Mar"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TMDMOD_2001.M.Nov"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCh2.M.sl1"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CLYPPT.M.sl1"] # clay vs water, keep water
RemainingCovars = RemainingCovars[!RemainingCovars %in% "TMDMOD_2001.M.Apr"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_organic.30cm"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "AWCtS.M.sl4"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_sand.10cm"] ## LandGIS sand vs clay, oh boy. Sand is the middle fraction so remove that
# 0.9 threshold reached
CorLong = RecalcCor(RemainingCovars)
length(RemainingCovars) # 93 covars
tail(CorLong)

# Try correlation for nonlinear relations; kendall is too slow for >100 vars still, so spearman
CorLong = RecalcCor(RemainingCovars, method="spearman")
#RemainingCovars = RemainingCovars[!RemainingCovars %in% "OCSTHA.M.sd2"] ## bulk density vs soil organic carbon; carbon needs a log-transform and is overall more correlated, so eliminate it
RemainingCovars = RemainingCovars[!RemainingCovars %in% "ORCDRC.M.sl1"] # ORCDRC vs ORSTHA again, keep latter
RemainingCovars = RemainingCovars[!RemainingCovars %in% "sol_ph.10cm"] ## Soil pH vs annual precipitation; the more water, the more acidic. Curious. Rain washes away alkali. Precipitation is more important for non-vegetation though.
RemainingCovars = RemainingCovars[!RemainingCovars %in% "bio4"] ## yabs vs bio4, temperature sd... Little seasonality at the equator, high seasonality at middle latitudes (40-ish). Seasonality is harder to explain and is higher correlated with everything else.
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_prec_06"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_wind_09"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "CECSOL.M.sl1"]
RemainingCovars = RemainingCovars[!RemainingCovars %in% "wc2.0_30s_tavg_05"] # can't defeat bio1
CorLong = RecalcCor(RemainingCovars, method="spearman") # 0.9 threshold reached
length(RemainingCovars) # 86
# Next is to either do lasso or stepwise with a logistic regression
toString(RemainingCovars) # This is put into utils/covariate-names.r, GetAllPixelCovars()


library(pbdPAPI, quietly=TRUE)

x <- matrix(rnorm(1e6), ncol=250)

system.flops(cov(x))


source("R/tmbImportPackages.R")

installDrawPackages <- function() {
  # define needed packages
  packages <- c("extrafont", "ggmap", "ggplot2")
  tmbImportPackages(packages)
}

#' Draw summary of all tambora data to a map
#'
#' This function allows you to draw data inquired from tambora.org to a map
#' @param tamboraData, i.e. as inquired by function fromTambora()
#' @keywords tambora.org map visualisation
#' @export
#' @examples
#' data<-fromTambora(); drawWorldMapAll(data)

drawValueBoxPlot <- function(tamboraData) {
  installDrawPackages()

  mean_index <- aggregate(tamboraData[,'si_average'], list(tamboraData$begin_year), mean)

  #match to two columns with different length by machting criteria
  data$mean <- mean_index[match(tamboraData$begin_year, mean_index$Group.1), 'x']

  ggplot(aes(y = si_average, x = begin_year), data = tamboraData, x)+
    labs(fill= "Index", x = "Year", y = "Temperature Index", title = "")+
    geom_boxplot(aes(fill=mean, group = cut_width(begin_year, 1)), outlier.alpha = 0.1)+
    scale_y_continuous(breaks=c(-3,-2,-1,0,1,2,3))+
    scale_fill_gradient2(low="blue", mid="green", high="red", limits=c(-3,+3))+
    geom_jitter(size = 0.5,  width = 0.5, height = 0.25)+
    geom_smooth()
}


fv = 10*(0:500)

axspec = formant(750, 100, 500, 5000)
axspec = axspec * formant(1250, 100, 500, 5000)
axspec = axspec * formant(2750, 100, 500, 5000)
axspec = axspec * formant(3250, 100, 500, 5000)
axspec = axspec * formant(4750, 100, 500, 5000)
axspec = axspec * hpc2(5, fv, 500)

plot(fv, 20*log10(axspec), type='l', ylab="Log Magnitude (dB)", xlab="Frequency (Hz)", ylim=c(-20,40),
		 main="F1 Frequency & Spectrum Amplitude")


# Reading in Data
ds = read.csv('Social_Network_Ads.csv')
ds = ds[, 3:5]

ds[,3] = as.factor(ds[,3])

# Scaling and splitting
library(caTools)
ds[,1:2] = scale(ds[,1:2])

split = sample.split(ds$Purchased, SplitRatio = 0.75)
train = subset(ds, split == TRUE)
test = subset(ds, split == FALSE)

#SVM
library(caret)

# k-Fold Cross Validation
clf = train(form = Purchased ~., data = train, method = 'svmRadial')
clf$bestTune


#' Range of Distribution
#'
#' Range returns a 2 index vector with the 0th index
#' containing the minimum value, and the 1st index containing the maximum value
#' for a given distribution.
#'
#' @param ... Single distribution to compute range from.
#' @param na.rm Not used; vestige of the `base::range()` S3 generic.
#' @details If there are no methods for the distribution's class,
#' the range is calculated
#' using `eval_quantile()` at 0 and at 1.
#' @examples
#' a <- dst_gpd(0, 1, 0.5)
#' b <- dst_unif(0, 1)
#' c <- dst_norm(3, 4)
#' range(a)
#' range(b)
#' range(c)
#' @rdname range
#' @export
range.dst <- function(..., na.rm = FALSE) {
  ellipsis <- rlang::list2(...)
  n <- length(ellipsis)
  if (n > 1) {
    stop("Can only find the range of one distribution; received ", n)
  }
  eval_quantile(ellipsis[[1L]], at = 0:1)
}


library(npowerPrioR)
source("data_Poisson.r")

library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

#### Sampling from the "prior"
prior <- stan_model("stan/simple_Poisson_prior.stan")

po.data <- list(
  N0 = N_0,
  y0 = y_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  a_0 = NA
)

####################
J <- 20
maxA <- 1
epsilon <- 0.05

adaptive.time <- system.time(
  adaptive.ca0.estimates <- build_grid(compiled.model.prior = prior,
                                       eps = epsilon, M = maxA, J = J, v1 = 10, v2 = 10,
                                       stan.list = po.data, pars = "lambda")
)

## Exporting
write.csv(adaptive.ca0.estimates$result, row.names = FALSE,
          file = paste("../data/constant_data/Poisson_logCA0_adaptive_J=", J, ".csv", sep = ""))


library(tidyverse)
library(rstan)
library(reshape2)
library(MASS)

load('processedDat.RData')

options(mc.cores = min(parallel::detectCores(),10))
rstan_options(auto_write = TRUE)
Sys.setenv(LOCAL_CPPFLAGS = '-march=native')

## transform data to fit anxHard.stan
stanDat <- list()

dat$id <- as.numeric(as.factor(dat$StudyId))

stopifnot(max(dat$id)==n_distinct(dat$StudyId))
stanDat$N <- max(dat$id)

dat$time <- dat$time+1

stanDat$nt <- 12

stanDat$anxObs <- as.matrix(dat%>%select(id,time,anxlevel)%>%dcast(id~time,value.var='anxlevel')%>%select(-id))
stanDat$isObsAnx <- ifelse(is.na(stanDat$anxObs),0,1)
stanDat$anxObs[stanDat$isObsAnx==0] <- 1

stanDat$subObs <- as.matrix(dat%>%select(id,time,anyHard)%>%dcast(id~time,value.var='anyHard')%>%select(-id))
stanDat$isObsSub <- ifelse(is.na(stanDat$subObs),0,1)
stanDat$subObs[stanDat$isObsSub==0] <- 1

## fill in missing values by assumption
dat$race <- as.factor(dat$Race_R)
dat$race[is.na(dat$race)] <- 1
levels(dat$race) <- names(attr(datO$Race_R,'labels'))

dat$Hispanic_R[is.na(dat$Hispanic_R)] <- 2
dat$hisp <- ifelse(dat$Hispanic_R==1,1,0)

dat$gender[is.na(dat$gender)] <- 1

X <- model.matrix(~age+gender+race+hisp+Site,
  data=dat%>%group_by(id)%>%summarize_all(function(x) x[1]))

stanDat$X <- scale(X[,-1])

stanDat$p <- ncol(X)-1

#mod <- stan('anxHard2.stan',data=stanDat,chains=1,iter=10,pars=c('anx','sub'),include=FALSE)

anxInit <- function(isObsAnx,anxObs,cAnx){
  nt <- ncol(anxObs)
  N <- nrow(anxObs)
  anx <- matrix(rnorm(nt*N,0,1),N,nt)
  anx[isObsAnx==1&anxObs==1] <- cAnx[1]-.2
  anx[isObsAnx==1&anxObs==2] <- mean(cAnx)
  anx[isObsAnx==1&anxObs==3] <- cAnx[2]+.2
  anx
}

subInit <- function(isObsSub,subObs){
  nt <- ncol(subObs)
  N <- nrow(subObs)
  sub <- matrix(rnorm(nt*N,0,1),N,nt)
  sub[isObsSub==1&subObs==0] <- -.5
  sub[isObsSub==1&subObs==1] <- .5
  sub
}

initFun <- function(){
  attach(stanDat)
  on.exit(detach(stanDat))
  anxMod <- polr(ordered(anxObs[,1])~X,method='probit')
  subMod <- glm(subObs[,1]~X,family=binomial('probit'))
  list(
    b=rnorm(1,0,.5),
    gamAnx=rnorm(1,.25,.5),
    gamSub=rnorm(1,.25,.5),
    betaAnx=coef(anxMod),
    betaSub=coef(subMod)[-1],
    #alphaAnx=rnorm(1),
    alphaSub=coef(subMod)[1],
    cAnx=anxMod$zeta,
    anx=anxInit(isObsAnx,anxObs,anxMod$zeta),
    sub=subInit(isObsSub,subObs))
}

mod <- stan('anxHard2.stan',data=stanDat,chains=4,iter=10000,pars=c('b','cAnx','gamAnx','gamSub','betaAnx','betaSub','alphaSub'),init=initFun,cores=4)
save(mod,file='anxHardMod.RData')


# Goal: To read in a simple data file, and look around it's contents.

# Suppose you have a file "x.data" which looks like this:
#        1997,3.1,4
#        1998,7.2,19
#        1999,1.7,2
#        2000,1.1,13
# To read it in --

A <- read.table("x.data", sep=",",
                col.names=c("year", "my1", "my2"))
nrow(A)                                 # Count the rows in A

summary(A$year)                         # The column "year" in data frame A
                                        # is accessed as A$year

A$newcol <- A$my1 + A$my2               # Makes a new column in A
newvar <- A$my1 - A$my2                 # Makes a new R object "newvar"
A$my1 <- NULL                           # Removes the column "my1"

# You might find these useful, to "look around" a dataset --
str(A)
summary(A)
library(Hmisc)          # This requires that you've installed the Hmisc package
contents(A)
describe(A)

# Goal: To read in a simple data file where date data is present.

# Suppose you have a file "x.data" which looks like this:
#        1997-07-04,3.1,4
#        1997-07-05,7.2,19
#        1997-07-07,1.7,2
#        1997-07-08,1.1,13

A <- read.table("x.data", sep=",",
                col.names=c("date", "my1", "my2"))
A$date <- as.Date(A$date, format="%Y-%m-%d")
       # Say ?strptime to learn how to use "%" to specify
       # other date formats. Two examples --
       # "15/12/2002"  needs "%d/%m/%Y"
       # "03 Jun 1997" needs "%d %b %Y"

       # Actually, if you're using the ISO 8601 date format, i.e.
       # "%Y-%m-%d", that's the default setting and you don't need to
       # specify the format.

A$newcol <- A$my1 + A$my2               # Makes a new column in A
newvar <- A$my1 - A$my2                 # Makes a new R object "newvar"
A$my1 <- NULL                           # Delete the `my1' column
summary(A)                              # Makes summary statistics

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/r2.r