hybrid.train.test <- function(data.set) {
  special.feature.selection <- c(2,3,4,5,6,12,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41)

  # Change feature selection here
  # feature.selection <- c(2,3,4,5,6,12,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41)
  feature.selection <- 1:41

  train.data <- data.set[['training']]
  test.data <- data.set[['testing']]
  # First layer, use decision tree to classify is.attack
  println('Training normal/abnormal data classifier...')

  # Change type of attacks here (decision.tree  random.forest  kmeans)
  # binary.type <- 'decision.tree'
  binary.type <- 'na'
  binary.start.time <- proc.time()
  binary.classifier <-
    switch(binary.type,
           decision.tree = {
             # Train a decision tree, Accuracy : 0.925
             # You can adjust minbucket here. min bucket is the smallest bucket of a leaf node in decision tree
             # binary.classifier <- rpart(is.attack ~ ., data=train.data[,c(feature.selection,43)], minbucket = 150)
             binary.classifier <- rpart(is.attack ~ ., data=train.data[,c(feature.selection,43)], minbucket = 50)
             fancyRpartPlot(binary.classifier)
             y.binary.hat <- predict(binary.classifier, test.data[,feature.selection],type='vector')
             binary.result <- confusionMatrix(as.factor(as.logical(round(y.binary.hat))), as.factor(test.data$is.attack))
           },
           random.forest = {
             # Train a random forest，Accuracy : 0.9258
             train.data.matrix  <-  train.data
             train.data.matrix[1:41] <- data.matrix(train.data[1:41])
             train.data.matrix$is.attack <- as.factor(train.data.matrix$is.attack)
             test.data.matrix <- test.data
             test.data.matrix[1:41] <- data.matrix(test.data[1:41])
             test.data.matrix$is.attack <- as.factor(test.data.matrix$is.attack)

             # You can adjuts number of trees here
             # With the increase of ntree the accuracy will improve. But will remain steady at certain point.
             # Common values are 100~2000, it is really slow to train a lot of trees.
             #binary.classifier <- randomForest(is.attack ~ ., data=train.data.matrix[,c(feature.selection, 43)],
             #                                   importance=TRUE, ntree=100, type="class")

             binary.classifier <- randomForest(is.attack ~ ., data=train.data.matrix[,c(feature.selection, 43)],
                                               importance=TRUE, ntree=10, type="class")
             y.binary.hat <- predict(binary.classifier, test.data.matrix[,feature.selection], type="class")
             binary.result <- confusionMatrix(y.binary.hat, test.data$is.attack)
           },
           kmeans = {
             # Create template and use KNN to classify data, Accuracy : 0.9228
             # Accuracy can be improved by adjusting number of centers!
             train.normal <- data.matrix(train.data[train.data$label == 'normal',
                                                    special.feature.selection])
             train.attack <- data.matrix(train.data[train.data$label != 'normal',
                                                    special.feature.selection])

             # You can change the number of centers here.
             # You can change the number of max iteration here. A common value is 100. If it shows warning:
             # like not converged in 10 rounds.

             # Number of centers can be adjusted.
             # I think it is better to have less normal centers than attacks.
             # Because we want to have fewer normal centers
             #  normal.centers <- kmeans(train.normal, centers = 5,iter.max = 100)$centers
             # attack.centers <- kmeans(train.attack, centers = 10,iter.max = 100)$centers

             normal.centers <- kmeans(train.normal, centers = 100,iter.max = 10)$centers
             attack.centers <- kmeans(train.attack, centers = 300,iter.max = 10)$centers
             x.centers <- rbind(normal.centers,  attack.centers)
             y.labels <- c(rep(FALSE,dim(normal.centers)[1]),
                           rep(TRUE,dim(attack.centers)[1]))
             y.binary.hat <- knn(x.centers, data.matrix(test.data[,special.feature.selection]), y.labels, k=1)
             binary.result <- confusionMatrix(y.binary.hat, test.data$is.attack)
           })
  binary.stop.time <- proc.time()
  print(binary.type)
  if (exists("binary.result"))
    print(binary.result)

  # Begin multi-class classification
  println('Training attack type classifier...')
  # You can change the type of classifier here: decision.tree  random.forest  kmeans  naive.bayes
  multiclass.type <- 'decision.tree'
  use.all.data <- TRUE
  train.attack <- train.data[train.data$label != 'normal',]
  test.attack <- test.data[test.data$label != 'normal',]
  multiclass.start.time <- proc.time()
  multiclass.classifier <-
    switch(multiclass.type,
           decision.tree = {
             # Train a decision tree, Accuracy : 0.9302
             # You can adjust minbucket here. min bucket is the smallest bucket of a leaf node in decision tree
             # multiclass.classifier <- rpart(attack.type ~ ., data=train.attack[,c(feature.selection,45)], minbucket = 50)
             if (use.all.data) {
               multiclass.classifier <- rpart(attack.type ~ ., data=train.data[,c(feature.selection,45)], minbucket = 150)
             } else{
               multiclass.classifier <- rpart(attack.type ~ ., data=train.attack[,c(feature.selection,45)], minbucket = 150)
             }
             fancyRpartPlot(multiclass.classifier)
             y.multiclass.hat <- predict(multiclass.classifier, test.attack[,feature.selection],type='class')
             multiclass.result <- confusionMatrix(y.multiclass.hat, test.attack$attack.type)
             post(multiclass.classifier, file='decision.tree.ps', digits=0, pretty=0)
             multiclass.classifier
           },
           random.forest = {
             # Train a random forest, please notice the confusion matrix, Accuracy : 0.9178
             if (use.all.data) {
               train.data.matrix  <-  train.data
               test.data.matrix <- test.data
             } else {
               train.data.matrix  <-  train.attack
               test.data.matrix <- test.attack
               train.data.matrix$attack.type <- factor(train.data.matrix$attack.type, levels = c("dos","probe", "r2l", "u2r"))
             }

             train.data.matrix[1:41] <- data.matrix(train.data.matrix[1:41])
             test.data.matrix[1:41] <- data.matrix(test.data.matrix[1:41])

             # You can adjuts number of trees here
             # With the increase of ntree the accuracy will improve. But will remain steady at certain point.
             # Common values are 100~2000, it is really slow to train a lot of trees.
             #binary.classifier <- randomForest(is.attack ~ ., data=train.data.matrix[,c(feature.selection, 43)],
             #                                   importance=TRUE, ntree=100, type="class")
             multiclass.classifier <- randomForest(attack.type ~ ., data=train.data.matrix[,c(feature.selection, 45)],
                                                   importance=TRUE, ntree=10, type="class")
             print(importance(multiclass.classifier))
             varImpPlot(multiclass.classifier)
             y.multiclass.hat <- predict(multiclass.classifier, test.data.matrix[,feature.selection], type="class")
             y.multiclass.hat <- factor(y.multiclass.hat, levels = c("dos","normal","probe", "r2l", "u2r"))
             multiclass.result <- confusionMatrix(y.multiclass.hat, test.data.matrix$attack.type)
             summary(multiclass.classifier)
             multiclass.classifier
           },
           kmeans = {
             # Create template and use KNN to classify data, Accuracy : 0.7711
             # Accuracy can be improved by adjusting number of centers!
             train.dos = train.data[train.data$attack.type=='dos', feature.selection]
             train.normal = train.data[train.data$attack.type=='normal', feature.selection]
             train.probe = train.data[train.data$attack.type=='probe', feature.selection]
             train.r2l = train.data[train.data$attack.type=='r2l', feature.selection]
             train.u2r = train.data[train.data$attack.type=='u2r', feature.selection]
             train.dos = data.matrix(train.dos)
             train.normal = data.matrix(train.normal)
             train.probe = data.matrix(train.probe)
             train.r2l = data.matrix(train.r2l)
             train.u2r = data.matrix(train.u2r)

             # You can change the number of centers here.
             # You can change the number of max iteration here. A common value is 100. If it shows warning:
             # like not converged in 10 rounds.

             # I think it is better to have fewer dos centers than others because there are so many of them
             # We do not need to attrack more points. Others should have more centers.
             # Warning, you can have more centers than your points.
             #  Example:normal.centers <- kmeans(train.normal, centers = 5,iter.max = 100)$centers

             dos.centers = kmeans(train.dos, centers = 60 ,iter.max = 10)$centers
             normal.centers = kmeans(train.normal, centers = 30,iter.max = 10)$centers
             probe.centers = kmeans(train.probe, centers = 10,iter.max = 10)$centers
             r2l.centers = kmeans(train.r2l, centers = 10,iter.max = 10)$centers
             u2r.centers = kmeans(train.u2r, centers = 10,iter.max = 10)$centers
             if (use.all.data) {
               y.labels = c(rep('dos',dim(dos.centers)[1]),
                            rep('normal',dim(normal.centers)[1]),
                            rep('probe',dim(probe.centers)[1]),
                            rep('r2l',dim(r2l.centers)[1]),
                            rep('u2r',dim(u2r.centers)[1]))
               x.centers = rbind(dos.centers,
                                 normal.centers,
                                 probe.centers,
                                 r2l.centers,
                                 u2r.centers)
             } else {
               y.labels = c(rep('dos',dim(dos.centers)[1]),
                            rep('probe',dim(probe.centers)[1]),
                            rep('r2l',dim(r2l.centers)[1]),
                            rep('u2r',dim(u2r.centers)[1]))
               x.centers = rbind(dos.centers,
                                 probe.centers,
                                 r2l.centers,
                                 u2r.centers)
             }

             y.multiclass.hat <- knn(x.centers, data.matrix(test.attack[,feature.selection]), y.labels, k=1)
             y.multiclass.hat <- factor(y.multiclass.hat, levels = c("dos","normal","probe", "r2l", "u2r"))
             multiclass.result <- confusionMatrix(y.multiclass.hat, test.attack$attack.type)
           },
           naive.bayes = {
             # Build a naive bayes classifier, Accuracy : 0.7575
             if (use.all.data) {
               multiclass.classifier <- naiveBayes(attack.type ~ ., data = train.data[,c(feature.selection, 45)])
             } else {
               multiclass.classifier <- naiveBayes(attack.type ~ ., data = train.attack[,c(feature.selection, 45)])
             }

             y.multiclass.hat <- predict(multiclass.classifier, test.attack[,feature.selection], type="class")
             y.multiclass.hat <- factor(y.multiclass.hat, levels = c("dos","normal","probe", "r2l", "u2r"))
             multiclass.result <- confusionMatrix(y.multiclass.hat, test.attack$attack.type)
             multiclass.classifier
           })
  multiclass.stop.time <- proc.time()
  print(multiclass.type)
  print(multiclass.result)
  println('Time used for binary classfication:')
  print(binary.stop.time - binary.start.time)
  println('Time used for multiclass classfication:')
  print(multiclass.stop.time - multiclass.start.time)
  println('Total time used:')
  print(multiclass.stop.time - binary.start.time)
  println('Doing overall test:')

  if (multiclass.type =='kmeans') {
    y.multiclass.hat <- knn(x.centers, data.matrix(test.data[,feature.selection]), y.labels, k=1)
  } else if (multiclass.type == "random.forest") {
    test.data.matrix <- test.data
    test.data.matrix[1:41] <- data.matrix(test.data[1:41])
    y.multiclass.hat <- predict(multiclass.classifier, test.data.matrix[,feature.selection], type="class")

  } else {
    y.multiclass.hat <- predict(multiclass.classifier, test.data[,feature.selection],type='class')
  }

  # The first layer exists
  if (binary.type == 'decision.tree') {
    y.hat = round(y.binary.hat)
    y.hat = as.character(as.logical(y.hat))
  } else if (binary.type %in% c('random.forest','kmeans')){
    y.hat = as.character(y.binary.hat)
  }

  if (binary.type %in% c('decision.tree', 'random.forest', 'kmeans')) {
    y.hat[y.hat == 'TRUE'] <- as.character(y.multiclass.hat[y.hat == 'TRUE'])
    y.hat[y.hat == 'FALSE'] <- 'normal'
  } else {
    # Only one layer exists
    y.hat = as.character(y.multiclass.hat)
  }

  y.hat = as.factor(y.hat)
  y.hat <- factor(y.hat, levels = c("dos","normal","probe", "r2l", "u2r"))
  println("**********  Overall result")
  print(confusionMatrix(y.hat, test.data$attack.type))
}


library(MASS)
library(ggplot2)
library(gridExtra)
library(reshape2)
library(grid)

sample_predictive_posterior <- function(P_test, traces_coefficients, traces_intercept, traces_noise_inv){
  nsamples <- nrow(traces_coefficients)

  # add intercept to the rets of coefficients
  P_test <- rbind(1,P_test)
  traces_coefficients <- cbind(traces_intercept, traces_coefficients)
  T_test = dim(P_test)[2]
  y_preds <- matrix(0, nrow=nsamples, T_test)
  for(i in 1:nsamples){
    # a prediction over all the test threads
    b = traces_coefficients[i,]
    noise = 1/sqrt(traces_noise_inv[i])
    means <- t(P_test)%*%b
    y_preds[i,] <- sapply(1:T_test, function(i) {rnorm(1, mean=means[i], sd=noise)})
  }
  # return samples from the posterior (one sample is a prediction over all the threads in the test set)
  y_preds
}

plot_predictive_posterior <- function(samples){
  # """
  # Plot posterior mean with 50 and 95 confidence bands.
  #
  # Parameters:
  # ==========
  # samples: array with one sample of posterior in every row
  x <- 1:dim(samples)[2]

  # Posterior mean and credible intervals
  df <- data.frame(thread=1:ncol(samples), mean=colMeans(samples))
  df$ci_upper50 <- apply(samples, 2, quantile, 0.75)
  df$ci_lower50 <- apply(samples, 2, quantile, 0.25)
  df$ci_upper95 <- apply(samples, 2, quantile, 0.975)
  df$ci_lower95 <- apply(samples, 2, quantile, 0.025)

  p <- ggplot(df, aes(x=thread, y=mean))
  p <- p + geom_ribbon(aes(ymin=ci_lower95, ymax=ci_upper95), fill=gray(0.5), alpha=1)
  p <- p + geom_ribbon(aes(ymin=ci_lower50, ymax=ci_upper50), fill=gray(0.8), alpha=1)
  p <- p + geom_line(aes(x=thread, y=mean), color="black")
  p <- p + xlab('Threads')
  p <- p + ylab('Predictive posterior')
  p <- p + labs(color=NULL)
  p <- p + scale_colour_discrete(guide = FALSE)
  p <- p + scale_alpha_identity(guide = FALSE)
  p <- p + theme(text = element_text(size = 15),
                 panel.background = element_blank(),
                 panel.grid.major = element_blank(),
                 panel.grid.minor = element_blank(),
                 axis.line = element_line(colour = "black"),
                 legend.key = element_rect(fill = "white"),
                 legend.position=c(0.1, 0.8))
  print(p)
  p
}
plot_clustering_posterior <-function(samples){
  # Plot posterior of pairwise co-ocurrence matrix
  # Args:
  # samples: traces of cluster assignments
  coincidences <- sapply(1:ncol(samples), function(i){ colSums(samples[,i]==samples) })

  # From X1, X2 to 1,2...
  rownames(coincidences) <- 1:nrow(coincidences)
  p <- ggplot(melt(coincidences), aes(Var1,Var2, fill=value)) + geom_raster(vjust=0.5, hjust=0.5)
  p <- p + scale_fill_continuous(guide = FALSE)
  p <- p + coord_fixed() # preserve aspect ratio
  p <- p + xlab('users')
  p <- p + ylab('users')
  p <- p + scale_y_continuous(trans = "reverse", expand=c(0,0), breaks=c(10,20,3,40,50))
  p <- p + scale_x_continuous(expand=c(0,0), breaks=c(10,20,3,40,50))
  p <- p + theme(text = element_text(size = 15),
                 panel.background = element_blank(),
                 #axis.ticks = element_blank(),
                 #axis.text = element_blank(),
                 axis.line = element_blank())
  p
}
plot_posterior <- function(experiment){

  burnin <- 100

  # Get traces of the posterior distribution, and test set
  traces.path <- file.path(experiment, 'traces')
  plots.path <- file.path(experiment, 'plots') # store figure here
  P_test <- read.csv(file.path('data', dataset, "test_participations_50.csv"), sep='\t')
  y_test <- read.csv(file.path('data', dataset, "test_lengths_50.csv"), sep='\t')$y

  # Posterior over the parameters that allow the prediction
  traces_coefficients <- read.csv(file.path(traces.path, 'traces.coefficients.trc'), sep='')[-c(1:burnin),]
  traces_intercept <- read.csv(file.path(traces.path, 'traces.intercept.trc'), sep='')[-c(1:burnin),]$intercept
  traces_noise_inv <- read.csv(file.path(traces.path, 'traces.noise_inv.trc'), sep='')[-c(1:burnin),]
  traces_coefficients <- as.matrix(traces_coefficients)
  traces_noise_inv <- as.matrix(traces_noise_inv)

  # Take samples from posterior predictive distribution
  y_samples <- sample_predictive_posterior(P_test, traces_coefficients, traces_intercept, traces_noise_inv)

  # Plot posterior distribution (with threads sorted by length)
  idx_sorted <- order(y_test)
  p1 <- plot_predictive_posterior(y_samples[,idx_sorted])
  p1 <- p1 + geom_line(y=y_test[idx_sorted], color="red") # add true lengths

  # Plot confusion matrix
  traces_z <- read.csv(file.path(traces.path, 'traces.z.trc'), sep='')[-c(1:burnin),]
  p2 <- plot_clustering_posterior(traces_z)

  # Put both plots together
  g1<-ggplotGrob(p1)
  g2<-ggplotGrob(p2)
  grid.newpage()
  grid.draw(cbind(g1, g2, size = "first"))

  #..and save to file
  dir.create(file.path(plots.path), recursive=TRUE)
  dev.copy(png, file.path(plots.path, 'posterior.png'))
  dev.off()
  g <- grid.grab()
  g<- grid.arrange(g1, g2, widths=c(0.5,0.5))
  ggsave(file.path(plots.path, 'posterior_ggsave.png'), plot = g)
}


rm(list = ls(all = TRUE))
#http://etfprophet.com/days-since-200-day-highs/

require(quantmod)
getSymbols('^GSPC',from='1900-01-01')

daysSinceHigh <- function(x, n){
   apply(embed(x, n), 1, which.max)-1
}

myStrat <- function(x, nHold=100, nHigh=200) {
	position <- ifelse(daysSinceHigh(x, nHigh)<=nHold,1,0)
	c(rep(0,nHigh-1),position)
}

myStock <- Cl(GSPC)
myPosition <- myStrat(myStock,100,200)
bmkReturns <- dailyReturn(myStock, type = "arithmetic")
myReturns <- bmkReturns*Lag(myPosition,1)
myReturns[1] <- 0

names(bmkReturns) <- 'SP500'
names(myReturns) <- 'Me'


library(ggplot2)

# Exploratory data analysis

# Does brainweight influence the hours that a mammal need to sleep?

g <- ggplot(data = msleep)+
  geom_point(aes(x=brainwt, y=sleep_total))

# many mammals with small brains and very few with large brains -> log of x axis

g <- g + scale_x_log10()

# Are there differences depending on type of food source
# Does not seem that way
# We can also
g2 <- ggplot(data = msleep)+
  geom_point(aes(x=brainwt, y=sleep_total, color = vore)) +
  scale_x_log10()

# If we don't like the colors used for the color aesthetic, we can change it:
g2 + scale_color_ordinal(na.value = "grey")
g2 + ggsci::scale_color_rickandmorty()
g2 + ggsci::scale_colour_npg()
g2 <- g2 + scale_color_manual(values = c("dodgerblue4",
                                   "darkolivegreen4",
                                   "darkorchid3",
                                   "orange", "grey"))

# does this relationship depend on conservation status?
g2 +
  facet_grid(conservation~.)

# Can we add a title to this graph?
g2 +
  labs(x = "a", y="b", title = "t")

# change the appearance
g2<- g2 + theme_bw()+theme(axis.text = element_text(face = "bold"))

# Boxplots

plastics <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-01-26/plastics.csv')

ggplot(plastics, aes(x=year, y=grand_total))+
  geom_boxplot()

# Oh no what happened here?
# Alison continous vs. categorical data

ggplot(plastics, aes(x=factor(year), y=grand_total))+
  geom_boxplot()+
  geom_violin()+
  scale_y_log10()

ggplot(data = msleep, aes(x=vore, y = sleep_rem, color = vore)) +
  geom_boxplot(outlier.alpha = 0, color = "gray") +
  geom_point(alpha = 0.8, size = 3, position = position_jitter(width = 0.1)) +
  scale_fill
  labs(y = "sleep rem (h)", x = "Eating behaviour",
       title = "Do carnivores sleep deeper than herbivores?")+
  theme_light()+
  theme(
    legend.position = "none"
)

# Barcharts

# Histograms

# test other data ---------------------------------------------------------
# This could be group exercises at the end of the day
# Each group with a different dataset

forest <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-04-06/forest.csv')
forest_area <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-04-06/forest_area.csv')
brazil_loss <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-04-06/brazil_loss.csv')
soybean_use <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-04-06/soybean_use.csv')
vegetable_oil <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-04-06/vegetable_oil.csv')

ggplot(brazil_loss, aes(x=year, y=commercial_crops))+
  geom_line()

# And still other data ----------------------------------------------------

plastics <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-01-26/plastics.csv')

ggplot(plastics, aes(x=year, y=grand_total))+
  geom_boxplot()

# other -------------------------------------------------------------------

plants <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2020/2020-08-18/plants.csv')

# linear models - penguin data --------------------------------------------
# might be that you have to install the packages see and qqplotr if you get
# errors when checking the model
library(palmerpenguins)
library(ggplot2)
library(performance)
# do larger penguins generally have a longer bill? -> regression

ggplot(penguins, aes(x=body_mass_g, y=bill_length_mm)) +
  geom_point() +
  geom_smooth(method = "lm", alpha = 0)

lm1 <- lm(bill_length_mm ~ body_mass_g, data = penguins)

# looks not perfect
# Some bariance not really constant and residuals are higher than expected from a
# normal distribution for high and low values respectively (see also distribution)
# think about possible reasons -> is it just the data that looks like this or might we need
# another explanatory variable?

check_model(lm1)

# we might have to consider species as well? -> Ancova
# The green species has considerably higher residuals than the others

ggplot(penguins, aes(x=body_mass_g, y=bill_length_mm)) +
         geom_point(aes(color = species)) +
  geom_smooth(method = "lm", alpha = 0, formula = y~x)

# is this effect different between species? -> Ancova
# note that if we put color in the top level aesthetics, also the linear model
# lines are added by group
ggplot(penguins, aes(x=body_mass_g, y=bill_length_mm, color = species)) +
  geom_point() +
  geom_smooth(method = "lm", alpha = 0)

# without interaction
lm2 <- lm(bill_length_mm ~ body_mass_g + species, data = penguins)

# Hey now the assumptions look pretty good if we add species as explanatory variable
check_model(lm2)

anova(lm2)
summary(lm2)

# with interaction
lm2b <- lm(bill_length_mm ~ body_mass_g * species, data = penguins)

# Hey now the assumptions look pretty good if we add species as explanatory variable
# colinearity in this case does not matter because it is the interaction that is of course related
check_model(lm2b)

anova(lm2b)
summary(lm2b)

# Do penguins differ in weight between sex and does this depend on species?

ggplot(penguins, aes(x=sex, y=body_mass_g, color = species))+
  geom_boxplot(notch = TRUE)

lm3 <- lm(body_mass_g ~ sex * species, data = penguins)

# looks pretty good
check_model(lm3)

anova(lm3)

# Add model results to the plot
ggplot(penguins, aes(x=sex, y=body_mass_g, color = species))+
  geom_boxplot(notch = TRUE, position = position_dodge(width = 1)) +
  stat_summary(position = position_dodge(width = 1),
               fun = mean)

# linear models - slides --------------------------------------------------
library(tidyverse)
prod <- readr::read_tsv(here::here("day_03/data/05_productivity.txt"))

# make site a factor
prod <- mutate(prod, across(site, as_factor))

# Hypothesis 1: Productivity increases with species richness:
ggplot(prod, aes(x=richness, y=productivity))+
  geom_point()

# looks like yes
# fit a linear regression model
lm1 <- lm(productivity ~ richness, data = prod)
lm1a <- lm(productivity ~ richness, data = prod[prod$site == "site1",])
lm1b <- lm(productivity ~ richness, data = prod[prod$site == "site2",])
# Test whether the model is better than the null model (mean)
anova(lm1)
# Want to see the coefficients?
summary(lm1)
# extract coefficients
intercept <- lm1$coefficients[1]
slope <- lm1$coefficients[2]

# add to plot
# option 1: ab line with slope and intercept
ggplot(prod, aes(x=richness, y=productivity))+
  geom_point()+
  geom_abline(intercept = intercept, slope = slope)
#option 2 geom_smooth
ggplot(prod, aes(x=richness, y=productivity))+
  geom_point()+
  geom_smooth(method ="lm") # default formula = y~x

# Test assumptions
# install.packages("performance")
library(performance)
library(lindia)
check_model(lm1)
#---

# Hypothesis 2: Maybe both factors influence productivity?
ggplot(prod, aes(x=richness, y=productivity, color = site))+
  geom_point()

# make model:
lm3 <- lm(productivity ~ richness + site + richness:site, data = prod)
lm4 <- lm(productivity ~ richness + site, data = prod) # whats the difference

anova(lm3)
anova(lm4)
drop1(lm3, test = "F")

summary(lm3)
summary(lm4)

# make a plot
ggplot(prod, aes(x=richness, y=productivity, color = site))+
  geom_point() +
  geom_smooth(method = "lm")

# but: This is with interaction. Maybe we want to plot without the interaction?
# extract coefficients and plot ab lines

# Check assumptions
check_model(lm3) # collinearity makes sense
check_model(lm4) #  are okay

# plot lm4 with slopes and intercepts

lm4_slope <- lm4$coefficients[2]
lm4_intercept1 <- lm4$coefficients[1]
lm4_intercept2 <- lm4$coefficients[1] + lm4$coefficients[3]

ggplot(prod, aes(x=richness, y=productivity, color= site))+
  geom_point() +
  geom_abline(slope = lm4_slope, intercept = lm4_intercept1 , color = "red")+
  geom_abline(slope = lm4_slope, intercept = lm4_intercept2 , color = "blue")

# or using the predict function
pred_data <- expand_grid(
  richness = min(prod$richness):max(prod$richness),
  site = c("site1", "site2")
)
predictions <- predict(lm4, newdata = pred_data)
pred_data$productivity <- predictions

ggplot(prod, aes(x=richness, y=productivity, color= site))+
  geom_point() +
  geom_line(data= pred_data)

# chickwts lm -------------------------------------------------------------

chicks_lm <- lm(weight~feed, data = chickwts)

ggplot(chickwts, aes(x=feed, y=weight))+
  geom_boxplot()

# Cédric version

chickwts %>%
  mutate(feed = as.factor(feed)) %>%
  mutate(feed = fct_reorder(feed, -weight)) %>%
  ggplot(aes(x=feed, y=weight, color = feed))+
  geom_boxplot()+
  #geom_point(size = 3, alpha = 0.15)+
  geom_jitter(size = 3, alpha = 0.25, width = 0.2)+
  coord_flip()+
  ggsci::scale_color_uchicago()+
  labs(y = "weight [g]", x = "Diet")+
  theme(legend.position = "none")

# npp data ----------------------------------------------------------------

npp <- read_tsv(here::here("day_03/data/06_npp.txt"))

ggplot(npp, aes(x=fertilized, y = npp, fill = flooding))+
  geom_boxplot()+
  facet_wrap(~beaver)

# Hypothesis??? Seems to be an interaction between fertilized and flooding

npp_lm <- lm(npp ~ fertilized + flooding + beaver + fertilized : flooding, data = npp)

check_model(npp_lm)

predict(npp_lm, newdata = data.frame(fertilized = "no", flooding = "rarely", beaver = "no"))

# log-transformation ------------------------------------------------------

msleep
ggplot(msleep, aes(x = awake, y = brainwt))+
  geom_point()+
  scale_y_log10()

sleep_mod <- lm(brainwt ~ awake, data = msleep)
sleep_mod2 <- lm(log(brainwt) ~ awake, data = msleep)
check_model(sleep_mod) # bad -> pattterns in residuals
check_model(sleep_mod2) # much better

# add preditions to plot -> on the log scale

ggplot(msleep, aes(x = sleep_total, y = brainwt))+
  geom_point()+
  geom_smooth(method = "lm") + # careful if you have models with or withour interaction
  scale_y_log10()

# but what if we want to plot our data on the normal scale?
ggplot(msleep, aes(x = sleep_total, y = brainwt))+
  geom_point()+
  geom_smooth(method = "lm")  # careful if you have models with or withour interaction

# use predict function

pred_data <- tibble(sleep_total = min(msleep$sleep_total):max(msleep$sleep_total))
predictions <- predict(sleep_mod2, newdata = pred_data)
# backtransform the predictions and add them to the pred_data tibble
pred_data$brainwt <- exp(predictions)

ggplot(msleep, aes(x=sleep_total, y = brainwt))+
  geom_point()+
  geom_line(data = pred_data, color = "red")

# log-transform decay -----------------------------------------------------

decay <- read_tsv("day_03/data/Decay.txt")
# no transformation
ggplot(decay, aes(x= time, y=amount))+
  geom_point()
# log transformed response
# no transformation
ggplot(decay, aes(x= time, y=amount))+
  geom_point()+
  scale_y_log10()

mod <- lm(log(amount)~time, data = decay)

# Add model to data
# on transformed scale:
ggplot(decay, aes(x= time, y=amount))+
  geom_point()+
  scale_y_log10()+
  geom_smooth(method = "lm")

# on the original scale using predict
pred_data <- tibble(time = 0:30)
amount_pred <- predict(mod, newdata = pred_data)
# backtransform to original scale
pred_data$amount <- exp(amount_pred)

ggplot(decay, aes(x= time, y=amount))+
  geom_point()+
  geom_line(data = pred_data)

# or using the fancy thing (which does not produce the same results)
ggplot(decay, aes(x= time, y=amount))+
  geom_point()+
  geom_smooth(method = "glm", method.args = list(family = gaussian(link = "log")))

# tidyr -------------------------------------------------------------------

library(tidyverse)

table1 <- tibble(
  country = rep(c("Afghanistan", "Brazil", "China"), each = 2),
  year = rep(c(1999L, 2000L), 3),
  cases = c(745L, 2666L, 37737L, 80488L, 212258L, 213768L),
  population = c(19987071L, 20595360L, 172006362L, 174504898L, 1272915272L, 1280428583L)
)

table2 <- pivot_longer(table1, cols = c("cases", "population"),
                       names_to = "type", values_to = "count")

table3<- unite(table1, col = "rate", c("cases", "population"), sep = "/")
# cases
table4a <- table1 %>%
  select(-population) %>%
  pivot_wider(names_from = "year", values_from = "cases")
# population
table4b <- table1 %>%
  select(-cases) %>%
  pivot_wider(names_from = "year", values_from = "population")

# Problem 1: variable split between columns -------------------------------

cities <- c("Istanbul", "Moscow", "London", "Saint Petersburg", "Berlin", "Madrid", "Kyiv", "Rome", "Bucharest", "Paris")
population <- c(15.1e6, 12.5e6, 9e6, 5.4e6, 3.8e6, 3.2e6, 3e6, 2.8e6, 2.2e6, 2.1e6)
area_km2 <- c(2576, 2561, 1572, 1439,891,604, 839, 1285, 228, 105 )

country <- c("Turkey", "Russia", "UK", "Russia", "Germany", "Spain",
                        "Ukraine", "Italy", "Romania", "France")
# tidy
tidy <- tibble(city = cities,
           population = population,
           area_km2 = area_km2,
           country = country)

# untidy
# Problems:
# each row has multiple observations
# at the same time each observation is split across multiple rows (cases and population)
# the variable location is split into multiple columns
# variable country and city are united

untidy1 <- unite(tidy, col = "location", c("country", "city")) %>%
  pivot_longer(c("population", "area_km2"), names_to = "type") %>%
  pivot_wider(names_from = "location", values_from = "value")

# fix untidy 1:
# step 1: fix location in multiple columns
step1 <- untidy1 %>%
  pivot_longer(c(Turkey_Istanbul:France_Paris), names_to = "location")

# step2: split location into the variables country and city
step2 <- step1 %>%
  separate(location, sep = "_", into = c("country", "city"))

# step3: observation and population into one row
step3 <- step2 %>%
  pivot_wider(names_from = type, values_from = value)
# Tada

# dplyr -------------------------------------------------------------------

library(tidyverse)
library(jsonlite)

soybean_use <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-04-06/soybean_use.csv')

# Filter

# filter Germany
filter(soybean_use, entity == "Germany")
# filter Germany, Austria and Switzerland
countries_select <- c("Germany", "Austria", "Switzerland")
filter(soybean_use, entity %in% countries_select)
# only filter countries with a country code:
filter(soybean_use, is.na(code))
filter(soybean_use, !is.na(code))
# with relational and logical operators:
filter(soybean_use, between(year, 1970, 1980) & entity == "Germany")

# Select
# select entity, year and human_food:
select(soybean_use, entity, year, human_food)
# remove variables
select(soybean_use, -entity, -year, -human_food)
# starts_with
select(soybean_use, starts_with("p"))
select(soybean_use, ends_with("d"))
# contains
select(soybean_use, contains("code") | contains("year"))
# select multiple cols
select(soybean_use, 1:3)
select(soybean_use, code:animal_feed)

# mutate
# create a new variable with ifelse
mutate(soybean_use, single_country = ifelse(is.na(code), FALSE, TRUE))
# case when -> like if else but more complex
# assume in 180 they passed leg1, and in 2000 they changed it to leg2
mutate(soybean_use, legislation = case_when(
  year < 2000 & year >=1980 ~ "leg_1",
  year >= 2000 ~ "leg_2",
  TRUE ~ "no_leg"
))

# transmute
# create new columns and only keep the new columns
transmute(soybean_use,
          ratio_processed_animal = processed/animal_feed,
          ratio_human_animal = human_food/animal_feed)

# Arrange
# reorder data
# lowest processed first
arrange(soybean_use, processed)
# highest
arrange(soybean_use, desc(year), desc(processed))

# Summarise alone
# what happened here?
summarise(soybean_use,
          total_animal = sum(animal_feed),
          total_human = sum(human_food))

# collapse the entire data into one row
summarise(soybean_use,
          total_animal = sum(animal_feed, na.rm = TRUE),
          total_human = sum(human_food, na.rm = TRUE))

# With group by
soybean_use_group <- group_by(soybean_use, year)

summarise(soybean_use_group,
          total_animal = sum(animal_feed, na.rm = TRUE),
          total_human = sum(human_food, na.rm = TRUE))

# count

count(soybean_use, entity)

# Pipe
# combine operations
soybean_use %>%
  filter(!is.na(code)) %>%
  group_by(year) %>%
  summarise(
    mean_processed = mean(processed, na.rm=TRUE),
    sd_processed = sd(processed, na.rm = TRUE)
  ) %>%
  arrange(desc(year))

# simple pipe
soybean_use %>%
  count(year)

plot <-data.frame(x = c(1,2,3), y= c(1,2.5,2))%>%
  ggplot(aes(x=x, y=y)) +
  geom_point(size=3)+
  geom_abline(intercept = 0.2, slope= .7, color = "red")+
  scale_y_continuous(expand = c(0,0), limits = c(0,3.5)) +
  scale_x_continuous(expand = c(0,0), limits = c(0,3.5)) +
  geom_segment(x=1, y=0.9, xend = 1, yend=1,linetype = "dashed")+
  geom_segment(x=2, y=1.6, xend=2, yend=2.5,linetype = "dashed")+
  geom_segment(x=3, y=2.3, xend=3, yend=2,linetype = "dashed")+
  annotate(geom = "text", x = 2.1, y= 2.5, label = "Y[i]",parse = TRUE, size = 8)+
  annotate(geom = "text", x = 2.1, y= 1.4, label = latex2exp::TeX("$\\hat{Y}_i$"),
           parse = TRUE, size = 8, color = "red")+
  theme(axis.text = element_text(size = 20),
        axis.title = element_text(size = 20))

ggsave("slides/img/residual.png", plot)

# GLMs --------------------------------------------------------------------

# poisson -----------------------------------------------------------------
library(tidyverse)
specdat <- read_tsv("day_03/data/species.txt")

ggplot(specdat, aes(y=Species, x=Biomass, color = pH))+
  geom_point()

mod1 <- glm(Species~Biomass + pH + Biomass:pH, data = specdat,
         family = "poisson")
# can't interpret the coefficients anymore because on scale of link function
summary(mod1)

# Hypothesis testing with Chisq test
drop1(mod1, test = "Chisq")

# plot results
pred_dat <- expand_grid(
  Biomass = seq(from = min(specdat$Biomass), to = max(specdat$Biomass), length.out = 200),
  pH = unique(specdat$pH)
)
# predict species with the new data
pred_dat$Species <- predict(mod1, newdata = pred_dat,
                            type = "response") #<<

ggplot(specdat, aes(y=Species, x=Biomass, color = pH))+
  geom_point()+
  geom_line(data = pred_dat)

# or with geom_smooth
ggplot(specdat, aes(y=Species, x=Biomass, color = pH))+
  geom_point()+
  geom_smooth(method = "glm", method.args = list(family = "poisson"))

# Tests -------------------------------------------------------------------
library(tidyverse)
set.seed(123)

mydata <- tibble(
  normal = rnorm(n = 400, mean = 50, sd = 5),
  non_normal = runif(n = 400, min = 45, max = 55)
)

mydata %>%
  pivot_longer(cols = 1:2, names_to = "type", values_to = "value") %>%
  ggplot()+
  geom_histogram(alpha = 0.5, aes( x = value, fill = type,y = ..density..)) + # plot probability instead of count on y axis
  stat_function(fun = dnorm,
                args = list(mean = 50,
                            sd = 5),
                color = "darkorange", size = 1)+
  stat_function(fun = dnorm,
                args = list(mean = mean(mydata$non_normal),
                            sd = sd(mydata$non_normal)),
                color = "cyan4", size = 1)+
    scale_fill_manual(values = c("cyan4", "darkorange"))+
  theme(legend.position = c(0.85,0.85))

# ks.test -----------------------------------------------------------------

ks.test(mydata$normal, "pnorm", mean = mean(mydata$normal),
        sd = sd(mydata$normal))

ks.test(mydata$non_normal, "pnorm", mean = mean(mydata$non_normal),
        sd = sd(mydata$non_normal))

# Shapiro wilk ------------------------------------------------------------

shapiro.test(mydata$normal)
shapiro.test(mydata$non_normal)

# QQ ----------------------------------------------------------------------

ggplot(mydata, aes(sample = normal)) + stat_qq() + stat_qq_line()

ggplot(mydata, aes(sample = non_normal)) + stat_qq() + stat_qq_line()

# Ftest -------------------------------------------------------------------

InsectSprays

TreatA <- InsectSprays[InsectSprays$spray == "A",]$count
TreatB <- InsectSprays[InsectSprays$spray == "B",]$count
TreatE <- InsectSprays[InsectSprays$spray == "E",]$count

TreatA <- filter(InsectSprays, spray == "A")$count
TreatB <- filter(InsectSprays, spray == "B")$count
TreatE <- filter(InsectSprays, spray == "E")$count

shapiro.test(TreatA) #normal
shapiro.test(TreatB) # normal
shapiro.test(TreatE) # normal

var.test(TreatA, TreatB) # equal
var.test(TreatA, TreatE) # not equal

#---
# A,B,E: Normal distr.
# AB equal var

t.test(TreatA, TreatB, var.equal = TRUE)
t.test(TreatA, TreatE, var.equal = FALSE)
wilcox.test(TreatA, TreatB)

# paired data points
# before and after
#


master.file.df <- as.data.frame(fread(paste(input.local.data.dir,"master.file.csv",sep="")))
master.file.df <- subset(master.file.df, use.this == "yes")

# do summary of each dataset: size of data, predictors, distribition of continuous and categorical

dataset.names <- unique(master.file.df$dataset)

dataset.summaries <- NULL
for(this.dataset in dataset.names){

  print(this.dataset)
  this.dataset.df <- as.data.frame(fread(paste(input.data.dir,"ml-datasets/",this.dataset,".data.txt",sep="")))

  this.response.index <- ifelse(subset(master.file.df, dataset == this.dataset)$index.of.response == "last", ncol(this.dataset.df), 1)

  these.levels <- unique(this.dataset.df[,this.response.index])
  n.levels <- length(these.levels)
  this.summary <- data.frame(dataset = this.dataset, n=nrow(this.dataset.df), response.levels=paste(these.levels, collapse=";"),n.levels=n.levels, n.predictors=(ncol(this.dataset.df)-1))
  dataset.summaries <- rbind(dataset.summaries, this.summary)

}

dataset.summaries <- dataset.summaries[order(dataset.summaries$n), ]

write.table(dataset.summaries, file = paste(output.local.data.dir, "ml-dataset-summaries.csv",sep=""), quote = FALSE,row.names=FALSE, sep=",", na="")

########################################
#####    Cluster Into Groups      ######
########################################

n.clusters <- 5
method <- "n"
file.prefix <- paste("ClusterVar-",method,"-K-", n.clusters, sep="")

if(method == "both"){
  k.means <- kmeans(dataset.summaries[,c("n", "n.predictors")] ,n.clusters)
}else{
  k.means <- kmeans(dataset.summaries[,c("n")],n.clusters)
}

dataset.summaries$cluster <- k.means$cluster

cluster.summary <- with(dataset.summaries, tapply(n, cluster, mean))
cluster.summary <- data.frame(value=cluster.summary, cluster=seq(1:nrow(cluster.summary)))
cluster.summary <- cluster.summary[order(-cluster.summary$value),]
cluster.summary$new_cluster1 <- seq(1,nrow(cluster.summary))
clusterMap <- hash(keys=as.character(cluster.summary$cluster), values= cluster.summary$new_cluster1)

dataset.summaries$dataset.cluster  <-  unlist(sapply( dataset.summaries[,"cluster"], function(x) { clusterMap[[as.character(x)]] } ))
dataset.summaries <- dataset.summaries[order(dataset.summaries$n),]

write.table(dataset.summaries, file = paste(output.local.data.dir, "ml-dataset-summaries-clustered.csv",sep=""), quote = FALSE,row.names=FALSE, sep=",", na="")

summaryObj <- summary(as.factor(dataset.summaries$dataset.cluster))
summary.df <- data.frame(cluster=names(summaryObj), count=summaryObj)
write.table(summary.df, file = paste(output.local.data.dir, "ml-dataset-summaries-cluster-summary.csv",sep=""), quote = FALSE,row.names=FALSE, sep=",", na="")

par(font=2)
pdf(file = paste(output.local.data.dir,"Dataset-Cluster-Quandrant-", file.prefix, ".pdf",sep=""))

ggplot() +
  geom_point(data=dataset.summaries, mapping=aes(x=log(n), y=log(n.predictors),color=factor(dataset.cluster)), width=1.5, size=4, fill="white") +
  labs(title = paste(file.prefix, sep=""),x = "Log[Dataset Size (n)]", y = "Log[Number of Predictors]") +
  theme_bw() +
  theme(legend.text = element_text(size = 14, colour = "black"),plot.title = element_text(size = 18),text = element_text(size=16))+
  scale_colour_brewer(name = "Cluster",palette="Set1")

dev.off();
par(font=1)


#! /usr/bin/Rscript
setwd("/var/textBasedIR/")
library(ggplot2)
df <- read.csv("flickr8k_unigram_hybrid_results.csv",
               header = FALSE,
               col.names = c("method", "lambda",
                             "recall@1", "mrr"))

setwd("/home/mandar/Desktop/")
p1 <- ggplot(df, aes(x = recall.1, y = mrr)) +
  geom_point(size=3, aes(color=factor(method), shape=factor(method))) +
  geom_smooth(aes(color=factor(method)), method = "lm", se = FALSE) +
  theme_bw() +
  theme(
    axis.title.x = element_text(face="bold", color="black", size=12),
    axis.title.y = element_text(face="bold", color="black", size=12),
    plot.title = element_text(face="bold", color = "black", size=12),
    legend.position=c(1,1),
    legend.justification=c(1,1)) +
  labs(x="Recall@1",
       y = "Mean Reciprocal Rank",
       title= "Linear Regression (95% CI) of Mean Reciprocal Rank vs Recall@1, by selection method")

p2 <- ggplot(df, aes(x = lambda, y = mrr))+
  geom_point(size=3, aes(color=factor(method), shape=factor(method))) +
  geom_smooth(aes(color=factor(method)), method = "lm", se = FALSE) +
  theme_bw() +
  theme(
    axis.title.x = element_text(face="bold", color="black", size=12),
    axis.title.y = element_text(face="bold", color="black", size=12),
    plot.title = element_text(face="bold", color = "black", size=12),
    legend.position=c(1,1),
    legend.justification=c(1,1)) +
  labs(x="Number of Lambda",
       y = "Mean Reciprocal Rank",
       title= "Linear Regression (95% CI) of Mean Reciprocal Rank vs Lambda, by selection method")

p3 <- ggplot(df, aes(x = lambda, y = recall.1)) +
  geom_point(size=3, aes(color=factor(method), shape=factor(method))) +
  geom_smooth(aes(color=factor(method)), method = "lm", se = FALSE) +
  theme_bw() +
  theme(
    axis.title.x = element_text(face="bold", color="black", size=12),
    axis.title.y = element_text(face="bold", color="black", size=12),
    plot.title = element_text(face="bold", color = "black", size=12),
    legend.position=c(1,1),
    legend.justification=c(1,1)) +
  labs(x="Number of Lambda",
       y = "Recall@1",
       title= "Linear Regression (95% CI) of Recall@1 vs Lambda, by selection method")


#' Computes estimates and ancillary information for diagonal classifiers
#'
#' Computes the maximum likelihood estimators (MLEs) for each class under the
#' assumption of multivariate normality for each class. Also, computes ancillary
#' information necessary for classifier summary, such as sample size, the number
#' of features, etc.
#'
#' This function computes the common estimates and ancillary information used in
#' all of the diagonal classifiers in the `sparsediscrim` package.
#'
#' The matrix of training observations are given in `x`. The rows of `x`
#' contain the sample observations, and the columns contain the features for each
#' training observation.
#'
#' The vector of class labels given in `y` are coerced to a `factor`.
#' The length of `y` should match the number of rows in `x`.
#'
#' An error is thrown if a given class has less than 2 observations because the
#' variance for each feature within a class cannot be estimated with less than 2
#' observations. If other data have zero variances, these will be removed with
#' a warning.
#'
#' The vector, `prior`, contains the _a priori_ class membership for
#' each class. If `prior` is NULL (default), the class membership
#' probabilities are estimated as the sample proportion of observations belonging
#' to each class. Otherwise, `prior` should be a vector with the same length
#' as the number of classes in `y`. The `prior` probabilities should be
#' nonnegative and sum to one.
#'
#' @inheritParams lda_diag
#' @param pool logical value. If TRUE, calculates the pooled sample variances
#' for each class.
#' @param est_mean the estimator for the class means. By default, we use the
#' maximum likelihood estimator (MLE). To improve the estimation, we provide the
#' option to use a shrunken mean estimator proposed by Tong et al. (2012).
#' @return named list with estimators for each class and necessary ancillary
#' information
#'
#' @references Tong, T., Chen, L., and Zhao, H. (2012), "Improved Mean
#' Estimation and Its Application to Diagonal Discriminant Analysis,"
#' Bioinformatics, 28, 4, 531-537.
#' \url{http://bioinformatics.oxfordjournals.org/content/28/4/531.long}
diag_estimates <- function(x, y, prior = NULL, pool = FALSE,
                           est_mean = c("mle", "tong")) {
  obj <- list()
  obj$labels <- y
  obj$N <- length(y)
  obj$p <- ncol(x)
  obj$groups <- levels(y)
  obj$num_groups <- nlevels(y)

  est_mean <- match.arg(est_mean)

  # Error Checking
  if (!is.null(prior)) {
    if (length(prior) != obj$num_groups) {
      rlang::abort("The number of 'prior' probabilities must match the number of classes in 'y'.")
    }
    if (any(prior <= 0)) {
      rlang::abort("The 'prior' probabilities must be nonnegative.")
    }
    if (sum(prior) != 1) {
      rlang::abort("The 'prior' probabilities must sum to one.")
    }
  }
  if (any(table(y) < 2)) {
    rlang::abort("There must be at least 2 observations in each class.")
  }

  # By default, we estimate the 'a priori' probabilities of class membership with
  # the MLEs (the sample proportions).
  if (is.null(prior)) {
    prior <- as.vector(table(y) / length(y))
  }

  # For each class, we calculate the MLEs (or specified alternative estimators)
  # for each parameter used in the DLDA classifier. The 'est' list contains the
  # estimators for each class.
  obj$est <- tapply(seq_along(y), y, function(i) {
    stats <- list()
    stats$n <- length(i)
    if (est_mean == "mle") {
      stats$xbar <- colMeans(x[i, , drop = FALSE])
    } else if (est_mean == "tong") {
      stats$xbar <- tong_mean_shrinkage(x[i, , drop = FALSE])
    }
    stats$var <- with(stats, (n - 1) / n * apply(x[i, , drop = FALSE], 2, var))
    stats
  })

  # Check to see if any predictors had zero variances
  obj$est <- check_for_zero_vars(obj$est)

  # Calculates the pooled variance across all classes.
  if (pool) {
    obj$var_pool <- Reduce('+', lapply(obj$est, function(x) x$n * x$var)) / obj$N
  }

  # Add each element in 'prior' to the corresponding obj$est$prior
  for(k in seq_len(obj$num_groups)) {
    obj$est[[k]]$prior <- prior[k]
  }
  obj
}

check_for_zero_vars <- function(x, warn = TRUE) {
  var_est <- lapply(x, function(x) x$var == 0)
  is_zv <- do.call("rbind", var_est)
  any_zv <- apply(is_zv, 2, any)
  if (all(any_zv)) {
    rlang::abort("All predictors have zero variance.")
  }
  if (any(any_zv)) {
    if (warn) {
      nms <- paste0(names(any_zv)[any_zv], collapse = ", ")
      nms <- paste("The following predictors had zero variance (possibly within ",
                   "a class) and were removed from the analysis:", nms)
      rlang::warn(nms)
    }
    x <- lapply(x, reduce_elem, retain = names(any_zv)[!any_zv], "xbar")
    x <- lapply(x, reduce_elem, retain = names(any_zv)[!any_zv], "var")
  }
  x
}

reduce_elem <- function(x, retain, col) {
  x[[col]] <- x[[col]][retain]
  x
}

#' Computes estimates and ancillary information for regularized discriminant
#' classifiers
#'
#' Computes the maximum likelihood estimators (MLEs) for each class under the
#' assumption of multivariate normality for each class. Also, computes ancillary
#' information necessary for classifier summary, such as sample size, the number
#' of features, etc.
#'
#' This function computes the common estimates and ancillary information used in
#' all of the regularized discriminant classifiers in the `sparsediscrim`
#' package.
#'
#' The matrix of training observations are given in `x`. The rows of `x`
#' contain the sample observations, and the columns contain the features for each
#' training observation.
#'
#' The vector of class labels given in `y` are coerced to a `factor`.
#' The length of `y` should match the number of rows in `x`.
#'
#' An error is thrown if a given class has less than 2 observations because the
#' variance for each feature within a class cannot be estimated with less than 2
#' observations.
#'
#' The vector, `prior`, contains the _a priori_ class membership for
#' each class. If `prior` is NULL (default), the class membership
#' probabilities are estimated as the sample proportion of observations belonging
#' to each class. Otherwise, `prior` should be a vector with the same length
#' as the number of classes in `y`. The `prior` probabilities should be
#' nonnegative and sum to one.
#'
#' @inheritParams lda_diag
#' @param y vector of class labels for each training observation
#' @param cov logical. Should the sample covariance matrices be computed?
#' (Default: yes)
#' @param prior vector with prior probabilities for each class. If NULL
#' (default), then the sample proportions are used. See details.
#' @return named list with estimators for each class and necessary ancillary
#' information
regdiscrim_estimates <- function(x, y, cov = TRUE, prior = NULL) {
  obj <- list()
  obj$labels <- y
  obj$N <- length(y)
  obj$p <- ncol(x)
  obj$groups <- levels(y)
  obj$num_groups <- nlevels(y)

  # Error Checking
  if (!is.null(prior)) {
    if (length(prior) != obj$num_groups) {
      rlang::abort("The number of 'prior' probabilities must match the number of
            classes in 'y'.")
    }
    if (any(prior <= 0)) {
      rlang::abort("The 'prior' probabilities must be nonnegative.")
    }
    if (sum(prior) != 1) {
      rlang::abort("The 'prior' probabilities must sum to one.")
    }
  }
  if (any(table(y) < 2)) {
    rlang::abort("There must be at least 2 observations in each class.")
  }

  # By default, we estimate the 'a priori' probabilities of class membership with
  # the MLEs (the sample proportions).
  if (is.null(prior)) {
    prior <- as.vector(table(y) / length(y))
  }

  # For each class, we calculate the MLEs for each parameter used in the
  # 'regdiscrim' classifiers. The 'est' list contains the estimators for each
  # class.
  obj$est <- tapply(seq_along(y), y, function(i) {
    stats <- list()
    stats$n <- length(i)
    stats$xbar <- as.vector(colMeans(x[i, , drop = FALSE]))
    if (cov) {
      stats$cov <- with(stats, cov_mle(x[i, , drop = FALSE]))
    }
    stats
  })

  # Calculates the pooled sample covariance matrix.
  if (cov) {
    obj$cov_pool <- Reduce('+', lapply(obj$est, function(x) x$n * x$cov)) / obj$N
  }

  # Add each element in 'prior' to the corresponding obj$est$prior
  for(k in seq_len(obj$num_groups)) {
    obj$est[[k]]$prior <- prior[k]
  }
  obj
}


getNodes=function(lowerf,upperf,sampling,error,relative){
 tol=10^-7

 if (abs(upperf-lowerf)<tol)
      return(list())
 # put the lower/upper frequency in a node
 lowerNode=getNodesAux(lowerf,sampling,error,"lower",abs(upperf-lowerf),relative);
 upperNode=getNodesAux(upperf,sampling,error,"upper",abs(upperf-lowerf),relative);
 #message(lowerNode)
 #message(upperNode)
 return(mergeNodes(lowerNode,upperNode,sampling,error,relative))

}

 mergeNodes=function(ln,un,sampling,error,relative){

 # lowerNode==upperNode
 if((ln[[1]]==un[[1]])&&(ln[[2]]==un[[2]])){
 finalNodes=list(ln[[1]],ln);
 return(finalNodes)
 }
 #upperNode is a child of lowerNode
 if(isChild(un,ln)){
    #new lower node verifying the cover conditions
    newLnode=c(ln[[1]]+1,ln[[2]]*2)
    finalNodes=mergeNodes(newLnode,un,sampling,error,relative);
    return(finalNodes)
 }
 #lowerNode is a child of upperNode
 if(isChild(ln,un)){
    #new upper node verifying the cover conditions
    newUnode=c(un[[1]]+1,un[[2]]*2+1)
    finalNodes=mergeNodes(ln,newUnode,sampling,error,relative);
    return(finalNodes)
 }
 #general case: there is overlap.there may be an uncovered band
 uncoverLowF=sampling/(2^(ln[[1]]+1))*(ln[[2]]+1);
 uncoverHighF=sampling/(2^(un[[1]]+1))*un[[2]];
 mediumNodes=getNodes(uncoverLowF,uncoverHighF,sampling,error,relative);
 if (length(mediumNodes)==0){#there was not an uncovered band
  finalNodes=list(max(ln[[1]],un[[1]]),ln,un)
 }else{

   finalNodes=c(list(max(ln[[1]],un[[1]]),ln),(mediumNodes[2:length(mediumNodes)]),list(un))
 }
   return(finalNodes)
}

#node1 is child of node2
isChild=function(node1,node2){
#if node1 is child of node2-->the level of the node1 must be greater than the level of the node2
if (node1[[1]]>node2[[1]]){
  c1=getC(node1[[1]],node1[[2]])
  c2=getC(node2[[1]],node2[[2]])
  #the parent of node1 at the level of node2 is codified with the first node2[[1]](level of node2) numbers of c1
  parentc1=c1[1:length(c2)]
  auxBool=prod(c2==parentc1)
  ischild=(auxBool==1)
}else{ #node1 is not child of node2
  ischild=FALSE
}
return (ischild)
}


library(tidyverse)
library(tidymodels)
library(magrittr)
library(modelsummary)
library(rpart)
library(e1071)
library(kknn)
library(nnet)
library(kernlab)

set.seed(100)

income <- read_csv("http://archive.ics.uci.edu/ml/machine-learning-databases/adult/adult.data", col_names = FALSE)
names(income) <- c("age","workclass","fnlwgt","education","education.num","marital.status","occupation","relationship","race","sex","capital.gain","capital.loss","hours","native.country","high.earner")

# From UC Irvine's website (http://archive.ics.uci.edu/ml/machine-learning-databases/adult/adult.names)
#   age: continuous.
#   workclass: Private, Self-emp-not-inc, Self-emp-inc, Federal-gov, Local-gov, State-gov, Without-pay, Never-worked.
#   fnlwgt: continuous.
#   education: Bachelors, Some-college, 11th, HS-grad, Prof-school, Assoc-acdm, Assoc-voc, 9th, 7th-8th, 12th, Masters, 1st-4th, 10th, Doctorate, 5th-6th, Preschool.
#   education-num: continuous.
#   marital-status: Married-civ-spouse, Divorced, Never-married, Separated, Widowed, Married-spouse-absent, Married-AF-spouse.
#   occupation: Tech-support, Craft-repair, Other-service, Sales, Exec-managerial, Prof-specialty, Handlers-cleaners, Machine-op-inspct, Adm-clerical, Farming-fishing, Transport-moving, Priv-house-serv, Protective-serv, Armed-Forces.
#   relationship: Wife, Own-child, Husband, Not-in-family, Other-relative, Unmarried.
#   race: White, Asian-Pac-Islander, Amer-Indian-Eskimo, Other, Black.
#   sex: Female, Male.
#   capital-gain: continuous.
#   capital-loss: continuous.
#   hours-per-week: continuous.
#   native-country: United-States, Cambodia, England, Puerto-Rico, Canada, Germany, Outlying-US(Guam-USVI-etc), India, Japan, Greece, South, China, Cuba, Iran, Honduras, Philippines, Italy, Poland, Jamaica, Vietnam, Mexico, Portugal, Ireland, France, Dominican-Republic, Laos, Ecuador, Taiwan, Haiti, Columbia, Hungary, Guatemala, Nicaragua, Scotland, Thailand, Yugoslavia, El-Salvador, Trinadad&Tobago, Peru, Hong, Holand-Netherlands.

######################
# Clean up the data
######################
# Drop unnecessary columns
income %<>% select(-native.country, -fnlwgt, education.num)
# Make sure continuous variables are formatted as numeric
income %<>% mutate(across(c(age,hours,education.num,capital.gain,capital.loss), as.numeric))
# Make sure discrete variables are formatted as factors
income %<>% mutate(across(c(high.earner,education,marital.status,race,workclass,occupation,relationship,sex), as.factor))
# Combine levels of factor variables that currently have too many levels
income %<>% mutate(education = fct_collapse(education,
                                            Advanced    = c("Masters","Doctorate","Prof-school"),
                                            Bachelors   = c("Bachelors"),
                                            SomeCollege = c("Some-college","Assoc-acdm","Assoc-voc"),
                                            HSgrad      = c("HS-grad","12th"),
                                            HSdrop      = c("11th","9th","7th-8th","1st-4th","10th","5th-6th","Preschool")
),
marital.status = fct_collapse(marital.status,
                              Married      = c("Married-civ-spouse","Married-spouse-absent","Married-AF-spouse"),
                              Divorced     = c("Divorced","Separated"),
                              Widowed      = c("Widowed"),
                              NeverMarried = c("Never-married")
),
race = fct_collapse(race,
                    White = c("White"),
                    Black = c("Black"),
                    Asian = c("Asian-Pac-Islander"),
                    Other = c("Other","Amer-Indian-Eskimo")
),
workclass = fct_collapse(workclass,
                         Private = c("Private"),
                         SelfEmp = c("Self-emp-not-inc","Self-emp-inc"),
                         Gov     = c("Federal-gov","Local-gov","State-gov"),
                         Other   = c("Without-pay","Never-worked","?")
),
occupation = fct_collapse(occupation,
                          BlueCollar  = c("?","Craft-repair","Farming-fishing","Handlers-cleaners","Machine-op-inspct","Transport-moving"),
                          WhiteCollar = c("Adm-clerical","Exec-managerial","Prof-specialty","Sales","Tech-support"),
                          Services    = c("Armed-Forces","Other-service","Priv-house-serv","Protective-serv")
)
)

######################
# tidymodels time!
######################
income_split <- initial_split(income, prop = 0.8)
income_train <- training(income_split)
income_test  <- testing(income_split)

#####################
# logistic regression
#####################
print('Starting LOGIT')
# set up the task and the engine
tune_logit_spec <- logistic_reg(
  penalty = tune(), # tuning parameter
  mixture = 1       # 1 = lasso, 0 = ridge
) %>%
  set_engine("glmnet") %>%
  set_mode("classification")

# define a grid over which to try different values of the regularization parameter lambda
lambda_grid <- grid_regular(penalty(), levels = 50)

# 3-fold cross-validation
rec_folds <- vfold_cv(income_train, v = 3)

# Workflow
rec_wf <- workflow() %>%
  add_model(tune_logit_spec) %>%
  add_formula(high.earner ~ education + marital.status + race + workclass + occupation + relationship + sex + age + capital.gain + capital.loss + hours)

# Tuning results
rec_res <- rec_wf %>%
  tune_grid(
    resamples = rec_folds,
    grid = lambda_grid
  )

# what is the best value of lambda?
top_acc  <- show_best(rec_res, metric = "accuracy")
best_acc <- select_best(rec_res, metric = "accuracy")
final_logit_lasso <- finalize_workflow(rec_wf,
                                       best_acc
)
print('*********** LOGISTIC REGRESSION **************')
logit_test <- last_fit(final_logit_lasso,income_split) %>%
  collect_metrics()

logit_test %>% print(n = 1)
top_acc %>% print(n = 1)

# combine results into a nice tibble (for later use)
logit_ans <- top_acc %>% slice(1)
logit_ans %<>% left_join(logit_test %>% slice(1),by=c(".metric",".estimator")) %>%
  mutate(alg = "logit") %>% select(-starts_with(".config"))

#####################
# tree model
#####################
print('Starting TREE')
# set up the task and the engine
tune_tree_spec <- decision_tree(
  min_n = tune(), # tuning parameter
  tree_depth = tune(), # tuning parameter
  cost_complexity = tune(), # tuning parameter
) %>%
  set_engine("rpart") %>%
  set_mode("classification")

# define a set over which to try different values of the regularization parameter (complexity, depth, etc.)
tree_parm_df1 <- tibble(cost_complexity = seq(.001,.2,by=.05))
tree_parm_df2 <- tibble(min_n = seq(10,100,by=10))
tree_parm_df3 <- tibble(tree_depth = seq(5,20,by=5))
tree_parm_df  <- full_join(tree_parm_df1,tree_parm_df2,by=character()) %>% full_join(.,tree_parm_df3,by=character())

# YOU FILL IN THE REST

# Workflow
tree_wf <- workflow() %>%
  add_model(tune_tree_spec) %>%
  add_formula(high.earner ~ education + marital.status + race + workclass + occupation + relationship + sex + age + capital.gain + capital.loss + hours)

# Tuning results
tree_res <- tree_wf %>%
  tune_grid(
    resamples = rec_folds,
    grid = tree_parm_df
  )

# what is the best value of lambda?
top_tree  <- show_best(tree_res, metric = "accuracy")
best_tree <- select_best(tree_res, metric = "accuracy")
final_decision_tree <- finalize_workflow(tree_wf,
                                       best_tree
)

print('*********** DECISION TREE **************')
tree_test <- last_fit(final_decision_tree,income_split) %>%
  collect_metrics()

tree_test %>% print(n = 1)
top_tree %>% print(n = 1)

# combine results into a nice tibble (for later use)
tree_ans <- top_tree %>% slice(1)
tree_ans %<>% left_join(tree_test %>% slice(1),by=c(".metric",".estimator")) %>%
  mutate(alg = "tree") %>% select(-starts_with(".config"))

#####################
# neural net
#####################
print('Starting NNET')
# set up the task and the engine
tune_nnet_spec <- mlp(
  hidden_units = tune(), # tuning parameter
  penalty = tune()
) %>%
  set_engine("nnet") %>%
  set_mode("classification")

# define a set over which to try different values of the regularization parameter (number of neighbors)
nnet_parm_df1 <- tibble(hidden_units = seq(1,10))
lambda_grid   <- grid_regular(penalty(), levels = 10)
nnet_parm_df  <- full_join(nnet_parm_df1,lambda_grid,by=character())

# YOU FILL IN THE REST

# Workflow
nnet_wf <- workflow() %>%
  add_model(tune_nnet_spec) %>%
  add_formula(high.earner ~ education + marital.status + race + workclass + occupation + relationship + sex + age + capital.gain + capital.loss + hours)

# Tuning results
nnet_res <- nnet_wf %>%
  tune_grid(
    resamples = rec_folds,
    grid = nnet_parm_df
  )

# what is the best value of lambda?
top_nnet  <- show_best(nnet_res, metric = "accuracy")
best_nnet <- select_best(nnet_res, metric = "accuracy")
final_decision_nnet <- finalize_workflow(nnet_wf,
                                         best_nnet
)

print('*********** NEURAL NETWORKS **************')
nnet_test <- last_fit(final_decision_nnet,income_split) %>%
  collect_metrics()

nnet_test %>% print(n = 1)
top_nnet %>% print(n = 1)

# combine results into a nice tibble (for later use)
nnet_ans <- top_nnet %>% slice(1)
nnet_ans %<>% left_join(nnet_test %>% slice(1),by=c(".metric",".estimator")) %>%
  mutate(alg = "nnet") %>% select(-starts_with(".config"))

#####################
# knn
#####################
print('Starting KNN')
# set up the task and the engine
tune_knn_spec <- nearest_neighbor(
  neighbors = tune() # tuning parameter
) %>%
  set_engine("kknn") %>%
  set_mode("classification")

# define a set over which to try different values of the regularization parameter (number of neighbors)
knn_parm_df <- tibble(neighbors = seq(1,30))

# YOU FILL IN THE REST

# Workflow
knn_wf <- workflow() %>%
  add_model(tune_knn_spec) %>%
  add_formula(high.earner ~ education + marital.status + race + workclass + occupation + relationship + sex + age + capital.gain + capital.loss + hours)

# Tuning results
knn_res <- knn_wf %>%
  tune_grid(
    resamples = rec_folds,
    grid = knn_parm_df
  )

# what is the best value of lambda?
top_knn  <- show_best(knn_res, metric = "accuracy")
best_knn <- select_best(knn_res, metric = "accuracy")
final_decision_knn <- finalize_workflow(knn_wf,
                                         best_knn
)

print('*********** KNN **************')
knn_test <- last_fit(final_decision_knn,income_split) %>%
  collect_metrics()

knn_test %>% print(n = 1)
top_knn %>% print(n = 1)

# combine results into a nice tibble (for later use)
knn_ans <- top_knn %>% slice(1)
knn_ans %<>% left_join(knn_test %>% slice(1),by=c(".metric",".estimator")) %>%
  mutate(alg = "knn") %>% select(-starts_with(".config"))

#####################
# SVM
#####################
print('Starting SVM')
# set up the task and the engine
tune_svm_spec <- svm_rbf(
  cost = tune(),
  rbf_sigma = tune()
) %>%
  set_engine("kernlab") %>%
  set_mode("classification")

# define a set over which to try different values of the regularization parameter (number of neighbors)
svm_parm_df1 <- tibble(cost      = c(2^(-2),2^(-1),2^0,2^1,2^2,2^10))
svm_parm_df2 <- tibble(rbf_sigma = c(2^(-2),2^(-1),2^0,2^1,2^2,2^10))
svm_parm_df  <- full_join(svm_parm_df1,svm_parm_df2,by=character())

# YOU FILL IN THE REST

# Workflow
svm_wf <- workflow() %>%
  add_model(tune_svm_spec) %>%
  add_formula(high.earner ~ education + marital.status + race + workclass + occupation + relationship + sex + age + capital.gain + capital.loss + hours)

# Tuning results
svm_res <- svm_wf %>%
  tune_grid(
    resamples = rec_folds,
    grid = svm_parm_df
  )

# what is the best value of lambda?
top_svm  <- show_best(tree_svm, metric = "accuracy")
best_svm <- select_best(tree_svm, metric = "accuracy")
final_decision_svm <- finalize_workflow(tree_svm,
                                        best_svm
)

print('*********** SUPPORT VECTOR MACHINE **************')
svm_test <- last_fit(final_decision_svm,income_split) %>%
  collect_metrics()

svm_test %>% print(n = 1)
top_svm %>% print(n = 1)

# combine results into a nice tibble (for later use)
svm_ans <- top_svm %>% slice(1)
svm_ans %<>% left_join(svm_test %>% slice(1),by=c(".metric",".estimator")) %>%
  mutate(alg = "svm") %>% select(-starts_with(".config"))

#####################
# combine answers
#####################
all_ans <- bind_rows(logit_ans,tree_ans,nnet_ans,knn_ans, svm_ans)
datasummary_df(all_ans %>% select(-.metric,-.estimator,-mean,-n,-std_err),output="latex") %>% print


## # # Write insert, delete, and containment search functions

insert <- function(t, h) {
    ## inserts any MHR h into collection of MHRs t
    t <- rbind(t, h)
    return(t)
}
## ## test
## testh <- h*2
## test <- insert(t, testh)
## test <- insert(test, h)
## test

delete <- function(t, h, end) {
    ## deletes MHR h from collection of MHRs t
    matchingid <- which(apply(t[1:end], 1, function(x) all(x == h[1:end])))
    ## may not be present if previously deleted so check for matchingid > 0
    if (length(matchingid) > 0) t <- t[-c(matchingid),]
    return(t)
}
## delete(test, testh)

## return TRUE if x is a number and FALSE otherwise
is.number <- function(x) suppressWarnings(!is.na(as.numeric(as.character(x))))

## find parameter values for h based on location names
hlocation <- function(h, df, space) {
    nparam <- ncol(space) - 1
    end    <- nparam * 2
    hloc   <- h[1:end]
    for (i in 1:end) {
        boundname <- as.character(h[[i]])
        j <- i + 1
        if (i > nparam) j <- i - nparam + 1
        if (h[i] == 'SL' | h[i] == 'SU') {
            ## boundary is set to original space of interest
            ##print(i)
            ##print(as.character(h[[i]]))
            hloc[i] <- space[space$name == boundname, j]
        ## } else if (typeof(h[[i]]) == 'double') {
        } else if (is.number(h[[i]]) == 'TRUE') {
            ## implies boundary is set based on location and no boundary point yet
            ##print(i)
            hloc[i] <- h[i]
        } else {
            ## boundary is location of a datapoint on the boundary
            hloc[i] <- dfs[dfs$name == boundname, j]
        }
    }
    ## make sure value passed back is numeric
    hloc <- data.frame( t( sapply(hloc, function(x) as.numeric(as.character(x))) ) )
    return(hloc)
}
## hloc <- hlocation(h, dfs, space)

## # identifies where point x is relative to MHR h (i.e.,x is inside the bounds of the MHR)
ContainmentSearch <- function(h, pname, df, space) {
    ## # if pname is between every upper and lower bound for every parameter, then it is inside MHR
    ## # if pname is equal to upper or lower bound for any parameter, then it is on the boundary

    ## ## debug
    ## browser()

    ## what are the parameter values, x, for datapoint pname
    nparam <- ncol(space) - 1
    end    <- nparam*2
    datapoint <- df[df$name == pname,]
    x <- datapoint[2:(nparam+1)]
    if (nrow(x) == 0) return(list(location='ContainmentSearch: no matching point found',
                                  distance='0', mindist='0', maxdist='0'))
    if (nrow(x) > 1) cat('****** fatal error: duplciate datapoint names found ******\n')
    x <- as.numeric(x)

    ## what are the parameter values, hloc, for MHR h
    hloc <- hlocation(h[1:end], df, space)

    ## how far is pname from the low and high extremes of the MHR for each parameter
    ## low  <- hloc[1         :nparam]
    ## high <- hloc[(nparam+1):end   ]
    low  <- as.numeric( hloc[1         :nparam] )
    high <- as.numeric( hloc[(nparam+1):end   ] )
    distance <- (x - low)/(high - low)

    ## where is pname in relation to the MHR
    maxdist <- max(distance)
    mindist <- min(distance)
    if ( (mindist < 0) | (maxdist > 1) ) {
        location <- 'outside'
    } else if ( (mindist == 0) | (maxdist == 1) ) {
        location <- 'on boundary'
    } else {
        location <- 'inside'
    }

    return(list(location=location, distance=distance, mindist=mindist, maxdist=maxdist))
    ## return(location)
}
## h
## pname <- 'point1'
## contains <- ContainmentSearch(h, pname, dfs, spaces)
## contains

## ## following finds all matching points but that was not what was needed
## # ContainmentSearch <- function(t,x) which(apply(t, 1, function(xx) all(xx == x)))
## # ContainmentSearch(t,dfx)

size <- function(hloc) {
    ## use volume of hyper rectangle
    end    <- ncol(hloc)
    nparam <- end/2
    low  <- hloc[1         :nparam]
    high <- hloc[(nparam+1):end   ]
##    browser()
    volume <- apply(high - low, 1, prod)
    ## low  <- as.numeric( hloc[1         :nparam] )
    ## high <- as.numeric( hloc[(nparam+1):end   ] )
    ## volume <- prod(high-low)
    return(volume)
}

bigenough <- function(hloc, small=sizesmall) {
    ## return TRUE if MHR h is sufficiently large
    sizeh <- size(hloc)
    logical <- sizeh >= small
    return(logical)
}
## #sizesmall
## #size(h)
## #bigenough(h,(1e+6-1))
## #bigenough(h,1e+6)
## #bigenough(h,(1e+6+1))
## #bigenough(h,sizesmall)

bounded <- function(h, end) {
    ## return true if the MHR, h, is bounded on all sides by a data point or original MHR side
    ## irow is the row number for the current data point of interest in df
    unbounded <- sapply(h[1:end], is.numeric)
    if (ncol(h[unbounded]) == 0) {
        bounded <- TRUE
    } else {
        bounded <- FALSE
    }
    return(bounded)
}

pbound <- function(h, jdim, side, df, space) {
    ## for parameter jdim:
    ##     return the name of the boundary if bounded by SL, SU, or a datapoint
    ##     otherwise return the location of the boundary

    ## print(h)
    ## print(jdim)
    nparam <- ncol(space) - 1
    if (side == "L" ) {
        jside <- jdim
    } else {
        jside <- jdim + nparam
    }
    hchar <- as.character(h[[jside]])  ## pull h[jside] out of dataframe
    ## browser()

    ## check boundary points and replace if needed
    if (h[jside] == 'SL' | h[jside] == 'SU') {
        ## still bounded by original space
        boundedby <- hchar

    } else if (is.numeric(h[jside])) {
        ## parent was not bounded either just pass the same
        boundedby <- as.numeric(h[[jside]])

    } else {
        ## test that the parent point on the boundary is really on the new MHR boundary
        testloc <- ContainmentSearch(h, hchar, df, space)$location
        if (testloc == 'on boundary') {
            boundedby <- hchar

        } else {
            ## parent point not on boundary so reset boundary to location value
            hloc <- hlocation(h, df, space)
            boundedby <- hloc[jside]

            ## now look at additional boundary points
            ## and use if on the boundary of interest (jside)
            bounds  <- h$bounds[[1]]
            lbounds <- length(bounds)
            ## only look if bounds contains more than the 1 NA point
            if (lbounds > 1) {
                bounds <- bounds[2:lbounds]  # stripped out the NA
                for (boundpoint in bounds) {
                    cs <- ContainmentSearch(h, boundpoint, df, space)
                    if (cs$location == 'on boundary' &
                        df[df$name == boundpoint, 1+jdim] == hloc[[jside]] ) {
                        ## then point is on the same boundary
                        boundedby <- boundpoint
                        break
                    }
                }
            }
        }
    }
    return(boundedby)
}

inexisting <- function(t, h) {
    ## return no if h is not conatined within an existing MHR in t
    ## return yes if h is contained within an existing MHR in t
    ## t and h need to contain parameter values
    nparam <- ncol(h) / 2
    inexisting <- 'no'
    for (trow in 1:nrow(t)) {
        ## nwithin will be used to track the number of parameters for which h is within trow
        nwithin <- 0
        for (j in 1:nparam) {
            ## for parameter j, test to see if MHR h is above lower bound of trow
            ## and below upper bound of trow
            if (h[j] >= t[trow, j] & h[j+nparam] <= t[trow, j+nparam]) nwithin <- nwithin + 1
        }
        if (nwithin == nparam) {
            inexisting <- 'yes'
            break
        }
    }
    return(inexisting)
}

rglcube <- function(data, color='blue') {
    ## adds a rectangular prism to a scatter plot made using rgl::plot3d
    ## data = dateframe where 1st 6 columns are: xL, yL, zL, xU, yU, zU
    ##        additional columns, if present, are ignored
    ## polygon3d is part of rgl packages
    ##
    liu <- data
    polygon3d(x=c(liu[[1]], liu[[4]], liu[[4]], liu[[1]]), # x-y plane at lower z
              y=c(liu[[2]], liu[[2]], liu[[5]], liu[[5]]),
              z=c(liu[[3]], liu[[3]], liu[[3]], liu[[3]]),
              coords=c(1,2), col=color, alpha=0.2)
    polygon3d(x=c(liu[[1]], liu[[4]], liu[[4]], liu[[1]]), # x-y plane at upper z
              y=c(liu[[2]], liu[[2]], liu[[5]], liu[[5]]),
              z=c(liu[[6]], liu[[6]], liu[[6]], liu[[6]]),
              coords=c(1,2), col=color, alpha=0.2)
    polygon3d(x=c(liu[[1]], liu[[1]], liu[[1]], liu[[1]]),  # y-z plane at lower x
              y=c(liu[[2]], liu[[2]], liu[[5]], liu[[5]]),
              z=c(liu[[6]], liu[[3]], liu[[3]], liu[[6]]),
              coords=c(2,3), col=color, alpha=0.2)
    polygon3d(x=c(liu[[4]], liu[[4]], liu[[4]], liu[[4]]),  # y-z plane at upper x
              y=c(liu[[2]], liu[[2]], liu[[5]], liu[[5]]),
              z=c(liu[[6]], liu[[3]], liu[[3]], liu[[6]]),
              coords=c(2,3), col=color, alpha=0.2)
    polygon3d(x=c(liu[[1]], liu[[4]], liu[[4]], liu[[1]]),  # z-x plane at lower y
              y=c(liu[[2]], liu[[2]], liu[[2]], liu[[2]]),
              z=c(liu[[3]], liu[[3]], liu[[6]], liu[[6]]),
              coords=c(3,1), col=color, alpha=0.2)
    polygon3d(x=c(liu[[1]], liu[[4]], liu[[4]], liu[[1]]),  # z-x plane at upper y
              y=c(liu[[5]], liu[[5]], liu[[5]], liu[[5]]),
              z=c(liu[[3]], liu[[3]], liu[[6]], liu[[6]]),
              coords=c(3,1), col=color, alpha=0.2)
}


data("PlantGrowth")
View(PlantGrowth)

bartlett.test(PlantGrowth$weight~PlantGrowth$group)

R Community/R Stats_Basics Part 1/Assignment6.r


####### Robust Model #######

### Model with heteroscedastic Variance ###

fit.lme.ml.vexp.wogi <- lme(volume ~ daydiff + group:daydiff , random = ~ daydiff | mouse, data = dfData,
                                corr = corARMA(form= ~1|mouse, p = 2, q =0), # To model dependence. Unit root in MA for ARMA(2,1)
                                weights = varExp(form=~fitted(.)|v3SplitGroups), # Three groups can be changed to two as well
                                method = "ML", na.action =na.pass)

summary(fit.lme.ml.vexp.wogi)

pred.ml.vexp.wogi = predict(fit.lme.ml.vexp.wogi)

res.ml.vexp.wogi.pea = resid(fit.lme.ml.vexp.wogi, type = "p")

res.ml.vexp.wogi = resid(fit.lme.ml.vexp.wogi)

p13 =
ggplot(data = dfData,aes(y = res.ml.vexp.wogi.pea, x = pred.ml.vexp.wogi)) +
  geom_point(aes(color = group)) +
  scale_color_manual(values=vColors[1:2]) +
  geom_line(y = 0) +
  theme_minimal() +
  xlab("Fitted by ML and with VarExp & CorARMA modeled") +
  ylab("Pearson Residuals")

par(mfrow=c(1,1))

qqnorm(resid(fit.lme.ml.vexp.wogi, type ="p"),main="Pearson Residuals",pch=16,bty='n', col = vColors[3])
qqline(resid(fit.lme.ml.vexp.wogi, type = "p"),lwd=2,col= vColors[2])

ggplot(data = dfData,aes(y = res.ml.vexp.wogi.pea, x = v3SplitGroups)) +
  geom_boxplot(fill = vColors[1:3], alpha = 0.6, color= vColors[1:3]) +
  theme_minimal() +
  xlab("Three Groups") +
  ylab("Pearson Residuals fitted by ML and with VarExp & CorARMA modeled")

anova(fit.lme.ml.vexp.wogi, fit.lme.ml.wogi)

### Model with forced uncorrelation between random intercept and slope ###

summary(
  lme(volume ~ daydiff + group:daydiff,
  random = list(mouse=pdIdent(~daydiff)),
  data = dfData,
  method = "ML")
  ) # Not good

### Robust model with HUber Weights ###

fit.rob.ml.wogi <- rlmer(volume ~ daydiff + group:daydiff + (daydiff | mouse), data = dfData,
                         rho.sigma.b=psi2propII(smoothPsi, k=1.345), # Higher k more efficiency, lower more robust
                         rho.sigma.e=psi2propII(smoothPsi, k=1.345)
                         )

summary(fit.rob.ml.wogi)

Weights = summary(fit.rob.ml.wogi)[9]$wgt.e

pred.rob.ml.wogi = predict(fit.rob.ml.wogi)

res.rob.ml.wogi = residuals(fit.rob.ml.wogi, type = "response", scaled = TRUE)

p14 =
ggplot(data = dfData,aes(y = res.rob.ml.wogi, x = pred.rob.ml.wogi, color = Weights)) +
  geom_point() +
  scale_color_gradient(high = vColors[2], low = vColors[1]) +
  geom_line(y = 0) +
  theme_minimal() +
  xlab("Fitted by ML and Huber Loss function") +
  ylab("Scaled Residuals w/o weights applied")

qqnorm(resid(fit.rob.ml.wogi),main="Residuals",pch=16,bty='n', col = vColors[3])
qqline(resid(fit.rob.ml.wogi),lwd=2,col= vColors[2])

compare(fit.lme4.ml.wogi, fit.rob.ml.wogi)

grid.arrange(p13,p14, nrow = 1)

plot.rlmerMod(fit.rob.ml.wogi)


samplesize <- 1000
sex <- factor(floor(runif(n = samplesize, min = 0, max = 3)), labels = c("male", "female", "other"))
agegroup <- factor(floor(runif(n = samplesize, min = 0, max = 5)), labels = c("10s", "20s", "30s", "40s", "50s"))

a <- sapply(sex, function (x) {
  b <- 0
  if(x == 'male') b <- rbinom(n=1,size=1,prob = 0.7)
  else if (x == 'female') b <- rbinom(n=1,size=1,prob = 0.5)
  else b <- rbinom(n=1,size=1,prob = 0.1)
  return(b)
})

b <- sapply(agegroup, function (x) {
  c <- 0
  if (x == '30s') c <- rbinom(n=1,size=1,prob = 0.7)
  else c <- rbinom(n=1,size=1,prob = 0.5)
  return (c)
})

click_rate <- scale(x = (a+b), center=min(a+b), scale = (max(a+b) - min(a+b)))
click <- factor(ifelse(click_rate > 0.5, 1, 0), labels = c("n", "y"))
summary(click)
ad_click <- data.frame(click=click, sex=sex, agegroup)
write.table(x = ad_click,file = "data/ad_click.csv", sep = ',')


require(ggplot2) # for plotting
require(ggpubr) # for violin plots
require(gridExtra) # for combining plots
require(RColorBrewer) # to define color scales
require(ggrepel) # for plot labeling

# Plot residuals of aragonite dataset with respect to regressions ------------------------------------------------------------

# Build custom color scales for full dataset plot
colorscale <- unlist(brewer.pal(length(unique(dat$Analysis)), "Set1"))
names(colorscale) <- unique(dat$Analysis[order(dat$Temp)])

uniquesamples <- data.frame(samplename = unique(violin_data$sample),
    Analysis = sapply(strsplit(unique(violin_data$sample), split = "_"), "[", 2)
) # Link sample to Analysis
fillscale <- colorscale[match(uniquesamples$Analysis, names(colorscale))]
names(fillscale) <- uniquesamples$samplename

# Plot residuals
York_residual_plot <- ggplot(data = dat, aes(10^6 / (Temp + 273.15) ^ 2 , D47res_York)) +
    geom_ribbon(data = D47m_York_result_res,
        aes(x = x,
        y = fit,
        ymin = lwr,
        ymax = upr),
        fill = "grey",
        alpha = 0.5) +
    geom_line(data = D47m_York_result_res,
        aes(x = x, y = fit),
        color = "grey",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_line(data = D47m_York_result_res,
        aes(x = x, y = Anderson),
        color = "black",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_line(data = D47m_York_result_res[1:1001, ],
        aes(x = x, y = Meinicke),
        color = "black",
        linetype = "dotted",
        cex = 1,
        alpha = 1) +
    geom_pointrange(data = D47stats,
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47res_York,
            ymin = D47res_York - CL95,
            ymax = D47res_York + CL95,
            color = Analysis,
            shape = type),
        cex = 1,
        alpha = 1) +
    geom_errorbarh(data = D47stats,
        aes(xmin = 10^6 / ((Temp + 2 * Temp_SD) + 273.15) ^ 2,
        xmax = 10^6 / ((Temp - 2 * Temp_SD) + 273.15) ^ 2,
        y = D47res_York,
        color = Analysis),
        cex = 1,
        alpha = 1) +
#    geom_violin(data = dat[which(!dat$D47_outlier), ],
#        aes(10^6 / (270.15) ^ 2,
#            y = D47res_York),
#        fill = "black",
#        kernel = "rectangular",
#        scale = "width",
#        position = "identity",
#        width = .2,
#        cex = 0,
#        alpha = 0.2,
#        color = NA,
#        trim = TRUE) +
#    geom_pointrange(data = dat[which(!dat$D47_outlier), ],
#        aes(x = 10^6 / (270.15) ^ 2,
#            y = mean(D47res_York),
#            ymin = mean(D47res_York) - sd(D47res_York),
#            ymax = mean(D47res_York) + sd(D47res_York)),
#        color = "black",
#        cex = 1) +
# Plot layout
    ylim(-0.1, 0.1) +
    scale_x_continuous(10 ^ 6 / T ^ 2 ~ "(K)",
        breaks = seq(0, 14, 1),
        minor_breaks = seq(0, 14, 0.25),
        sec.axis = sec_axis(~ sqrt(1e6 / .) - 273.15,
            "Temperature (°C)",
            breaks = temp_breaks,
            labels = temp_labs),
        limits = c(0, 14)) +
    labs(x = 10 ^ 6 / T ^ 2 ~ "(K)",
        y = Delta * Delta[47] ~ "(\u2030"~"I-CDES)",
        colour = "Legend") +
    scale_colour_manual(values = colorscale) +
    scale_shape_manual(values = c(15:20)) +
    theme_bw() +
    theme(legend.position = "none")

# Add separate summary violin/pointrange
York_residual_plot_margin <- ggplot(data = dat[which(!dat$D47_outlier), ]) +
    geom_violin(aes(1,
            y = D47res_York),
        fill = "black",
        kernel = "rectangular",
        scale = "width",
        position = "identity",
        cex = 0,
        alpha = 0.2,
        color = NA,
        trim = TRUE
    ) +
    geom_pointrange(data = dat[which(!dat$D47_outlier), ],
        aes(1,
            y = mean(D47res_York),
            ymin = mean(D47res_York) - sd(D47res_York),
            ymax = mean(D47res_York) + sd(D47res_York)),
        color = "black",
        cex = 1) +
    scale_y_continuous("",
        breaks = seq(-0.1, 0.1, 0.1),
        labels = rep("", 3),
        limits = c(-0.1, 0.1)) +
    scale_x_continuous("",
        breaks = seq(0.5, 1.5, 0.5),
        labels = rep("", 3),
        sec.axis = sec_axis(~ .,
            "",
            breaks = seq(0.5, 1.5, 0.5),
            labels = rep("", 3)),
        limits = c(0.5, 1.5)) +
    labs(x = "") +
    theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.background = element_blank(),
        axis.ticks = element_blank(),
        plot.margin = unit(c(5.5, 0, 5.5, -20), "pt")
    )

lowT_York_residual_plot <- ggplot(data = dat, aes(10^6 / (Temp + 273.15) ^ 2 , D47res_lowT_York)) +
    geom_ribbon(data = D47m_lowT_York_result_res,
        aes(x = x,
        y = fit,
        ymin = lwr,
        ymax = upr),
        fill = "grey",
        alpha = 0.5) +
    geom_line(data = D47m_lowT_York_result_res,
        aes(x = x, y = fit),
        color = "grey",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_line(data = D47m_lowT_York_result_res,
        aes(x = x, y = Anderson),
        color = "black",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_line(data = D47m_lowT_York_result_res[1:1001, ],
        aes(x = x, y = Meinicke),
        color = "black",
        linetype = "dotted",
        cex = 1,
        alpha = 1) +
    geom_pointrange(data = D47stats,
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47res_lowT_York,
            ymin = D47res_lowT_York - CL95,
            ymax = D47res_lowT_York + CL95,
            color = Analysis,
            shape = type),
        cex = 1,
        alpha = 1) +
    geom_errorbarh(data = D47stats,
        aes(xmin = 10^6 / ((Temp + 2 * Temp_SD) + 273.15) ^ 2,
        xmax = 10^6 / ((Temp - 2 * Temp_SD) + 273.15) ^ 2,
        y = D47res_lowT_York,
        color = Analysis),
        cex = 1,
        alpha = 1) +
# Add summary violin/pointrange
#    geom_violin(data = dat[which(!dat$D47_outlier & (dat$Analysis != "Muller17")), ],
#        aes(10^6 / (270.15) ^ 2,
#            y = D47res_lowT_York),
#        fill = "black",
#        kernel = "rectangular",
#        scale = "width",
#        position = "identity",
#        width = .2,
#        cex = 0,
#        alpha = 0.2,
#        color = NA,
#        trim = TRUE) +
#    geom_pointrange(data = dat[which(!dat$D47_outlier  & (dat$Analysis != "Muller17")), ],
#        aes(x = 10^6 / (270.15) ^ 2,
#            y = mean(D47res_lowT_York),
#            ymin = mean(D47res_lowT_York) - sd(D47res_lowT_York),
#            ymax = mean(D47res_lowT_York) + sd(D47res_lowT_York)),
#        color = "black",
#        cex = 1) +
    ylim(-0.1, 0.1) +
    scale_x_continuous(10 ^ 6 / T ^ 2 ~ "(K)",
        breaks = seq(0, 14, 1),
        minor_breaks = seq(0, 14, 0.25),
        sec.axis = sec_axis(~ sqrt(1e6 / .) - 273.15,
            "Temperature (°C)",
            breaks = temp_breaks,
            labels = temp_labs_lowT),
        limits = c(7, 14)) +
    labs(x = 10 ^ 6 / T ^ 2 ~ "(K)",
        y = Delta * Delta[47] ~ "(\u2030"~"I-CDES)",
        colour = "Legend") +
    scale_colour_manual(values = colorscale) +
    scale_shape_manual(values = c(15:20)) +
    theme_bw()

# Add separate summary violin/pointrange
lowT_York_residual_plot_margin <- ggplot(data = dat[which(!dat$D47_outlier), ]) +
    geom_violin(aes(1,
            y = D47res_lowT_York),
        fill = "black",
        kernel = "rectangular",
        scale = "width",
        position = "identity",
        cex = 0,
        alpha = 0.2,
        color = NA,
        trim = TRUE
    ) +
    geom_pointrange(data = dat[which(!dat$D47_outlier), ],
        aes(1,
            y = mean(D47res_lowT_York),
            ymin = mean(D47res_lowT_York) - sd(D47res_lowT_York),
            ymax = mean(D47res_lowT_York) + sd(D47res_lowT_York)),
        color = "black",
        cex = 1) +
    scale_y_continuous("",
        breaks = seq(-0.1, 0.1, 0.1),
        labels = rep("", 3),
        limits = c(-0.1, 0.1)) +
    scale_x_continuous("",
        breaks = seq(0.5, 1.5, 0.5),
        labels = rep("", 3),
        sec.axis = sec_axis(~ .,
            "",
            breaks = seq(0.5, 1.5, 0.5),
            labels = rep("", 3)),
        limits = c(0.5, 1.5)) +
    labs(x = "") +
    theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.background = element_blank(),
        axis.ticks = element_blank(),
        plot.margin = unit(c(5.5, 0, 5.5, -20), "pt")
    )

poly_residual_plot <- ggplot(data = dat, aes(10^6 / (Temp + 273.15) ^ 2 , D47res_poly)) +
    geom_ribbon(data = D47m_poly_MC_result_res,
        aes(x = x,
        y = fit,
        ymin = lwr,
        ymax = upr),
        fill = "grey",
        alpha = 0.5) +
    geom_line(data = D47m_poly_MC_result_res,
        aes(x = x, y = fit),
        color = "grey",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_line(data = D47m_poly_MC_result_res,
        aes(x = x, y = Anderson),
        color = "black",
        linetype = "dashed",
        cex = 1,
        alpha = 1) +
    geom_line(data = D47m_poly_MC_result_res[1:1001, ],
        aes(x = x, y = Meinicke),
        color = "black",
        linetype = "dotted",
        cex = 1,
        alpha = 1) +
    geom_pointrange(data = D47stats,
        aes(x = 10^6 / (Temp + 273.15) ^ 2,
            y = D47res_poly,
            ymin = D47res_poly - CL95,
            ymax = D47res_poly + CL95,
            color = Analysis,
            shape = type),
        cex = 1,
        alpha = 1) +
    geom_errorbarh(data = D47stats,
        aes(xmin = 10^6 / ((Temp + 2 * Temp_SD) + 273.15) ^ 2,
        xmax = 10^6 / ((Temp - 2 * Temp_SD) + 273.15) ^ 2,
        y = D47res_poly,
        color = Analysis),
        cex = 1,
        alpha = 1) +
# Add summary violin/pointrange
#    geom_violin(data = dat[which(!dat$D47_outlier), ],
#        aes(10^6 / (270.15) ^ 2,
#            y = D47res_poly),
#        fill = "black",
#        kernel = "rectangular",
#        scale = "width",
#        position = "identity",
#        width = .2,
#        cex = 0,
#        alpha = 0.2,
#        color = NA,
#        trim = TRUE) +
#    geom_pointrange(data = dat[which(!dat$D47_outlier), ],
#        aes(x = 10^6 / (270.15) ^ 2,
#            y = mean(D47res_poly),
#            ymin = mean(D47res_poly) - sd(D47res_poly),
#            ymax = mean(D47res_poly) + sd(D47res_poly)),
#        color = "black",
#        cex = 1) +
    ylim(-0.1, 0.1) +
    scale_x_continuous(10 ^ 6 / T ^ 2 ~ "(K)",
        breaks = seq(0, 14, 1),
        minor_breaks = seq(0, 14, 0.25),
        sec.axis = sec_axis(~ sqrt(1e6 / .) - 273.15,
            "Temperature (°C)",
            breaks = temp_breaks,
            labels = temp_labs),
        limits = c(0, 14)) +
    labs(x = 10 ^ 6 / T ^ 2 ~ "(K)",
        y = Delta * Delta[47] ~ "(\u2030"~"I-CDES)",
        colour = "Legend") +
    scale_colour_manual(values = colorscale) +
    scale_shape_manual(values = c(15:20)) +
    theme_bw()

# Add separate summary violin/pointrange
poly_residual_plot_margin <- ggplot(data = dat[which(!dat$D47_outlier), ]) +
    geom_violin(aes(1,
            y = D47res_poly),
        fill = "black",
        kernel = "rectangular",
        scale = "width",
        position = "identity",
        cex = 0,
        alpha = 0.2,
        color = NA,
        trim = TRUE
    ) +
    geom_pointrange(data = dat[which(!dat$D47_outlier), ],
        aes(1,
            y = mean(D47res_poly),
            ymin = mean(D47res_poly) - sd(D47res_poly),
            ymax = mean(D47res_poly) + sd(D47res_poly)),
        color = "black",
        cex = 1) +
    scale_y_continuous("",
        breaks = seq(-0.1, 0.1, 0.1),
        labels = rep("", 3),
        limits = c(-0.1, 0.1)) +
    scale_x_continuous("",
        breaks = seq(0.5, 1.5, 0.5),
        labels = rep("", 3),
        sec.axis = sec_axis(~ .,
            "",
            breaks = seq(0.5, 1.5, 0.5),
            labels = rep("", 3)),
        limits = c(0.5, 1.5)) +
    labs(x = "") +
    theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.background = element_blank(),
        axis.ticks = element_blank(),
        plot.margin = unit(c(5.5, 0, 5.5, -20), "pt")
    )

Combined_residual_plot <- grid.arrange(York_residual_plot + theme(legend.position = "none"),
    York_residual_plot_margin,
    poly_residual_plot + theme(legend.position = "none"),
    poly_residual_plot_margin,
    lowT_York_residual_plot + theme(legend.position = "none"),
    lowT_York_residual_plot_margin,
    layout_matrix = rbind(
        c(rep(1, 15), 2),
        c(rep(3, 15), 4),
        c(rep(5, 15), 6)
    ))


suppressMessages(library(Matrix))
suppressMessages(library(cop))

x = matrix(0, 10, 3)
x[3, 1] = 1
x[6, 1] = 2
x[2, 2] = 3
x[4, 2] = 4
x[7, 2] = 5
x[1, 3] = 6
x[2, 3] = 7
s = as(x, "dgCMatrix")
comm.print(s)

ret = spadd_allreduce(s)
comm.print(ret)

finalize()