# this script depends on data-raw/scripts/rt.r
# Packages ----------------------------------------------------------------
library(EpiNow2)
library(data.table)
library(here)

# Load samples ------------------------------------------------------------
# load from disk
samples <- get_regional_results(results_dir = here::here("data-raw", "data", "rt", "samples"),
                                samples = TRUE)$estimates$samples
# filter for infection posteriors
samples <- samples[variable %in% "infections"][,.(county = region, date, sample, value, type)]

# Calculate prevalence ----------------------------------------------------
# order by county and date, then taking a rolling sum of the last 7 days excluding today
setorder(samples, county, date)
samples <- samples[, lag_inc := shift(value, 2, "lag"), by = county]
samples <- samples[, prev := frollsum(lag_inc, n = 6, align = "right"), by = county]

prev_summary <- calc_summary_measures(samples, summarise_by = c("date", "county"), CrIs = 0.95)

npn <- prev_summary[county %in% c("pilot", "non-pilot")]

## extract dates of interest
samples <- samples[date == "2020-10-31" | date == "2020-11-07"]
samples <- samples[, .(county, date, sample, prev)]
prev <- dcast(samples, county + sample ~ date, value.var = "prev")

# make ratio
prev <- prev[, prev_ratio := `2020-10-31` / `2020-11-07`]

## save with other EpiNow2 results
fwrite(prev, here::here("data-raw", "data", "rt", "prevalence-samples.csv"))


map.colors <- function (value,high.low,palette) {
  proportion <- ((value-high.low[1])/(high.low[2]-high.low[1]))
  index <- round ((length(palette)-1)*proportion)+1
  return (palette[index])
}


#' Principal Components Analysis
#'
#' Performs the principal components analysis.
#'
#' @details
#' \code{prcomp()} performs the principal components analysis on the data
#' matrix by taking the SVD. Sometimes core R and kazaam will disagree
#' slightly in what the rotated variables are because of how the SVD is
#' caluclated.
#'
#' @section Communication:
#' The communication is an \code{allreduce()} call, quadratic on the number of
#' columns.  Most of the run time should be dominated by relatively expensive
#'  local operations.
#'
#' @param x
#' A shaq.
#' @param center
#' Should columns are zero centered?
#' @param scale.
#' Should columns are rescaled to unit variance?
#' @param retx
#' Should the rotated variables be returned?
#' @param tol
#' The cutoff for components.
#' @param ...
#' Ignored.
#'
#' @return
#' A list of elements \code{sdev}, \code{rotation}, \code{center}, \code{scale},
#' and \code{x}, as with R's own \code{prcomp()}.  The elements are,
#' respectively, a regular vector, a regular matrix, a regular vector, a regular
#' vector, and a shaq.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#' pca = prcomp(x)
#'
#' comm.print(pca)
#'
#' finalize()
#' }
#'
#' @name prcomp
#' @rdname prcomp
#' @export
prcomp.shaq = function(x, retx=TRUE, center=TRUE, scale.=FALSE, tol=NULL, ...)
{
  x <- scale(x, center=center, scale=scale.)
  x.center <- attr(DATA(x), "scaled:center")
  x.scale <- attr(DATA(x) , "scaled:scale")
  if (any(x.scale == 0))
      comm.stop("cannot rescale a constant/zero column to unit variance")

  s <- svd(x, nu=0)
  s$d <- s$d/sqrt(max(1, nrow(x) - 1))

  if (!is.null(tol))
  {
    rank <- max(as.integer(sum(s$d > (s$d[1L] * tol))), 1L)
    if (rank < ncol(x))
    {
      s$v <- s$v[, 1L:rank, drop=FALSE]
      s$d <- s$d[1L:rank]
    }
  }

  if (is.null(x.center))
    center = FALSE
  else
    center = x.center

  if (is.null(x.scale))
    scale = FALSE
  else
    scale = x.scale

  r <- list(sdev=s$d, rotation=s$v, center=center, scale=scale)
  if (retx)
    r$x <- x %*% s$v

  class(r) <- "prcomp"

  return(r)
}


lpcSpect <- function(samps, np=256, m=18) {
  np2 = np + np
  lpc <- levnsn(wav2r(samps,m), m)
  h <- c(lpc$a, rep(0, np2 - m))
  af <- 1/np
  sp <- 20*log10(as.vector(af*sqrt(lpc$v))/abs(fft(h))[1:(np+1)])
  sp
}


# Simple Linear Regression

# Importing the data set
dataset = read.csv('Salary_Data.csv')

# Splitting the data set into the Training set and Test set
library(caTools)
set.seed(123)
split = sample.split(dataset$Salary, SplitRatio = 2/3)
training_set = subset(dataset, split == TRUE)
test_set = subset(dataset, split == FALSE)

# Fitting Simple Linear Regression to the Training set
regressor = lm(formula = Salary ~ YearsExperience,
               data = training_set)

# Predicting the Test set results
y_pred = predict(regressor, newdata = test_set)

# Visualizing the Training set results
ggplot() +
  geom_point(aes(x = training_set$YearsExperience, y = training_set$Salary),
             colour = 'red') +
  geom_line(aes(x = training_set$YearsExperience, y = predict(regressor, newdata = training_set)),
            color = 'blue') +
  ggtitle('Salary vs Experience (Training set)') +
  xlab('Year of experience') +
  ylab('Salary')

# Visualizing the Test set results
ggplot() +
  geom_point(aes(x = test_set$YearsExperience, y = test_set$Salary),
             colour = 'red') +
  geom_line(aes(x = training_set$YearsExperience, y = predict(regressor, newdata = training_set)),
            color = 'blue') +
  ggtitle('Salary vs Experience (Test set)') +
  xlab('Year of experience') +
  ylab('Salary')


#Load Libraries
library(mlbench)
library(randomForest)
library(dplyr)

#Load the data
data(PimaIndiansDiabetes)
df<-PimaIndiansDiabetes
#Explore the length and breadth of the data
str(df)

#Setting seed for reproducability
library(caret)
set.seed(2019)

#Create 70% train and 30% test dataset
train_index <- sample(seq_len(nrow(df)),floor(0.7 * nrow(df)))
train <- df[train_index,]
test <- df[-train_index,]
print("Training Dataset shape:")
print(dim(train))
print("Test Dataset shape:")
print(dim(test))

#Train model on train dataset
model <-randomForest(diabetes~.,data=train, mtry =3)
print(model)

#Predict on test dataset
y_predicted <- predict(model, newdata = test)

#Create Confusion-Matrix
results<-confusionMatrix(y_predicted, test$diabetes, positive= 'pos')
print("Confusion Matrix  (Test Data)- ")
print(results$table)

#Print overall Accuracy
results$overall[1]

library(caret)
set.seed(2019)

#Define function for 4 fold cross validation
train_control = trainControl(method = "cv",  number=5, savePredictions = TRUE,verboseIter = TRUE)

#Defining the value of mtry =3 (to match our previous example)
parameter_values = expand.grid(mtry=3)

#Fit the model
model_rf_kfold<- train(diabetes~., data=df, trControl=train_control,
                    method="rf",  metric= "Accuracy",
                    tuneGrid = parameter_values)
#Print Overall Accuracy (Averaged across all folds)
model_rf_kfold$results[2]

#Print the detailed prediction dataset
print("Shape of Prediction Dataset")
print(dim(model_rf_kfold$pred))

print("Prediction detailed results - ")
head(model_rf_kfold$pred) #print first 6 rows
tail(model_rf_kfold$pred) #print last 6 rows

print("Accuracy across each Fold-")
model_rf_kfold$resample

print(paste("Average Accuracy :",mean(model_rf_kfold$resample$Accuracy)))
print(paste("Std. Dev Accuracy :",sd(model_rf_kfold$resample$Accuracy)))

#Define function for 4 fold cross validation
set.seed(2019)
train_control = trainControl(method = "LOOCV", savePredictions = TRUE)

#Defining the value of mtry =3 (to match our previous example)
parameter_values = expand.grid(mtry=3)

#Fit the model
model_rf_LOOCV<- train(diabetes~., data=df, trControl=train_control,
                    method="rf",  metric= "Accuracy",
                    tuneGrid = parameter_values)
#Print Overall Accuracy (Averaged across all folds)
print(model_rf_LOOCV$results[2])

#Print the detailed prediction dataset
print("Shape of Prediction Dataset")
print(dim(model_rf_LOOCV$pred))

print("Prediction detailed results - ")
head(model_rf_LOOCV$pred) #print first 6 rows

tail(model_rf_LOOCV$pred) #print last 6 rows

#Grid Search Optimization : Random Forest
#Define the Cross Validation method
set.seed(2019)
train_control = trainControl(method = "cv",  number=5, savePredictions = TRUE)

#Define Parameter Grid
parameter_grid = expand.grid(mtry=c(1,2,3,4,5,6))

#Fit the model with cross validation and grid search optimization
model_rf_gridSearch<- train(diabetes~., data=df, trControl=train_control,
               method="rf",  metric= "Accuracy",
               tuneGrid = parameter_grid)

#Print Overall Accuracy (Averaged across all folds)
print("Accuracy across hyperparameter Combinations:")
print(model_rf_gridSearch$results[,1:2])

#Print the detailed prediction dataset
print("Shape of Prediction Dataset")
print(dim(model_rf_gridSearch$pred))

print("Prediction detailed results - ")
print(head(model_rf_gridSearch$pred)) #print the first 6 rows

print(tail(model_rf_gridSearch$pred)) #print the last 6 rows

print("Best value for Hyperparameter 'mtry':")
print(model_rf_gridSearch$bestTune)

print("Final (Best) Model ")
print(model_rf_gridSearch$finalModel)

#Plot the grid metrics
library(repr)
options(repr.plot.width=8, repr.plot.height=5)
plot(model_rf_gridSearch)

#Grid Search Optimization - XGBoost
set.seed(2019)
#Define the Cross Validation method
train_control = trainControl(method = "cv",  number=5, savePredictions = TRUE)

#Define Parameter Grid
parameter_grid = expand.grid(nrounds = c(30,50,60,100),
                             eta=c(0.01,0.1,0.2,0.3),
                             max_depth = c(2,3,4,5),
                             gamma = c(1),
                             colsample_bytree = c(0.7),
                             min_child_weight = c(1)  ,
                             subsample = c(0.6)
                            )

#Fit the model with cross validation and grid search optimization
model_xgb_gridSearch<- train(diabetes~., data=df, trControl=train_control,
               method="xgbTree",  metric= "Accuracy",
                            tuneGrid = parameter_grid)

#Print the detailed prediction dataset
print("Shape of Prediction Dataset")
print(dim(model_xgb_gridSearch$pred))

print("Prediction detailed results - ")
head(model_xgb_gridSearch$pred) #print the first 6 rows

tail(model_xgb_gridSearch$pred) #print the last 6 rows

print("Best values for all selected Hyperparameters:")
model_xgb_gridSearch$bestTune

#Print Overall Accuracy (Averaged across all folds)
print("Average results across different combination of Hyperparameter Values")
model_xgb_gridSearch$results %>% arrange(desc(Accuracy)) %>% head(5)

library(repr)
options(repr.plot.width=8, repr.plot.height=5)
plot(model_xgb_gridSearch)

#Random Search Optimization - Random Forest

#Define the Cross Validation method
set.seed(2019)
train_control = trainControl(method = "cv",  number=5, savePredictions = TRUE)

#Fit the model with cross validation and grid search optimization
model_rf_randomSearch<- train(diabetes~., data=df, trControl=train_control,
                               method="rf",  metric= "Accuracy",tuneLength = 35)

#Print the detailed prediction dataset
print("Shape of Prediction Dataset")
print(dim(model_rf_randomSearch$pred))

print("Prediction detailed results - ")
head(model_rf_randomSearch$pred) #print the first 6 rows

tail(model_rf_randomSearch$pred) #print the last 6 rows

print("Best values for all selected Hyperparameters:")
model_rf_randomSearch$bestTune

#Print Overall Accuracy (Averaged across all folds)
model_rf_randomSearch$results %>% arrange(desc(Accuracy)) %>% head(5)

plot(model_rf_randomSearch)

#Random Search Optimization - XGBoost
set.seed(2019)

#Define the Cross Validation method
train_control = trainControl(method = "cv",  number=5, savePredictions = TRUE)

#Fit the model with cross validation and random search optimization
model_xgb_randomSearch<- train(diabetes~., data=df, trControl=train_control,
                               method="xgbTree",  metric= "Accuracy",tuneLength = 15)

#Print the detailed prediction dataset
print("Shape of Prediction Dataset")
print(dim(model_xgb_randomSearch$pred))

print("Prediction detailed results - ")
head(model_xgb_randomSearch$pred) #print the first 6 rows

tail(model_xgb_randomSearch$pred) #print the last 6 rows

print("Best values for all selected Hyperparameters:")
model_xgb_randomSearch$bestTune

#Print Overall Accuracy (Averaged across all folds for each hyperparameter combination)
model_xgb_randomSearch$results %>% arrange(desc(Accuracy)) %>% head(5)

set.seed(2019)
library(MlBayesOpt)
model_rf_bayesain <- rf_opt(train_data = train,
                       train_label = diabetes,
                       test_data = test,
                       test_label = diabetes,
                       mtry_range = c(1L, ncol(df)-1),
                       num_tree = 50,
                       init_points = 10,
                       n_iter = 10,
                       acq = "poi", eps = 0,
                       optkernel = list(type = "exponential", power =2))

set.seed(2019)
model_xgb_bayesian <- xgb_opt(train, diabetes, test, diabetes,
                              objectfun ='binary:logistic', evalmetric='logloss',
                              eta_range = c(0.1, 1L), max_depth_range = c(2L, 8L),
                              nrounds_range = c(70, 160L), #subsample_range = c(0.1, 1L),
                              bytree_range = c(0.4, 1L), init_points = 4, n_iter = 10,
                              acq = "poi", eps = 0, optkernel = list(type = "exponential", power =2))

Lesson07/Chapter 7 - Model Improvements.r


#Applying an absolute value function to create a new variable
df$EV_DiffAbs <- abs(df$EV_Diff)
#Checking the new column values as compared to the old column values
table(df$EV_DiffAbs, df$EV_Diff)


library(ggplot)
library(ggplot2)
library(pastecs)
library(fBasics)
install.packages("VGAM")
library(VGAM)

projectstat <- read.csv("~//Desktop//Technicaldebt//eds-projectstat.csv")

project = projectstat$project
loc = projectstat$loc
initialloc = projectstat$initialcommitdate
recentcommit = projectstat$recentdate
activedevs = projectstat$activedevs
totaldevs= projectstat$totaldevs
yearcount = projectstat$yearcount
age = projectstat$age
bugcount = projectstat$bugcount
vulnerabilities = projectstat$vulnerabilities
bd = projectstat$bd
vulns = projectstat$vulns
cocomo = projectstat$cocomo

colnames(projectstat)[1] <- "project"
colnames(projectstat)[2] <- "loc"
colnames(projectstat)[3] <- "initialcommit"
colnames(projectstat)[4] <- "recentcommit"
colnames(projectstat)[5] <- "activedevs"
colnames(projectstat)[6] <- "totaldevs"
colnames(projectstat)[7] <- "yearcount"
colnames(projectstat)[8] <- "age"
colnames(projectstat)[9] <- "bugcount"
colnames(projectstat)[10] <- "vulnerabilities"
colnames(projectstat)[11] <- "bd"
colnames(projectstat)[12] <- "vulns"
colnames(projectstat)[13] <- "cocomo"

cor(projectstat$bugcount,projectstat$vulnerabilities)
cor(projectstat$bugcount, projectstat$vulns)
cor(projectstat$bd, projectstat$vulns)
cor(projectstat$cocomo, projectstat$vulns)
#As cocomo increases, vulnerabilities increases (.632)
cor(projectstat$cocomo, projectstat$vulnerabilities)
cor(projectstat$loc, projectstat$vulns)
#.6327
cor(projectstat$loc, projectstat$vulnerabilities)
cor(projectstat$age, projectstat$vulnerabilities)
cor(projectstat$yearcount, projectstat$vulnerabilities)
cor(projectstat$activedevs, projectstat$vulnerabilities)
cor(projectstat$totaldevs, projectstat$vulnerabilities)
cor(projectstat$activedevs, projectstat$vulns)
cor(projectstat$totaldevs, projectstat$vulns)
cor(projectstat$vulnerabilities, projectstat$bd)
cor(projectstat$totaldevs,projectstat$bugcount)
cor(projectstat$loc,projectstat$bugcount)

totaleffort <- (projectstat$cocomo/projectstat$totaldevs)
cor(projectstat$cocomo, projectstat$bugcount)
cor(projectstat$yearcount, projectstat$bugcount)

totaleffort <-(projectstat$totaldevs*projectstat$yearcount)
cor(projectstat$totaleffort, projectstat$vulnerabilities)

hist(bugcount)

plot(projectstat$vulnerabilities)
plot(projectstat$cocomo)

shapiro.test(projectstat$bd)

qqnorm(vulnerabilities, main = 'Normal Probability Plot of Vulnerabilities')
qqnorm(cocomo, main = 'Normal Probability Plot of Cocomo')

effort <-((projectstat$cocomo/projectstat$totaldevs))
plot(cocomo,vulnerabilities)
abline(lm(vulnerabilities ~ effort), col="red")

lm.out=lm(vulnerabilities~cocomo)
summary(lm.out)

lm.out=lm(vulnerabilities~cocomo+bugcount)
summary(lm.out)

lm.out=lm(vulns~cocomo)
summary(lm.out)

#!!!! r-squared .5331
lm.out=lm(vulnerabilities~loc+totaldevs)
summary(lm.out)

#r-squared .543
lm.out=lm(vulnerabilities~loc+activedevs)
summary(lm.out)

#!!! r-squared .5512
totaleffort <-(projectstat$totaldevs*projectstat$yearcount)
lm.out=lm(vulnerabilities~loc+totaleffort)
summary(lm.out)

options(scipen=999)
#!! r-squared .2965
totaleffort <-(projectstat$totaldevs*projectstat$yearcount)
adjloc <- (projectstat$loc/100000)
lm.out=lm(vulnerabilities~adjloc+totaleffort)
summary(lm.out)

totaleffort <-(projectstat$totaldevs*projectstat$yearcount)
adjloc <- (projectstat$loc/100000)
lm.out=lm(vulns~adjloc+totaleffort)
summary(lm.out)

summary(m<-vglm(vulnerabilities~adjloc+totaleffort, tobit(Lower = 0), data = projectstat ))

sd(projectstat$loc)
mean(projectstat$loc)

totaleffort <-(projectstat$totaldevs*projectstat$yearcount)
sd(projectstat$totaldevs)
mean(projectstat$totaldevs)

sd(projectstat$yearcount)
mean(projectstat$yearcount)

sd(projectstat$vulnerabilities)
mean(projectstat$vulnerabilities)

hist(vulnerabilities)
plot(loc~vulnerabilities)
plot(adjloc~vulnerabilities)
plot(loc~age)

#not significant
totaleffort <-(projectstat$totaldevs*projectstat$yearcount)
lm.out=lm(vulns~totaleffort)
summary(lm.out)

lm.out=lm(vulns~totaleffort)
summary(lm.out)

log.vulnerabilities <-log(vulnerabilities)
hist(log.vulnerabilities)

log.cocomo <-log(cocomo)
hist(log.cocomo)

root.vuln <- (vulnerabilities)^.5
root.cocomo <- (cocomo)^.5

hist(root.vuln)

qqnorm(root.vuln)
qqnorm(root.cocomo)
qplot(trans.fitted, trans.resid) + geom_hline(yintercept = 0)
qplot(trans.fitted, cocomo) + geom_hline(yintercept = 0)

#t test *, positive
lm.out1=lm(vulns~cocomo)
summary(lm.out1)

#t test *, positive
lm.out3=lm(vulns~loc)
summary(lm.out3)

lm.out-(vulns~cocomo+bd+age)
summary(lm.out)


## library(devtools)
# use_package("data.table")
# use_package("Hmisc")
library(Hmisc)
library(data.table)
library(plyr)

## ** Functions

##' Generic function for quantile binning
##'
##' Creates quantiles of variable `numerical.var` (supplied as a single string)
##' using weights given by `weight.var`.
##'
##' @title Generic quantile binning
##' @param DT Data table to be summarized
##' @param numerical.var [str(1)] which variable will be quantilized
##' @param weight.var [num] weights with which quantiles are constructed
##' @param by.vars [str(n)] vector of variables by which
##' @param outvarnames not implemented yet: control return names
##' @param wt.quantile.fun [function] f(x,w) where x and w have equal length
##' @param ... extra arguments to `cut`
##' @return
##' @author Gustavo
dt_quantilebins_generic <- function(DT, numerical.var, weight.var, by.vars=NULL, outvarnames,
                                    wt.quantile.fun, scale, ...) {
  r <- DT[, {
    scaled_x <- get(numerical.var)*scale
    quantiles <- wt.quantile.fun(scaled_x, get(weight.var))
    # quantiles <- wt.quantile.fun(get(numerical.var))
    bin_label <- cut(scaled_x, breaks=quantiles, ordered_result = TRUE, ...)
    ll <- list(tmpvarname__ = scaled_x, bin_label=as.character(bin_label),
         bin_n=as.integer(bin_label), orig_pos=.I)
    names(ll)[1] <- numerical.var
    ll
  },by.vars]

  data.table::setkey(r, orig_pos)
  r[, orig_pos := NULL]

  return(r)
}

##'  Compute weighted quantiles of a data.table `DT`
##'
##'  Apply `dt_quantilebins_generic` with Hmisc's `wtd.quantile` to find
##'  weighted quantiles. The number of percentiles is governed by `ntile`: with
##'  `ntile=5`, the function computes quintiles, with `ntile=4` quartiles,and so
##'  on.
##'
##' The `...` are passed to the `cut` function. Note that `ordered_result=TRUE`
##' necessarily (i.e., it's not an option).
##'
##'
##' @title Weighted quantile bins from data.table data
##' @param DT [data.table] data
##' @param numerical.var [str(1)] variable to be quantilized
##' @param wt.var [str(1)] variable to be used as weight
##' @param by.vars [str(n)] variable to subset by when computing quantiles
##' @param ntile [int] number of quantiles
##' @param outvarnames to be implemented
##' @param bounds [num(2)] natural bounds for `numerical.var` (for pretty printing)
##' @param ... extra arguments to the `cut` function
##' @return
##' @author Gustavo
##' @export
dt_quantilebins_weighted <- function(DT, numerical.var, wt.var, by.vars=NULL, ntile=5, outvarnames=c("bin", "bin_n"),
                                     scale = 1,
                                     bounds=c(-Inf, Inf), ...) {

  prob_range <- seq(0, 1, by=1/ntile)
  bin_define <- prob_range[-c(1, length(prob_range))]

  quantile.fun <- function(x,w) {
    c(bounds[1], Hmisc::wtd.quantile(x, weights=w, bin_define), bounds[2])
  }

  dt_quantilebins_generic(DT, numerical.var, wt.var, by.vars, outvarnames, quantile.fun, scale, ...)
}

#' @export

#' @export
tab <- function(DT, cols_tab, cols_subs=NULL, percent=TRUE) {
  mm <- ifelse(percent, 100, 1)

  tot <- DT[, .N]

  # All the necessary computation is done here...
  res <- DT[, .(`Number of occurrences` = .N), c(cols_tab, cols_subs)]
  res[, `Proportion of total` := mm*`Number of occurrences`/ tot]
  res[, `Proportion in group` := mm*`Number of occurrences`/ sum(`Number of occurrences`), cols_subs]
  # ... the rest is just taking this results and outputting them

  subs_gr <- unique(res[, cols_subs, cols_subs, with=FALSE]) # Find unique subsetting groups

  data.table::setkeyv(res, cols_subs)
  data.table::setkeyv(subs_gr, cols_subs)

  ## Loop over subsetting groups
  if (nrow(subs_gr) == 0) {
    return(list(list(
      group_name = "Full sample",
      tab = res[order(get(cols_tab))]
    )))
  }

  subs_names <- names(subs_gr) # Keep subsetting group names
  lapply(1:nrow(subs_gr),
         function(i) {
           ## For subset group `i`, lookup values in `res`
           this_gr <- subs_gr[i]
           tab <- this_gr[res, nomatch=0]
           group_vals <- paste(subs_names, unlist(this_gr), sep=" = ")

           data.table::setkeyv(tab, cols_tab)

           list(
             group_name = paste(group_vals, collapse=", "),
             tab = tab[order(get(cols_tab))]
           )
         })
}

#' @export
wtd.tab.flat <- function(DT, cols_tab, col_wt, cols_subs=NULL, percent=TRUE) {
  data.table::rbindlist(lapply(wtd.tab(DT, cols_tab, col_wt, cols_subs, percent),
                   function(l_subs) l_subs$tab))
}

#' @export
wtd.tab <- function(DT, cols_tab, col_wt="one", cols_subs=NULL, percent=TRUE) {
  mm <- ifelse(percent, 100, 1)

  tot <- DT[, sum(get(col_wt))]

  # All the necessary computation is done here...
  res <- DT[, .(`Number of occurrences` = sum(get(col_wt))), c(cols_tab, cols_subs)]
  res[, `Proportion of total` := mm*`Number of occurrences`/ tot]
  res[, `Proportion in group` := mm*`Number of occurrences`/ sum(`Number of occurrences`), cols_subs]
  # ... the rest is just taking this results and outputting them

  subs_gr <- unique(res[, cols_subs, cols_subs, with=FALSE]) # Find unique subsetting groups

  setkeyv(res, cols_subs)
  setkeyv(subs_gr, cols_subs)

  ## Loop over subsetting groups
  if (nrow(subs_gr) == 0) {
    return(list(list(
      group_name = "Full sample",
      tab = res[order(get(cols_tab))]
    )))
  }

  subs_names <- names(subs_gr) # Keep subsetting group names
  lapply(1:nrow(subs_gr),
         function(i) {
           ## For subset group `i`, lookup values in `res`
           this_gr <- subs_gr[i]
           tab <- this_gr[res, nomatch=0]
           group_vals <- paste(subs_names, unlist(this_gr), sep=" = ")

           setkeyv(tab, cols_tab)

           list(
             group_name = paste(group_vals, collapse=", "),
             tab = tab[order(get(cols_tab))]
           )
         })
}

colnames_verify <- function(list.DT){
  ## Inputs:
  ##   list.DT       :: (list)       :: list with data tables
  ## Outputs:
  ##   name_analysis :: (data.table) :: data table with output of column name
  ##                                    analysis

  list_names  <- sapply(list.DT, colnames)
  maximal_name  <- Reduce(union, list_names)

  name_analysis  <- data.table(
    colname = maximal_name
  )

  in_maximal  <- lapply(list.DT, function(DT) colnames(DT) %in% maximal_name)
  setDT(in_maximal)
  name_analysis  <- cbind(name_analysis, in_maximal)
}

setGroup <- function(DT, col_group, group_list, groupvarname = NULL, ...) {
  ## Format of `group_list`:
  ## ```{R}
  ## list(
  ##   group1 = c("g1_level1", "g1_level2", ...)
  ##   group2 = c("g2_level1", "g2_level2", ...)
  ## )
  ## ```

  ## Ellipsis are passed to the factor command

  ## Create dictionary:
  dict <- rbindlist(lapply(names(group_list), function(gname) {
    data.table(groupname = gname,
               vals = group_list[[gname]])
  }))
  dict[, groupname := factor(groupname, levels = unique(groupname))]

  if (is.null(groupvarname)) {
    groupvarname <- paste(col_group, "group", sep="_")
  }

  setnames(dict, c("vals"), c(col_group))

  DT[dict, (groupvarname) := groupname, on=col_group]
}

changeLevels <- function(DT, vname, old, new) {
   fac <- DT[, get(vname)]
   vnew <- mapvalues(fac, from=old, to=new)
   DT[, (vname) := vnew]
}

unitSample <- function(DT, unit_col, N) {
  sample(DT[, unique(get(unit_col))], N)
}


#' Plot Cutoff Table
#'
#' This function loads a file as a matrix. It assumes that the first column
#'
#' @param cutoff_table A cutoff table as generated by the generate_cutoff_table function/
#' @return A ggplot of the percentage of observations that are greater than the cutoff.
#' @export
plot_cutoff_table <- function(cutoff_table){
  p <- ggplot2::ggplot(cutoff_table, ggplot2::aes(x=cutoff, y=fraction_smaller_than_cutoff, group=1)) +
    ggplot2::geom_line() +
    ggplot2::xlab('Cutoff') +
    ggplot2::ylab('Fraction of input > cutoff') +
    ggplot2::ggtitle('Cumulative percentage of input > cutoff') + ggplot2::theme_bw()
  return(p)
}


 DSBGST Example Program Results

 Eigenvalues
    -0.8305 -0.6401  0.0992  1.8525


# homework: see the example on page 96 in Dean & Voss's book

library(daewr)
data(chem)
chem

model1 = aov(y ~ A * B * C * D, data = chem)
model1

model2 = lm(y ~ A * B * C * D, data = chem)
model2

coef(model2)

# effects without the Intercept
coef(model2)[-1]

fullnormal(coef(model2)[-1], alpha = 0.025)

LGB(coef(model2)[-1])

model6 = aov(y~A*B, data = chem)
model6


qsort <- function(v) {
  if ( length(v) > 1 )
  {
    pivot <- (min(v) + max(v))/2.0                            # Could also use pivot <- median(v)
    c(qsort(v[v < pivot]), v[v == pivot], qsort(v[v > pivot]))
  } else v
}

r=0

executeTask <- function(i) {

qsort(c(16+i,93,-99,95,-96,-24,-53,-71,96,-66,-21,72,-12,-32,-96,62,-42,-50,49,53,-65,52,-25,-69,88,-43,60,66,-94,-69,53,-71,-17,-58,-30,32,-16,-94,-42,-86,59,-53,94,97,-12,15,65,-35,-12,-82,-82,48,-48,66,-42,-63,33,-49,41,-85,94,66,-60,60,-65,-73,-50,-9,-48,-3,15,-77,81,95,-93,83,-21,34,-78,-61,-22,-58,65,78,41,-7,-59,20,88,-38,-15,-69,42,97,-35,61,8,2,-22,-85)) # -31   0   1   2   4  65  83  99 782))
	return(i+1)
}

for(i in 0:10000000) {
	r = executeTask(i)
}


library(readr)
library(tidyr)
library(caret)
library(dplyr)
library(pROC)

# DATA PREPARATION -------------------

# import data
denguecases <- read_delim("C:/Training/17_10_03_Intro_Explod/denguecases.csv",
                          ";", escape_double = FALSE, locale = locale(date_names = "nl",
                                                                      decimal_mark = ","), trim_ws = TRUE)
# rename and select columns
dengue <- denguecases %>%
  rename(country = Country, temp = Temperature, pop = Population, prec = Precipations, urb = Urbanization, dengue = `Possibility`) %>%
  select(c(1:7),-6) # select relevant columns (with dengue probability instead of dengue cases)
dengue$dengue <- dengue$dengue %>%
  factor(labels = c('No', 'Yes'))

# split data in 2 groups: one for modelbuilding (training 75%) and one for testing (25%)
set.seed(42) # for reproducability
N <- nrow(dengue) # define number of rows

shuffle <- dengue[sample(N), ] # shuffle the rows of the data

dengue_mod <- shuffle[1:round(N * .75), ] # 75% of data is for model building
dengue_val <- shuffle[-c(1:round(N * .75)), ] # 25% of data is for validation

# Create dengue occurence as outcome
outcome <- dengue_mod$dengue

# Create input variables as data.frame
input <- dengue_mod %>%
  select(temp, pop, prec, urb) %>%
  as.data.frame()

# MODEL BUILDING --------------

# Create reusable trainControl object: myControl
myControl <- trainControl(
  method = 'cv', number = 10,
  summaryFunction = twoClassSummary,
  classProbs = TRUE, # IMPORTANT!
  verboseIter = TRUE,
  savePredictions = TRUE)

# Fit glmnet model: model_glmnet
model_glmnet <- train(x = input, y = outcome,
                      metric = "ROC",
                      method = 'glmnet',
                      tuneGrid = expand.grid(
                        alpha = 0:1,
                        lambda = 0:10/10),
                      trControl = myControl
)

plot(model_glmnet)

# Fit random forest model: model_rf
model_rf <- train(x = input, y = outcome,
                  metric = "ROC",
                  method = 'ranger',
                  trControl = myControl)

plot(model_rf)

# Fit gradient boosting model: model_gb
model_gb <- train(x = input, y = outcome,
                  metric = "ROC",
                  method = 'gbm',
                  trControl = myControl
)

plot(model_gb)

# Fit gam: model_gam
model_gam <- train(x = input, y = outcome,
                   metric = "ROC",
                   method = 'gam',
                   trControl = myControl
)

plot(model_gam)

# Create model_list
model_list <- list(glmnet = model_glmnet, rf = model_rf, gb = model_gb, gam = model_gam)

# Pass model_list to resamples(): resamples
resamples = resamples(model_list)

# Summarize the results
summary(resamples)
bwplot(resamples, metric = 'ROC')
densityplot(resamples, metric = 'ROC')
xyplot(resamples, metric = 'ROC')
dotplot(resamples, metric = 'ROC')

# MODEL VALIDATING ----
# predictions on training data
pred <- predict(model_rf, dengue_mod, type = 'prob')

pred2 <- predict(model_rf, dengue_mod, type = 'raw')
confusionMatrix(pred2, dengue_mod$dengue)

# predictions of testing data
pred3 <- predict(model_rf, dengue_val, type = 'prob')

pred4 <- predict(model_rf, dengue_val, type = 'raw')
confusionMatrix(pred4, dengue_val$dengue)

# ROC curves
ROC <- roc(as.numeric(outcome), pred$Yes)
plot.roc(ROC, col = '#F4B828', print.auc = T, xlab = 'False positive rate (1 - Specificity)', ylab = 'True positive rate (Sensitivity)', legacy.axes = T)

ROC2 <- roc(as.numeric(dengue_val$dengue), pred3$No)
plot(ROC2, col = '#5E7164', print.auc = T, print.auc.y = 0.4, add = T)


  speciescomposition_db = function( DS="", p=NULL, redo=FALSE ) {

    ddir = project.datadirectory( "aegis", "speciescomposition" )
    dir.create( ddir, showWarnings=FALSE, recursive=TRUE )

    infix = paste( p$spatial_domain,  p$taxa, sep=".")
    if (p$spatial_domain == "snowcrab" ) {
      infix = paste( "SSE",  p$taxa, sep=".")  # just one domain for now
    }

    if (DS %in% c( "speciescomposition.ordination", "speciescomposition.ordination.redo", "pca", "ca") ) {

      fn.set = file.path( ddir, paste( "speciescomposition.by.set", infix, "rdata", sep=".") )
      fn.pca = file.path( ddir, paste( "pca", infix, "rdata", sep=".") )
      fn.ca  = file.path( ddir, paste( "ca",  infix, "rdata", sep=".") )

      if (DS=="speciescomposition.ordination") {
        set = NULL
        if (file.exists( fn.set) ) load( fn.set)
        return ( set )
      }

      if (DS=="pca") {
        pca.out = NULL
        if (file.exists( fn.pca) ) load( fn.pca)
        return ( pca.out )
      }

      if (DS=="ca") {
        ca.out = NULL
        if (file.exists( fn.ca) ) load( fn.ca)
        return ( ca.out )
      }

      sc = survey_db( DS="cat" ,p=p)  # species catch

      sc = sc[ which(is.finite( sc$zn ) ), ]
      sc = sc[ , c("id", "spec_bio", "zn" ) ]  # zscore-transformed into 0,1
      sc = sc[ , c("id", "zn","spec_bio" ) ]  # zscore-transformed into 0,1

      set = survey_db( DS="set", p=p) # trip/set loc information

      set = set[ ,  c("id", "yr", "dyear", "sa", "lon", "lat", "t", "z", "timestamp" ) ]
      set = na.omit( set ) # all are required fields

      # filter area
      igood = which( set$lon >= p$corners$lon[1] & set$lon <= p$corners$lon[2]
              &  set$lat >= p$corners$lat[1] & set$lat <= p$corners$lat[2] )
      set = set[igood, ]

      isc = taxonomy.filter.taxa( sc$spec_bio, method=p$taxa, outtype="internalcodes" )
      set = set[ which( set$id %in% unique( sc$id[isc]) ),]

      # .. data loss due to truncation is OK
      # ... smallest abundance adds little information to ordinations
      k = 1e3         # a large constant number to make xtabs work  but not too large as truncation is desired
      sc$zn = as.integer( sc$zn*k )
      m = xtabs( zn ~ as.factor(id) + as.factor(spec_bio), data=sc ) /k

      # remove low counts (absence) in the timeseries  .. species (cols) only
      cthreshold = 0.05 * k  # quantiles to be removed

      finished = F
      while( !(finished) ) {
        i = unique( which(rowSums(m) == 0 ) )
        j = unique( which(colSums(m) <= cthreshold ) )
        if ( ( length(i) == 0 ) & (length(j) == 0 ) ) finished=T
        if (length(i) > 0 ) m = m[ -i , ]
        if (length(j) > 0 ) m = m[ , -j ]
      }

      # PCA
      # no need to correct for gear types/surveys .. assuming no size-specific bias .. perhaps wrong but simpler
      corel = cor( m, use="pairwise.complete.obs" ) # set up a correlation matrix ignoring NAs
      corel[ is.na(corel) ] = 0
      s = svd(corel)  # eigenanalysis via singular value decomposition

      # scores = matrix.multiply (m, s$v)  # i.e., b %*% s$v  .. force a multiplication ignoring NAs
      m[which(!is.finite(m))] = 0
      scores = m %*% s$v  # i.e., b %*% s$v  .. force a multiplication ignoring NAs

      evec = s$v
      ev = s$d
      x = cbind( scores[,1] / sqrt(ev[1] ), scores[,2] / sqrt( ev[2]), scores[,3] / sqrt(ev[3] ) )
      y = cbind( evec[,1] * sqrt(ev[1] ) , evec[,2] * sqrt( ev[2]),  evec[,3] * sqrt( ev[3]) )
      rownames(y) = colnames(m)

      scores = data.frame( id=rownames(m), pca1=as.numeric(x[,1]), pca2=as.numeric(x[,2]), pca3=as.numeric(x[,3]), stringsAsFactors=FALSE )
      set = merge(set, scores, by="id", all.x=T, all.y=F, sort=FALSE)
      pca.out = list( scores=scores, eignenvectors=evec, eigenvalues=ev, cscores=y )
      save( pca.out, file=fn.pca, compress=TRUE)

      # Correpsondence analysis
      require(vegan)
        n = m * 0
        n[ which(m>0) ] = 1
        ord = cca( n )
        sp.sc = scores(ord, choices=c(1:3))$species
        si.sc = scores(ord, choices=c(1:3))$sites
        scores = data.frame( id=as.character(rownames(si.sc)), ca1=as.numeric(si.sc[,1]), ca2=as.numeric(si.sc[,2]), ca3=as.numeric(si.sc[,3]) )
        variances=  ord$CA$eig[1:10]/sum(ord$CA$eig)*100
        set = merge(set, scores, by="id", all.x=T, all.y=F, sort=F)
        ca.out = list( scores=scores, ca=ord, variances=variances )
        save( ca.out, file=fn.ca, compress=T)
        save( set, file=fn.set, compress=T )

      return (fn.set)
    }

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

    if (DS %in% c( "speciescomposition", "speciescomposition.redo" ) ) {
      # remove dups and in planar coords
      fn = file.path( ddir, paste( "speciescomposition", infix, "rdata", sep=".") )

			if (DS=="speciescomposition") {
        SC = NULL
        if (file.exists( fn) ) load( fn )
        return ( SC )
			}

      SC = speciescomposition_db( DS="speciescomposition.ordination", p=p )
      SC = lonlat2planar( SC, proj.type=p$aegis_proj4string_planar_km )
      SC$lon = SC$lat = NULL

      oo = which(!is.finite( SC$plon+SC$plat ) )
      if (length(oo)>0) SC = SC[ -oo , ]  # a required field for spatial interpolation

      yrs = sort( unique( SC$yr ) )
      # check for duplicates
      for ( y in yrs ) {
        yy = which (SC$yr == y)
        ii = which( duplicated( SC$id[yy] ) )

        if (length(ii) > 0) {
          dd = which( SC$id[yy]  %in% SC$id[yy] [which(duplicated(SC$id[yy] ))])
          print( "The following sets have duplicated positions. The first only will be retained" )
          print( SC[yy,] [dd ] )
          SC = SC[ - ii,]
        }
      }

      imperative = c( "pca1", "pca2",  "pca3", "ca1", "ca2", "ca3" )
      ii = which( is.finite( rowSums( SC[,imperative ] ) ) )
      if (length(ii) == 0) stop( "No data .. something went wrong")
      SC = SC[ii,]

      save( SC, file=fn, compress=T )
			return (fn)
		}

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

    if ( DS=="areal_units_input" ) {

      fn = file.path( p$datadir,  "areal_units_input.rdata" )
      if ( !file.exists(p$datadir)) dir.create( p$datadir, recursive=TRUE, showWarnings=FALSE )

      xydata = NULL
      if (!redo)  {
        if (file.exists(fn)) {
          load( fn)
          return( xydata )
        }
      }
      xydata = speciescomposition_db( p=p, DS="speciescomposition"  )  #
      xydata = planar2lonlat(xydata, p$areal_units_proj4string_planar_km)  # should not be required but to make sure
      names(xydata)[which(names(xydata)=="z.mean" )] = "z"
      xydata = xydata[ geo_subset( spatial_domain=p$spatial_domain, Z=xydata ) , ] # need to be careful with extrapolation ...  filter depths
      xydata = xydata[ , c("lon", "lat", "yr" )]
      save(xydata, file=fn, compress=TRUE )
      return( xydata )
    }

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

    if ( DS=="carstm_inputs") {

      # prediction surface
      crs_lonlat = st_crs(projection_proj4string("lonlat_wgs84"))
      sppoly = areal_units( p=p )  # will redo if not found
      sppoly = st_transform(sppoly, crs=crs_lonlat )
      areal_units_fn = attributes(sppoly)[["areal_units_fn"]]

      # over-ride
      p$variabletomodel = "speciescomposition"  # force to be generic to share across variables

      label =  "carstm_inputs"
      if (p$carstm_inputs_prefilter =="rawdata") label = "carstm_inputs_rawdata"
      fn = carstm_filenames( p=p, returntype=label, areal_units_fn=areal_units_fn )

      # inputs are shared across various secneario using the same polys
      #.. store at the modeldir level as default
      outputdir = dirname( fn )
      if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )

      M = NULL
      if (!redo)  {
        if (file.exists(fn)) {
          load( fn)
          M = M[ which( M$yr %in% p$yrs), ]
          return( M )
        }
      }
      # message( "Generating carstm_inputs ... ")

      # do this immediately to reduce storage for sppoly (before adding other variables)

      M = speciescomposition_db( p=p, DS="speciescomposition"  )
      setDT(M)

      vars_to_retain = c("pca1", "pca2", "pca3", "ca1", "ca2", "ca3" )

      if (p$carstm_inputs_prefilter != "aggregated") {
        if (exists("quantile_bounds", p)) {
          for (vn in vars_to_retain) {
            TR = quantile(M[[vn]], probs=p$quantile_bounds, na.rm=TRUE )
            oo = which( M[[vn]] < TR[1])
            if (length(oo) > 0) M[[vn]][oo] = TR[1]
            oo = which( M[[vn]] > TR[2])
            if (length(oo) > 0) M[[vn]][oo] = TR[2]
          }
        }
      }

      # INLA does not like duplicates ... causes optimizer to crash frequently
      # oo = which(duplicated( M[, p$variabletomodel] ))
      # if ( length(oo)> 0) {
      #   eps = exp( log( .Machine$double.eps ) / 2)  # ~ 1.5e-8
      #   M[oo, p$variabletomodel]  = M[oo, p$variabletomodel]  + runif( length(oo), -eps, eps )
      # }

      M = planar2lonlat(M, proj.type=p$aegis_proj4string_planar_km) # get planar projections of lon/lat in km

      ii = which( M$lon > p$corners$lon[1] & M$lon < p$corners$lon[2]  & M$lat > p$corners$lat[1] & M$lat < p$corners$lat[2] )
      M = M[ ii, ]

      names(M)[which(names(M)=="yr") ] = "year"
      M = M[ which(M$year %in% p$yrs), ]
      M$tiyr = lubridate::decimal_date ( M$timestamp )
      M$dyear = M$tiyr - M$year

      M = carstm_prepare_inputdata( p=p, M=M, sppoly=sppoly,
            lookup_parameters = p$carstm_lookup_parameters,
            vars_to_retain=vars_to_retain,
            vars_to_drop ="speciescomposition" )  # drop dummy variable

      jj = which(!is.finite(M$t))
      if (length(jj) > 0 ) {
        M$t[jj] = median( M$t[-jj] )
      }

      jj = which(!is.finite(M$substrate.grainsize))
      if (length(jj) > 0 ) {
        M$substrate.grainsize[jj] = median( M$substrate.grainsize[-jj] )
      }

      attr( M, "proj4string_planar" ) =  p$aegis_proj4string_planar_km
      attr( M, "proj4string_lonlat" ) =  projection_proj4string("lonlat_wgs84")

      save( M, file=fn, compress=TRUE )

      M = M[ which( M$yr %in% p$yrs), ]

      return( M )
    }

  } # end function


# fspec -- formant based frequency spectrum
#
fspec <- function(f, n=128, nyquist=8000) {
  sp = formant(f[1], 100, n, nyquist)
  for (j in 2:length(f)) {
    sp = sp + formant(f[j], 100, n, nyquist) / (f[j]/500)
  }
#  sp = sp * hpc2(length(f), seq(0, nyquist, nyquist/n), f[1])
  return(sp)
}


#' Checking for integer values
#'
#' This function tests whether all entries in a vector are integers (up to rounding error)
#' @param x A numerical vector
#' @export
#' @return Returns TRUE if all entries of x are whole numbers; FALSE otherwise
#' @examples
#' is_wholenumber(c(1,2,4.1))

is_wholenumber <- function(x, tol = .Machine$double.eps^0.5)  all(abs(x - round(x)) < tol)


#'@title calcHMAppendageRes
#'
#'@description Calculate appendage resistance (\code{Rapp}) (kN) from the
#'Holtrop & Mennen method.
#'
#'@param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#'@param Cf Frictional resistance coefficient (vector of numericals,
#' dimensionless) (see \code{\link{calcCf}})
#'@param appendagesList List of appendages on ship (vector of strings) \itemize{
#'\item"rudder behind skeg"
#'\item"rudder behind stern"
#'\item"twin-screw balance rudders"
#'\item"shaft brackets"
#'\item"skeg"
#'\item"strut bossings"
#'\item"hull bossings"
#'\item"shafts"
#'\item"stabilizer fins"
#'\item"dome"
#'\item"bilge keels"
#'}
#'@param wettedAppSAList List of wetted surface areas corresponding to list of appendages
#' (vector of numericals, m^2)
#'@param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals corresponding to the ship speed, provide a single
#' number, or rely on the default
#'
#'@return \code{Rapp} (vector of numericals, kN)
#'
#'@references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calcCf}} }
#'
#'@family Holtrop-Mennen Calculations
#'@family Resistance Calculations
#'
#'@examples calcHMAppendageRes(seq(1,5,1),0.0015,"rudder behind skeg",50,seawaterDensity=1.025)
#' calcHMAppendageRes(seq(1,5,1),0.0015,NA,0,seawaterDensity=1.025)
#'
#'@export

calcHMAppendageRes<- function(shipSpeed,Cf,
       appendagesList,wettedAppSAList,seawaterDensity=1.025){

AppResFactor <- data.frame(appendage=c("rudder behind skeg","rudder behind stern",
"twin-screw balance rudders","shaft brackets","skeg","strut bossings","hull bossings",
"shafts","stabilizer fins","dome","bilge keels"),
resistance.factor=c(1.5,1.4,2.8,3,1.75,3,2,3,2.8,2.7,1.4))

wettedAppSAList[is.na(wettedAppSAList)==TRUE]<-0
appendagesList<- tolower(appendagesList)

FormFactorEqu=0

for(i in 1:length(appendagesList)){
  if(length(AppResFactor$resistance.factor[AppResFactor$appendage==paste(appendagesList[i])]*
      wettedAppSAList[i])>0){
 j<- AppResFactor$resistance.factor[grepl(appendagesList[i],AppResFactor$appendage)==TRUE]*
   wettedAppSAList[i]}else{j<-0}
  FormFactorEqu=FormFactorEqu+j
}

FormFactorEqu<-FormFactorEqu/sum(wettedAppSAList)
FormFactorEqu[is.na(FormFactorEqu)]<-0
Rapp<-0.5*seawaterDensity*(shipSpeed^2)*wettedAppSAList*FormFactorEqu*Cf

return(Rapp)
}


source('bootCIs.R')

points_by_condition <- function(result.df) {

  #compute mean for each user_id and representation
  result.df <- result.df[log(result.df$completion_time) < mean(log(result.df$completion_time)) + 3 * sd(log(result.df$completion_time)),]
  point_aggregate.df <- aggregate(abs(result.df$points), list(result.df$user_id,result.df$condition), sum)

  names(point_aggregate.df) <- c("user_id","condition","points")
  point_aggregate.df$points <- point_aggregate.df$points / 16 #convert to percentage of maximum points
  point_aggregate.df$condition <- revalue(point_aggregate.df$condition, c("animation" = "A",
                                                                          "multiples" = "M"
  ))
  point_aggregate.df$condition <- ordered(point_aggregate.df$condition, levels = c('M','A'))

  points_multiples <- subset(point_aggregate.df, condition=="M")$points
  points_animation <- subset(point_aggregate.df, condition=="A")$points

  n_points_multiples <- length(points_multiples)
  n_points_animation <- length(points_animation)

  if (sum(n_points_multiples) == 0) {
    points_ci_multiples <- c(0,0,0)
  }
  else {
    points_ci_multiples <- bootstrapMeanCI(points_multiples)
  }
  if (sum(n_points_animation) == 0) {
    points_ci_animation <- c(0,0,0)
  }
  else {
    points_ci_animation <- bootstrapMeanCI(points_animation)
  }

  points_analysis = c()
  points_analysis$ratio = c("M","A")
  points_analysis$pointEstimate = c(points_ci_multiples[1],points_ci_animation[1])
  points_analysis$ci.max = c(points_ci_multiples[3],points_ci_animation[3])
  points_analysis$ci.min = c(points_ci_multiples[2],points_ci_animation[2])
  points_analysis$n = c(n_points_multiples,n_points_animation)

  points_analysis.df <- data.frame(factor(points_analysis$ratio),points_analysis$pointEstimate, points_analysis$ci.min, points_analysis$ci.max,points_analysis$n)
  colnames(points_analysis.df) <- c("condition", "mean", "lowerBound_CI", "upperBound_CI","n")

  return(points_analysis.df)
}

total_points_CIs.df <- points_by_condition(trials_test.df)
total_points_CIs.df$condition <- ordered(total_points_CIs.df$condition, levels = c('M','A'))
total_points_CIs.df$task <- 'Overall Correcness'

plot_total_points_CI <- dualChart(total_points_CIs.df,ymin = -0.1,ymax = 1.1,yAxisLabel = "",xAxisLabel = "",displayXLabels = T,displayYLabels = T,vLineVal = -1,percentScale=T)

ggsave(plot = plot_total_points_CI, filename = "plot_total_points_CI.pdf", device="pdf", width = 3.75, height = 0.35, units = "in", dpi = 300)
ggsave(plot = plot_total_points_CI, filename = "plot_total_points_CI.png", device="png", width = 3.75, height = 0.35, units = "in", dpi = 300)

### COMPUTE DIFF

trials_subset.df <- trials_test.df[log(trials_test.df$completion_time) < mean(log(trials_test.df$completion_time)) + 3 * sd(log(trials_test.df$completion_time)),]
total_points.df <- aggregate(trials_subset.df$points, list(trials_subset.df$user_id,trials_subset.df$condition), sum)
names(total_points.df) <- c('user_id','condition','points')
total_points.df$points <- total_points.df$points / 16 #convert to percentage of maximum points
total_points.df$condition <- revalue(total_points.df$condition, c("animation" = "A",
                                                                  "multiples" = "M"
))
total_points.df$condition <- ordered(total_points.df$condition, levels = c('M','A'))

total_points_DiffCI.df <- bootdif(total_points.df)
total_points_DiffCI.df$task <- 'A-M'

plot_total_points_diff_CI <- dualChart(total_points_DiffCI.df,ymin = -0.125,ymax = 0.125,yAxisLabel = "",xAxisLabel = "",displayXLabels = T,displayYLabels = F,vLineVal = 0,percentScale=T)

ggsave(plot = plot_total_points_diff_CI, filename = "plot_total_points_diff_CI.pdf", device="pdf", width = 3.75, height = 0.5, units = "in", dpi = 300)
ggsave(plot = plot_total_points_diff_CI, filename = "plot_total_points_diff_CI.png", device="png", width = 3.75, height = 0.5, units = "in", dpi = 300)


#'
#' @importFrom stats na.omit
#' @importFrom stats var
#+
se <- function(x, na.rm = FALSE) {

  # na.rm = TRUE, we remove NA using na.omit()
  if (na.rm) x <- na.omit(x)

  # calculate and return se
  sqrt(var(x) / length(x))
}

#' t-test across multiple treatment status
#'
#' @description This function picks baseline group
#'     from multiple treatment groups,
#'     and implements t-test between the baseline group and
#'     each treatment group.
#'
#' @param y a formula object whose left hand side is outcome (`y ~ .`).
#' @param d a formula object whose right hand side is treatment variable (`~ d`)
#' @param base a string or numeric value of the baseline group.
#' @param data an object whose class is `data.frame`
#'
#' @return A matrix including mean and its standard error of outcome
#'     in each treatment and p-value of t-test.
#'     This object has `RCT` and `ttest` class.
#'
#' @importFrom purrr map
#' @importFrom purrr reduce
#' @importFrom magrittr %>%
#'
#' @export
#+
ttest_rct <- function(y, d, base, data) {

  # extract treatment and outcome variables
  dvar <- all.vars(d)
  yvar <- all.vars(y)[1]

  # extract treatment status
  assign <- unique(data[, dvar]) %>% unlist(use.names = FALSE)

  # extract outcome vector for baseline treatment status
  basevec <- subset(data, get(dvar) == base)[yvar]

  # implement t-test
  test <- assign %>%
    map(~ subset(data, get(dvar) == .)[yvar]) %>%
    map(~ list(
      t = t.test(x = ., y = basevec),
      se = se(unlist(.), na.rm = TRUE)
    )) %>%
    map(~ matrix(c(.$t$estimate[1], .$se, .$t$p.value), nrow = 1)) %>%
    reduce(rbind)

  colnames(test) <- c("estimate", "se", "pvalue")
  rownames(test) <- assign

  class(test) <- append(c("RCT", "ttest"), class(test))
  return(test)

}


a <- 1:100
IterBinSearch(a, 50)
BinSearch(a, 50, 1, length(a)) # output 50
IterBinSearch(a, 101) # outputs NULL


# Checks MCMC traces of a given experiment
#
# author: Alberto Luubreras
##########################
# http://www.people.fas.harvard.edu/~plam/teaching/methods/convergence/convergence_print.pdf
library(coda)
library(ggplot2)
library(reshape2)

traces.dir <- "./out/clear/DP_threads_140-1"
traces.dir <- "./out/overlapped/DP_threads_60-1"
traces.dir <- "./out/agreement/DP_threads_40_20000-1"
burn <- 17000 # burned samples

# Read trace files
files <- list.files(path = traces.dir, pattern = ".trc", recursive=T, full.names = T)
traces <- NULL
for(i in 1:length(files)){
  filename <- tail(strsplit(files[i], "/", fixed=T)[[1]], 1)
  varname <- strsplit(filename, ".", fixed=T)[[1]][2]
  traces[[varname]] <- read.csv(files[i], sep="")
}

nclusters <- apply(traces[['z']], 1, function(x) {length(unique(x))})

# Plot traces, densities, autocorrelations and Geweke's test for each variabl
# but z and coefficients
traces[['a']]<- traces[['a']][-1] #-1 to ignore the n_clusters column
traces[['b']]<- traces[['b']][-1]  #-1 to ignore the n_clusters column
df.traces <- cbind(traces[['alpha']], traces[['intercept']], 1/(traces[['noise_inv']]), traces[['a']], traces[['b']])
par(mfrow=c(3,4))
par(mfrow=c(3,3)) # no geweke
for (i in 1:ncol(df.traces)){
  varname <- names(df.traces)[i]
  df <- data.frame(df.traces[,i])
  names(df) <- varname
  chain <- mcmc(df)

  # Chain and density plots
  plot(chain, auto.layout = FALSE)

  # Drop the burn-in samplines
  chain[-c(1:burn),]
  # Autocorrelation plot
  autocorr.plot(chain, auto.layout = FALSE)
  ess <- effectiveSize(chain)
  autocorrelation_time <- nrow(chain)/ess
  title(varname)

  # Geweke z-score
  tryCatch(geweke.plot(chain, auto.layout = FALSE), error=function(e) plot(1,1))

  cat(varname, ess, autocorrelation_time, "\n")
}

if(TRUE){
  # Report all autocorrelations in a single plot
  par(mfrow=c(1,1))
  df.temp <- df.traces[,c('alpha', 'mean_mu_a0',
                          'det.R_a0.', 'det.W_a0.', 'beta_a',
                          'det.R_b0.', 'det.W_b0.', 'beta_b')]

  # Prettier without mean_mu_a0
  df.temp <- df.traces[,c('alpha',
                          'det.R_a0.', 'det.W_a0.', 'beta_a',
                          'det.R_b0.', 'det.W_b0.', 'beta_b')]
  df.ac <- data.frame(matrix(NA, nrow=1001, ncol=ncol(df.temp)))
  names(df.ac) <- names(df.temp)
  for (i in 1:(ncol(df.temp))){
    df.ac[,i] <- c(acf(df.temp[,i], plot=FALSE, lag.max =1000)$acf)
  }

  df.ac$lag <- 1:nrow(df.ac) # insert lag variable
  df.ac <- melt(df.ac, id='lag')

  p1 <- ggplot(df.ac, aes(x=lag, y=value, color=variable, linetype=variable))
  p1 <- p1 + geom_line(aes(y=value)) # add lines
  p1 <- p1 + geom_point(data=df.ac[seq(1,nrow(df.ac), by=50),], aes(shape=variable), size = 3) # add shape points

  p1 <- p1 + theme(panel.background = element_blank(),
                   panel.grid.major = element_blank(),
                   panel.grid.minor = element_blank(),
                   axis.line = element_line(colour = "black"),
                   legend.key = element_blank(),
                   legend.title =  element_blank(),
                   aspect.ratio = 4/10,
                   legend.position=c(0.9, 0.7))
  p1 <- p1 + ylab("Autocorrelation")
  print(p1)
}

# Plot z traces in a different way
par(mfrow=c(1,1))
image(as.matrix(traces[['z']]))

# Plot histogram of number of clusters
####################################+
par(mfrow=c(1,2))
nclusters <- apply(traces[['z']][-(1:burn),], 1, function(x) {length(unique(x))})

# plot histogram of number of clusters
hist(nclusters, breaks=100, col="grey", main=NA, xlab="Number of clusters", xlim=c(1,max(nclusters)),  cex.lab=1.2)
box()

# plot size of clusters
sizes <- apply(traces[['z']][-(1:burn),], 1, function(x) {as.vector(sort(table(x)))})
z.matrix <- as.matrix(traces[['z']][-(1:burn),])
sizes <- apply(z.matrix, 1, function(x) {as.vector((sort(table(x), decreasing = TRUE)))})
sizes.all <-  matrix(0, nrow=length(sizes), ncol=max(nclusters))
for (i in 1:nrow(sizes.all)){
  sizes_i <- as.vector((unlist(sizes[i])))
  sizes.all[i,1:length(sizes_i)] <- sizes_i
}
sizes <- data.frame(sizes.all)
means <- colMeans(sizes)
devs <- apply(sizes, 2, sd)^2
plot(means, pch=19, xlab="Clusters", ylab="Number of users", ylim=c(0,21), cex.lab=1.2)
arrows(1:length(means), means-devs/2, 1:length(means), means+devs/2, length=0.075, code=3, angle=90)

dev.copy(png, "ncomponents.png", height=215, unit='mm', res=72)
dev.off()

# plot traces of number of clusters
plot(1:length(nclusters), nclusters, pch=3, type='l', xlab='Iteration', ylab="Number of clusters")

# Plot noise. Good way to check whether it converged or something strange happenned
par(mfrow=c(1,1))
plot(df.traces$noise_inv, type="l")


Rsq.ad <- function(object)
{
    n <- length(residuals(object))
    p <- length(coef(object))
    rsq <- Rsq(object)
    1 - (n - 1)/(n - p) * (1 - rsq)
}


#` TF-IDF normalization with the binary matrix (sparse matrix): calculation of LSI (latent semantic indexing)
#` @param bmat          (sparse matrix)  A saparse matrix of binarized cell-by-feature matrix
#` @param TF            (logic)          If calculate the term frequencies of the input matrix. Use either raw counts or divide by total counts in each cell (default:T)
#` @param log_TF        (logic)          If the input/TF matrix will be log scaled (default:T)
#` @param scale_factor  (numberic)       Multiply terms in TF matrix by scale_factor prior to log1p. Equivalent to adding small pseudocount but doesn't cast to dense matrix at any point
#` @return              (sparse matrix)  A sparse matrix of TF-IDF
tfidf <- function(bmat, TF=TRUE, log_TF=TRUE, scale_factor=100000) {
  if (TF) {
    # "term frequency" method
    tf <- t(t(bmat) / Matrix::colSums(bmat))
  } else {
    # "raw count" method
    tf <- bmat
  }
  # Either TF method can optionally be log scaled
  if (log_TF) {
    if (TF) {
      tf@x <- log1p(tf@x * scale_factor)
    } else {
      tf@x <- log1p(tf@x * 1)
    }
  }
  # IDF "inverse document frequency smooth" method
  idf <- log(1 + ncol(bmat) / Matrix::rowSums(bmat))
  # TF-IDF
  tf_idf_counts <- fast_tfidf(tf, idf)
  rownames(tf_idf_counts) <- rownames(bmat)
  colnames(tf_idf_counts) <- colnames(bmat)
  return(tf_idf_counts)
}


library(ggplot2)
library(cluster)
source("date.r")
source("explore-data.r")

# Attempt to cluster into large number of houses based on geographic
# location and, later, price

weird <- with(geo, is.na(lat) | is.na(long) | lat > 100 | long > -100)
good <- subset(geo, !weird)
loc <- good[c("lat", "long")]

# This only takes a few seconds.
clusters <- clara(loc, k = 100, trace = 1)
# # Takes about 4 hours on my computer
# system.time(clusters <- clara(loc, k = 1000, trace = 1))

good$cl <- clusters$clustering

hulls <- ddply(good, .(cl), function(df) {
  df[chull(df$lat, df$long), c("lat", "long")]
})

qplot(lat, long, data = hulls, group = cl)


x <- 10:1
y <- -4:5
q <- c("Hockey", "Football", "Rugby", "Fencing", "Baseball", "Basketball",
       "Curling", "Lacrosse", "Golf", "Tennis")
myDF <- data.frame(x,y,q)
myDF
myDF <- data.frame(First=x, Second=y, Sport=q)
class(myDF$Sport)
class(myDF)
myDF <- data.frame(first=x, second=y, sport=q, stringsAsFactors = FALSE)
class(myDF$sport)
nrow(myDF)
ncol(myDF)
dim(myDF)
NROW(myDF)
NROW(x)
names(myDF)
names(myDF)[3]
rownames(myDF)
rownames(myDF) <- c("one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten")
myDF
head(myDF)
head(myDF, 4)
tail(myDF, 3)
myDF$sport
myDF[3,2]
myDF[3,2:3]
list1 <- list(1,2,3)
list1
list2 <- list(c(1,2,3))
list2
list3 <- list(c(1,2,3), c(3,4,5,6,7))
list3
myDF
list4 <- list(myDF, 1:10)
list4
list5 <- list(TheDataFrame=myDF, AVector=1:10, ThisList=list3)
list5
names(list5) <- c("data.frame", "vector", "list")
names(list5)
emptyList <- vector(mode="list", length=4)
emptyList
emptyList[[1]] <- 5
list5[["TheDataFrame"]][, 2, drop=FALSE]
list5[[4]] <- 3
list5
A <- matrix(1:10, nrow=5)
A
B <- matrix(21:30, nrow=5)
C <- matrix(21:40, nrow=2)
A, B, C
B
A + B
A * B
A - B
A / B
A == B
A %*% t(B)
colnames(A)
colnames(B) <- c("First", "Second")
rownames(B) <- c("One", "Two", "Three", "Four", "Five")
LETTERS
colnames(C) <- LETTERS[1:10]
rownames(C) <- c("Top", "Bottom")
C
A
t(A)

A %*% C

myArray <- array(1:12, dim=c(2,3,2))
myArray


 ZTGSNA Example Program Results

 S
       1.0E+00    8.2E-01    7.2E-01    8.2E-01

 DIF
       3.2E-01    3.6E-01    5.5E-01    2.8E-01

 Approximate error estimates for eigenvalues of (A,B)
       3.0E-15    3.8E-15    4.3E-15    3.8E-15

 Approximate error estimates for right eigenvectors of (A,B)
       9.5E-15    8.6E-15    5.6E-15    1.1E-14


library(networktools)

load('demo/parl_proceedings_ordered_words.rdata')

## fun-time in progress: using windowed adjacency to look at co-occurence of words in a given word distance.
## In this specific demo we look at consequtive POS tags

## In what percentage of the occurence of a POS tag did it occur directly after the other POS tag?
g = windowed.adjacency(list(lemma=tokens$pos1), tokens$id, list(aid=tokens$aid, sentence=tokens$sentence), window.size=2, as.graph=T, count.once=T, direction='down')

V(g)$label = as.character(V(g)$lemma)
V(g)$size = sqrt(V(g)$n)
V(g)$size=0
V(g)$label.cex=2
E(g)$arrow.size = 0.5
V(g)$label.color='black'
g$layout = layout.fruchterman.reingold
E(g)$label = round(E(g)$average.YX,2)

graph.plot(g, edge.weight=E(g)$average.YX, min.edge=0.2)
# In 80% of the times M occured, it occured directly after D

### conditional probability
g = windowed.adjacency(list(lemma=d$author), d$order.nr, d$conversation, window.size=2, as.graph=T, count.once=T, direction='down')

g = windowed.adjacency(list(lemma=tokens$pos1), tokens$id, list(aid=tokens$aid, sentence=tokens$sentence), window.size=2, as.graph=T, count.once=T, direction='down')

V(g)$label = as.character(V(g)$lemma)
V(g)$size = sqrt(V(g)$n)
V(g)$size=0
V(g)$label.cex=2
E(g)$arrow.size = 0.5
V(g)$label.color='black'
g$layout = layout.fruchterman.reingold
E(g)$label = round(E(g)$average.XY,2)

graph.plot(g, edge.weight=E(g)$average.XY, min.edge=0.2)
# In 80% of the times Q occured, N occured right after

# to what extent can communities be identified based on a comparison of a POS network structure?
# the difference between:
# We must destroy the Sith
# Destroy the Sith we must


 DPPRFS Example Program Results

 Solution(s)
             1          2
 1      1.0000     4.0000
 2     -1.0000     3.0000
 3      2.0000     2.0000
 4     -3.0000     1.0000

 Backward errors (machine-dependent)
       5.1E-17    6.1E-17
 Estimated forward error bounds (machine-dependent)
       2.3E-14    2.3E-14


   #Simulate Observations in this PCF category
    simulateObs = function(desired_mean, desired_sd, n, I, emperical_dist = FALSE){
        #Simulate outcomes from normal distribution (if emperical_dist == FALSE)
        # or from a transformation of the vector given by emperical_dist (if given)
        #desired_mean - desired output mean
        # desired_sd - desired output_sd
        #n - number of individuals
        #I - number of MC iterations
        #emeperical_dist - FALSE, or a vector of observations
        if (!is.numeric(emperical_dist)){
            matrix( rnorm(n * I, desired_mean, desired_sd),
                      nrow = n, ncol = I)
        } else{ #if emperical_dist == TRUE, standardize the observations
			stopifnot(is.numeric(emperical_dist))
			emperical_standardized = scale(emperical_dist)
			sampled_standardized = sample(emperical_standardized, n * I, replace = TRUE)
			matrix((sampled_standardized * desired_sd) + desired_mean, nrow = n, ncol = I)
		}
    }

simulateDesignBased = function(outcome_vec, pcf_vec, iters = 10,
		min_p = 0.01, max_p = 0.99){

	N = length(outcome_vec)

	pcf_vec = as.factor(pcf_vec)

	cat_probs = sapply(levels(pcf_vec),
			function(level) mean(outcome_vec[pcf_vec == level]))
	cat_probs[cat_probs == 1] = max_p
	cat_probs[cat_probs == 0] = min_p

	prob_vec = pcf_vec
	levels(prob_vec) = cat_probs
	prob_vec = as.numeric(as.character(prob_vec))

	null_mat = matrix(NA, nrow = N, ncol = iters)

	#Generate in a loop
	for (i in 1:iters){
	  null_mat[ ,i] = rbinom(N, 1, prob_vec)
	}
		return(list(data = null_mat, prob = prob_vec))
}

generateNullData = function(outcome_vec, pcf_vec, iters = 10,
	emperical_dist = FALSE){
  #Generate Null data for a continious outcome vec
  #COULD generate in parallel, but takes so little time it doesn't seem worth it
  #Only worth if we want to avoid storing the minimal data!
  #TODO - this is where we will change the function to simulate from the
  # emperical distribution

  stopifnot(length(outcome_vec) == length(pcf_vec))

  #Extract variables
  pcf_vec = as.factor(pcf_vec)
  sd_grand = sd(outcome_vec)
  N = length(outcome_vec)

  #Set up storage
  n_vec = mean_vec = sd_vec = NULL
  simulated_mat = matrix(NA, nrow = N, ncol = iters)

  for (cat in levels(pcf_vec)){#Loop over PCF categories
    indices = pcf_vec == cat

    #COmpute summary statistics
    m = mean(outcome_vec[indices])
    s = sd(outcome_vec[indices])
    n = sum(indices)
    if (is.na(s)){s = sd_grand}

    #Simulate observations
    data_temp = simulateObs(m, s, n, iters, emperical_dist)

    #Append summary statistics and data
    n_vec = c(n_vec, n)
    mean_vec = c(mean_vec, m)
    sd_vec = c(sd_vec, s)

    simulated_mat[indices, ] = data_temp
  }
  return( list(
    data = simulated_mat,
    n = n_vec,
    m = mean_vec,
    s = sd_vec
  ))
}

##Test computeNullBlock (TODO test against designBasedCont)
computeNullBlock = function(simulated_data, pcf_vec, inst_vec, gamma_vec, fun = designBasedContNull){
  #simulated_data <N x iters>
  #inst_vec <N x 1>: p institutions
  #pcf_vec <N x 1>

  iters = dim(simulated_data)[2]

  out_array = NULL
  for (i in 1:iters){
    out_array = abind::abind(out_array,
                      fun(gamma_vec, simulated_data[ ,i], pcf_vec, inst_vec),
                      along = 3)
  }
  return(out_array)
  #Returns array <P x n_gamma x iters)
}


suppressMessages(library(stats))
suppressMessages(library(craze))

if (fml_mpi()){
  comm.set.seed(1234)
} else {
  set.seed(1234)
}

n = 5
x = crossprod(matrix(runif(n*n), n))
y = matrix(1.0:5.0, n, 1)
x_fml = fmlmat(x)
y_fml = fmlmat(y)

test = as.matrix(solve(x_fml, y_fml))
truth = solve(x, y)
stopifnot(all.equal(test, truth))

### R's, but not fmlr/craze's solve() is having issues, possibly with openblas?
# test = as.matrix(solve(x_fml))
# truth = solve(x)
# stopifnot(all.equal(test, truth))


# Current method

# TODO Consider implementing this from scratch so that you know the details
# It should be straightforward, see here: https://bookdown.org/egarpor/NP-UC3M/kre-i-kre.html
# Using kernsmooth currently because I expect their implementation is faster and more robust

# The following functions contains Kernsmooth and ROT estimators.  ROT is selected currently

# Returns Lambda, or P(+|S=t)
EstLambda = function(S, X, t, idx, h = NULL){

  tryCatch({
    Sorder <- order(S, decreasing=TRUE)
    m <- length(S)
    idx.range <- c(max(1, idx - 1000), min(length(S), idx + 1000))

    S.ordered <- S[Sorder][idx.range[1]:idx.range[2]]
    X.ordered <- X[Sorder][idx.range[1]:idx.range[2]]

    ## --1 Kernsmooth bandwidth estimator
    ## more accurate, but prone to errors
    # if(is.null(h)) h <- KernSmooth::dpill(x = S.ordered, y = X.ordered, gridsize = 100)

    ## --2 Rule of thumb estimator
    ## Should not throw an error
    if(is.null(h)) h <- (m^{-1/5}) * sd(S)

    lp0 <- KernSmooth::locpoly(x = S.ordered, y = X.ordered, bandwidth = h, degree = 0,
                               range.x = range(S.ordered), gridsize = 1000)

    lp0.idx <- which.min(abs(lp0$x - t))
    lam <- lp0$y[lp0.idx]
  }, error = function(e) {
    stop("Lambda estimate failed.  Try setting h manually.")
  }
  )

  return(lam)
}

# --3 JHO
#
# # Returns Lambda, or P(+|S=t)
# EstLambda = function(S, X, t, ...){
#  #h is the bandwidth, t is called c in the JZ paper
#  #m is the sample size, S and X are the vectors of scores and labels
#  m <- length(S)
#  h <- (m^{-1/5}) * sd(S)
#  ind.win <- (S < t + h) & (S > t - h)
#  exp.X.and.I <- sum(X*ind.win)/m
#  exp.I <- sum(ind.win)/m
#  return(exp.X.and.I/exp.I)
# }

# --4 np method

# # Returns Lambda, or P(+|S=t)
# EstLambda = function(S, X, t, idx, Sorder, h = NULL){
#
#   idx.range <- c(max(1, idx - 100), min(length(S), idx + 100))
#
#   S.ordered <- S[Sorder][idx.range[1]:idx.range[2]]
#   X.ordered <- X[Sorder][idx.range[1]:idx.range[2]]
#
#   # TODO This is still not silent!
#   if(is.null(h)) {
#     bwa <- invisible(np::npregbw(formula = X.ordered ~ S.ordered, bwtype = "adaptive_nn",
#                                  regtype = "lc"))
#   } else {
#     bwa <- invisible(np::npregbw(formula = X.ordered ~ S.ordered, bws = h,
#                                  regtype = "lc"))
#   }
#   np.model <- invisible(np::npreg(bwa))
#
#   return(predict(np.model, newdata = data.frame(S.ordered = t)))
# }

# --5 JZ original method
#
# Returns Lambda, or P(+|S=t)
# EstLambda = function(S, X, t, ...){
#  #h is the bandwidth, t is called c in the JZ paper
#  #m is the sample size, S and X are the vectors of scores and labels
#  m <- length(S)
#  h <- (m^{-1/5})
#  ind.win <- (S < t + h) & (S > t - h)
#  exp.X.and.I <- sum(X*ind.win)/m
#  exp.I <- sum(ind.win)/m
#  return(exp.X.and.I/exp.I)
# }

# Bootstrap percentile CI
BootCI = function(X, S, m, pi.0, boot.rep, metric, plus, r, myseed=111){
  storeout=matrix(NA, nrow=m, ncol=1+boot.rep)
  r.all <- (1:m)/m
  idx <- which(r.all %in% r)
  storeout <- storeout[idx, ]
  storeout[,1] <- r
  set.seed(myseed)
  for(i in 1:boot.rep){
    boot.samp <- sample(1:m, m, replace = T)
    X.star = X[boot.samp]
    S.star = S[boot.samp]
    Sorder <-  order(S.star,decreasing=TRUE)
    hits <- cumsum(X.star[Sorder])[idx]
    pi.0 <- mean(X.star)
    pi <- (hits)/(m*r)
    k <- (hits)/(sum(X.star))
    if (plus) {
      # using random plus correction
      plus.yes <- rbinom(1, 4, .5)
      pi <- (hits+plus.yes)/(m*r+4)
      k <- r/pi.0*pi
    }
    if(metric == "rec") {
      storeout[,1+i] = k
    } else if(metric == "prec") {
      storeout[,1+i] = pi
    } else if(metric == "lift") {
      storeout[,1+i] = k/r
    }
    # print(i/boot.rep)
  }
  A = apply(storeout[,-1],MARGIN=1,FUN=function(x){quantile(x, probs = c(.025, .975))})
  # Returns 95% percentile bootstrap intervals at quantiles
  A=t(A)
}

#' Construct a confidence band for a recall or precision curve
#'
#' \code{PerfCurveBands} takes a pair of score and activity vectors as input.
#' A performance curve and confidence band is created for the selected testing fractions.
#'
#' @param S a vector of scores.
#' @param X a vector of activities.
#' @param r a vector of testing fractions.
#' @param metric the performance curve to use. Options are recall ("rec") and precision ("prec").
#' @param type specifies whether a point-wise confidence interval
#' ("pointwise") or a confidence band ("band") should be constructed.
#' @param method the method to use. Point-wise confidence interval options
#' are "binomial", "JZ", "bootstrap". Confidence band options are "sup-t", "theta-proj".
#' @param plus should plus correction be used or not?
#' @param conf.level the confidence level for the bands.
#' @param boot.rep the number of replicates to use for the bootstrap method.
#' @param mc.rep the number of Monte Carlo replicates to use for the sup-t method.
#' @param myseed the random seed.
#'
#' @export
PerfCurveBands <- function(S, X, r, metric = "rec", type = "band", method = "sup-t",
                           plus = T, conf.level = .95, boot.rep = 100,
                           mc.rep = 100000, myseed = 111, h = NULL){

  # TODO add support for EF

  # Some error handeling

  if (!(method %in% c("binomial", "JZ", "bootstrap", "sup-t", "theta-proj", "bonf"))) {
    stop("'method' should be a string specifiying a performance curve method in chemmodlab.
         Point-wise confidence interval options are 'binomial', 'JZ', 'bootstrap'. Confidence band options
         are 'sup-t', 'theta-proj'.")
  }

  if (!(metric %in% c("rec", "prec"))) {
    stop("'metric' should be a string specifiying a performance curve metric in chemmodlab.
         Point-wise confidence interval options are 'binomial', 'JZ', 'bootstrap'. Options
         are recall ('rec') and precision ('prec').")
  }

  if (!(type %in% c("band", "pointwise"))) {
    stop("'type' should be a string specifiying a performance curve type in chemmodlab.
         Point-wise confidence interval options are 'binomial', 'JZ', 'bootstrap'. Options
         are point-wise confidence interval ('pointwise') or a confidence band ('band').")
  }

  set.seed(myseed)
  alpha <- 1-conf.level
  m <- length(S) #total sample size
  nact <- sum(X)  #total number of actives
  ntest <- m*r #total number tested
  r.all <- (1:m)/m
  idx <- which(r.all %in% r)

  # Convert fractions in r to thresholds, for both sets of scores
  # Also accumulate the number of actives, for each score and jointly
  Fcdf <- ecdf(S); yyobs <- sort(unique(S))
  Finv <- stepfun(x = Fcdf(yyobs), y = c(yyobs, max(yyobs)), right=TRUE, f=1)
  hits <- vector(length = length(r))
  t <- vector(length = length(r))
  for(i in 1:length(r)) {
    t[i] <- Finv(1-r[i])
    hits[i] <- sum(X*(S > t[i]))
  }

  Lam.vec <- vector(length = length(idx))
  for(j in seq_along(idx)){
    Lam.vec[j] <- EstLambda(S, X, t = t[j], idx = idx[j], h)
  }

  pi <- (hits)/(m*r)
  k <- hits/nact

  # Plus 2 correction
  if (plus) {
    hits <- hits + 2
    nact <- nact + 4
    ntest <- ntest + 2
    m <- m + 4
  }

  pi.0 <- nact/m
  r <- ntest/m
  k.c <- hits/nact
  pi.c <- pi.0/r*k.c
  k.ide <- (cumsum(rev(sort(X)))[idx]/sum(X))

  CI.int <- matrix(ncol = 2, nrow = length(k))
  if(type == "pointwise") {

    # Z Quantile for CIs
    quant <- qnorm(1-alpha/2)

    if(metric == "rec") {
      if(method == "JZ"){
        for(j in seq_along(k)) {
          Lam <- Lam.vec[j]
          var.k <- ((k.c[j]*(1-k.c[j]))/(m*pi.0))*(1-2*Lam) +
            (Lam^2*(1-r[j])*r[j])/(m*pi.0^2)
          # Check to see if var.k is negative due to machine precision problem
          var.k <- ifelse(var.k < 0, 0, var.k)
          sd.k <- sqrt(var.k)
          lcl <- k.c[j] - quant*sd.k
          lcl <- ifelse(lcl < 0, 0, lcl)
          ucl <- k.c[j] + quant*sd.k
          ucl <- ifelse(ucl > k.ide[j], k.ide[j], ucl)
          CI.int[j, ] <- c(lcl, ucl)
        }
      } else if(method == "bootstrap") {
        # bootstrap quantiles
        CI.int <- BootCI(X, S, m, pi.0, boot.rep, metric = "rec", plus, r, myseed=myseed)
        CI.int[, 1] <- ifelse(CI.int[, 1] < 0, 0, CI.int[, 1])
        CI.int[, 2] <- ifelse(CI.int[, 2] > k.ide, k.ide, CI.int[, 2])
      } else if(method == "binomial") {
        for(j in seq_along(k)) {
          var.k <- ((m*pi.0)^-1)*k.c[j]*(1-k.c[j])
          var.k <- ifelse(var.k < 0, 0, var.k)
          sd.k <- sqrt(var.k)
          lcl <- k.c[j] - quant*sd.k
          lcl <- ifelse(lcl < 0, 0, lcl)
          ucl <- k.c[j] + quant*sd.k
          # TODO consider removing due to coverage issues
          ucl <- ifelse(ucl > k.ide[j], k.ide[j], ucl)
          CI.int[j, ] <- c(lcl, ucl)
        }
      }
    } else if(metric == "prec") {
      if(method == "JZ") {
        for(j in seq_along(k)) {
          Lam <- Lam.vec[j]
          var.pi <- (pi.c[j]*(1-pi.c[j]))/(m*r[j]) +
            (1-r[j])*(pi.c[j]-Lam)^2/(m*r[j])
          # Check to see if var.pi is negative due to machine precision issues
          var.pi <- ifelse(var.pi < 0, 0, var.pi)
          sd.pi <- sqrt(var.pi)
          lcl <- pi.c[j] - quant*sd.pi
          lcl <- ifelse(lcl < 0, 0, lcl)
          ucl <- pi.c[j] + quant*sd.pi
          ucl <- ifelse(ucl > 1, 1, ucl)
          CI.int[j, ] <- c(lcl, ucl)
        }
      } else if(method == "bootstrap") {
        # bootstrap quantiles
        CI.int <- BootCI(X, S, m, pi.0, boot.rep, metric = "prec", plus, r, myseed=myseed)
        CI.int[, 1] <- ifelse(CI.int[, 1] < 0, 0, CI.int[, 1])
        CI.int[, 2] <- ifelse(CI.int[, 2] > 1, 1, CI.int[, 2])
      } else if(method == "binomial") {
        for(j in seq_along(pi)) {
          var.pi <- ((m*r[j])^-1)*pi.c[j]*(1-pi.c[j])
          # Check to see if var.pi is negative due to machine precision issues
          var.pi <- ifelse(var.pi < 0, 0, var.pi)
          sd.pi <- sqrt(var.pi)
          lcl <- pi.c[j] - quant*sd.pi
          lcl <- ifelse(lcl < 0, 0, lcl)
          ucl <- pi.c[j] + quant*sd.pi
          ucl <- ifelse(ucl > 1, 1, ucl)
          CI.int[j, ] <- c(lcl, ucl)
        }
      }
    }
  } else if(type == "band") {
    if(metric == "rec") {
      if(method == "sup-t") {
        cor.C <- matrix(NA, ncol = length(k), nrow = length(k))
        for(f in seq_along(k)) {
          for(e in 1:f) {
            Lam1 <- Lam.vec[e]
            var.k1 <- (((k.c[e]*(1-k.c[e]))/(m*pi.0))*(1-2*Lam1) +
                         (Lam1^2*(1-r[e])*r[e])/(m*pi.0^2))
            var.k1 <- ifelse(var.k1 < 0, 0, var.k1)
            Lam2 <- Lam.vec[f]
            var.k2 <- (((k.c[f]*(1-k.c[f]))/(m*pi.0))*(1-2*Lam2) +
                         (Lam2^2*(1-r[f])*r[f])/(m*pi.0^2))
            var.k2 <- ifelse(var.k2 < 0, 0, var.k2)
            cov.k <- ((m^-1*pi.0^-2)*(pi.0*(k.c[e]-k.c[e]*k.c[f])*(1-Lam1-Lam2) +
                                        (r[e]-r[e]*r[f])*Lam1*Lam2))
            if(e == f) {
              # If the covariance serves as a variance then it cant be non-negative
              # otherwise, it can be negative
              cov.k <- ifelse(cov.k < 0, 0, cov.k)
            }
            cor.k <- cov.k/(sqrt(var.k1)*sqrt(var.k2))
            cor.k <- ifelse(var.k1 == 0 | var.k2 == 0, ifelse(e == f, 1, 0), cor.k)
            cor.C[e, f] <- cor.k
            cor.C[f, e] <- cor.k
          }
        }
        mc.samples <- MASS::mvrnorm(n = mc.rep, rep(0, length = length(k)), cor.C, tol = 1)
        max.q <- vector(length = mc.rep)
        for(j in 1:mc.rep) {
          max.q[j] <- max(abs(mc.samples[j, ]))
        }
        # Should be 1-alpha, see Montiel Olea and Plagborg-Møller
        quant <- quantile(max.q, probs = 1-alpha)
      } else if(method == "theta-proj") {
        quant <- sqrt(qchisq(1-alpha, length(k)))
      } else if(method == "bonf") {
        quant <- qnorm(1-alpha/(2*length(k)))
      } else {
        stop("Invalid method selected")
      }
      for(j in seq_along(k)) {
        Lam <- Lam.vec[j]
        var.k <- ((k.c[j]*(1-k.c[j]))/(m*pi.0))*(1-2*Lam) +
          (Lam^2*(1-r[j])*r[j])/(m*pi.0^2)
        # Check to see if var.k is negative due to machine precision problem
        var.k <- ifelse(var.k < 0, 0, var.k)
        sd.k <- sqrt(var.k)
        lcl <- k.c[j] - quant*sd.k
        lcl <- ifelse(lcl < 0, 0, lcl)
        ucl <- k.c[j] + quant*sd.k
        ucl <- ifelse(ucl > k.ide[j], k.ide[j], ucl)
        CI.int[j, ] <- c(lcl, ucl)
      }
    } else if(metric == "prec") {
      if(method == "sup-t") {
        cor.C <- matrix(NA, ncol = length(k), nrow = length(k))
        for(f in seq_along(pi)) {
          for(e in 1:f) {
            Lam1 <- Lam.vec[e]
            var.pi1 <- (pi.c[e]*(1-pi.c[e]))/(m*r[e]) +
              (1-r[e])*(pi.c[e]-Lam1)^2/(m*r[e])
            var.pi1 <- ifelse(var.pi1 < 0, 0, var.pi1)
            Lam2 <- Lam.vec[f]
            var.pi2 <- (pi.c[f]*(1-pi.c[f]))/(m*r[f]) +
              (1-r[f])*(pi.c[f]-Lam2)^2/(m*r[f])
            var.pi2 <- ifelse(var.pi2 < 0, 0, var.pi2)
            cov.pi <- (((m*r[e]*r[f])^{-1})*(r[e]*pi.c[e]*(1 - pi.c[e]) +
                                               (pi.c[e]-Lam1)*(pi.c[e]-Lam2)*(r[e] - r[e]*r[f])))
            if(e == f) {
              # If the covariance serves as a variance then it cant be non-negative
              # otherwise, it can be negative
              cov.pi <- ifelse(cov.pi < 0, 0, cov.pi)
            }
            cor.pi <- cov.pi/(sqrt(var.pi1)*sqrt(var.pi2))
            cor.pi <- ifelse(var.pi1 == 0 | var.pi2 == 0, ifelse(e == f, 1, 0), cor.pi)
            cor.C[e, f] <- cor.pi
            cor.C[f, e] <- cor.pi
          }
        }
        mc.samples <- MASS::mvrnorm(n = mc.rep, rep(0, length = length(k)), cor.C, tol = 1)
        max.q <- vector(length = mc.rep)
        for(j in 1:mc.rep) {
          max.q[j] <- max(abs(mc.samples[j, ]))
        }
        quant <- quantile(max.q, probs = 1-alpha)
      } else if(method == "theta-proj") {
        quant <- sqrt(qchisq(1-alpha, length(pi)))
      } else if(method == "bonf") {
        quant <- qnorm(1-alpha/(2*length(k)))
      } else {
        stop("Invalid method selected")
      }
      for(j in seq_along(pi)) {
        Lam <- Lam.vec[j]
        var.pi <- (pi.c[j]*(1-pi.c[j]))/(m*r[j]) + (1-r[j])*(pi.c[j]-Lam)^2/(m*r[j])
        # Check to see if var.k is negative due to machine precision problem
        var.pi <- ifelse(var.pi < 0, 0, var.pi)
        sd.pi <- sqrt(var.pi)
        lcl <- pi.c[j] - quant*sd.pi
        lcl <- ifelse(lcl < 0, 0, lcl)
        ucl <- pi.c[j] + quant*sd.pi
        ucl <- ifelse(ucl > 1, 1, ucl)
        CI.int[j, ] <- c(lcl, ucl)
      }
    }
  }

  list(CI = CI.int, rec = k, prec = pi, h = h)

  }


install.packages("swirl")
library("swirl")
ls()
rm(list=ls())
ls()
swirl()
5 + 7
x <- 5+7
x
y <- x - 3
y
z <- c(1.1,9,3.14)
?c
z
c(z, 555, z)
z*2 +100
my_sqrt <- sqrt(z -1)
my_sqrt
my_div <- z/my_sqrt
my_deiv
my_div
c(1,2,3,4 ) + c(0,10)
c(1,2,3,4)+ c(0,10,100)
z*2 +1000
my_div
swirl()
1:20
pi:10
15:1
?`:`
sec(1,20)
seq(1,20)
seq(0,10,by=0.5)
seq(0,10,length=30)
my_seq = seq(0,10,length=30)
my_seq <- seq(0,10,length=30)
my_seq <- seq(5,10,length=30)
length(my_seq)
1:length(my_seq)
seq(along.with = my_seq)
seq_along(my_seq)
rep(0, times = 40)
rep(c(0,1,2), times=10)
rep(c(0,1,2), each = 10)
num_vect <- c(0.5,55,-10,6)
tf <- num_vect < 1
tf
num_vect >=6
my_char <-c("My", "name", "is")
my_char
paste(my_char, collapse= " ")
my_name <- c(my_char, "cesine")
my_name
paste(my_name, collapse= " ")
paste("Hello", "world!", sep=" ")
paste(1:3, c("X", "Y", "Z"), sep = "")
paste(LETTERS, 1:4, sep = "-")
x <- c(44, NA, 5, NA)
x * 3
y <- rnorm(1000)
z <- rep(NA, 1000)
my_data <- sample(c(y,z), 100)
my_na <- is.na(my_data)
my_na
play()
my_data
nxt()
my_data == NA
sum(my_na)
my_data
0/0
Inf-Inf


score <- function(input) {
    if ((input[6]) <= (6.941)) {
        if ((input[13]) <= (14.4)) {
            if ((input[8]) <= (1.38485)) {
                var0 <- 45.58
            } else {
                var0 <- 22.939004149377574
            }
        } else {
            var0 <- 14.910404624277467
        }
    } else {
        if ((input[6]) <= (7.4370003)) {
            var0 <- 32.11304347826088
        } else {
            var0 <- 45.096666666666664
        }
    }
    return(var0)
}


#install packages
#install.packages("maptools")
#install.packages("rgeos")
#install.packages("spatstat")

#load packages
library(maptools)
library(spatstat)

#number of simulations
nSim <- 99

#number of observed points
nPts <- 10000
minT <- minimum observed temporal coordinate
maxT <- maximum observed temporal coordinate

#initialize matrix
mat1 <- matrix(nrow = 0, ncol =4)
mat2 <- matrix(nrow = 0, ncol =4)

#coordinate reference system
crs1 <- CRS([spatial reference information])

#boundary polygon
bds <- readShapePoly([boundary of study area], proj4string=crs1)

#observed points
obs <- read.table([array of data points])

#-----------------------------------------------------------------------------------------------------------------------------------------------------
#CSR with a temporal trend: randomize cases for each day. Timestamps are directly taken from original dataset. In other words: the temporal intensity of the point process is dictated by the original dengue fever dataset.
for (simNum in 0:nSim) {
pts1 <- rpoint(nPts, win = bds)
tempMat1 <- cbind(pts$x,pts$y,dengue$V3,replicate(nPts,simNum))
mat1 <- rbind(mat1,tempMat1)
}
write.table(mat1, paste("sim_CSR_tTrend.txt", sep = ","))
#-----------------------------------------------------------------------------------------------------------------------------------------------------

#-----------------------------------------------------------------------------------------------------------------------------------------------------
#CSTR
for (simNum in 0:nSim) {
  pts2 <- rpoint(nPts, win = bds)
  tempMat2 <- cbind(pts$x,pts$y,sample(minT:maxT,nPts,replace=T),replicate(nPts,simNum))
  mat2 <- rbind(mat2,tempMat2)
}
write.table(mat2, paste("sim_CSTR.txt", sep = ","))
#-----------------------------------------------------------------------------------------------------------------------------------------------------


#' Results of dealing a hand of cards
#'
#' @param n.iter The number of iterations in the monte carlo simulation (integer > 0)
#' @param hand.size The number of cards in each hand (shuffling would be \code{hand.size = 52})
#' @param parallel Should the simulation take advantage of multiple cores (defaults to \code{TRUE} -
#'   highly recommended if \code{n.iter > 1e5})
#' @return A list with \code{n.iter} elements. Each element is a data frame of
#'   size \code{hand.size x 3}.
#' @export
#'
deal.cards = function(n.iter = 1e5, hand.size = 5, parallel = TRUE) {
  stopifnot(n.iter %% 1 == 0 & n.iter > 0)
  stopifnot(hand.size %% 1 == 0 & hand.size > 0)
  suits <- c("Diamonds", "Clubs", "Hearts", "Spades")
  cards <- c("Ace", "Deuce", "Three", "Four","Five", "Six", "Seven", "Eight", "Nine", "Ten", "Jack", "Queen", "King")
  values <- c(0, 2:9, rep(10, 4))
  totalNumOfDecks <- 1
  deck <- expand.grid(cards=cards, suits=suits)
  deck$value <- values
  if(!parallel) {
    results = lapply(seq_len(n.iter), FUN = function(i) {
      deck[sample(1:52, size = hand.size, replace = FALSE),]
    })
  } else {
    results = mclapply(seq_len(n.iter), FUN = function(i) {
      deck[sample(1:52, size = hand.size, replace = FALSE),]
    })
  }
  return(results)
}


##
## http://stackoverflow.com/a/21221995/951174
##
confint.gee <- function(object, parm, level = 0.95, ...) {
  cc <- coef(summary(object))
  mult <- qnorm((1+level)/2)
  cc.d <- as.data.frame(cc)
  est <- cc.d$Estimate
  se <- cc.d$"Robust S.E"
  citab <- cbind(lwr=est-mult*se, upr=est+mult*se)
  rownames(citab) <- rownames(cc)
  citab[parm,]
}
confint.geeglm <- function(object, parm, level = 0.95, ...) {
  cc <- coef(summary(object))
  mult <- qnorm((1+level)/2)
  cc.d <- as.data.frame(cc)
  est <- cc.d$Estimate
  se <- cc.d$"Std.err"  #"Robust S.E"
  citab <- cbind(lwr=est-mult*se, upr=est+mult*se)
  rownames(citab) <- rownames(cc)
  #citab[parm,]
  citab
}
# get CIs of standardized GEE model
confint.geeglm.z <- function(object, parm, level = 0.95, ...) {
  cc <- coef(summary(object))
  mult <- qnorm((1+level)/2)
  cc.d <- as.data.frame(cc)
  est <- cc.d$Estimate
  se <- cc.d$"Std.err"
  citab <- cbind(lwr=est-mult*se, upr=est+mult*se)
  #citab <- with(as.data.frame(cc),
  #              cbind(lwr=Estimate-mult*"Robust S.E",
  #                    upr=Estimate+mult*"Robust S.E"))
  rownames(citab) <- rownames(cc)
  citab[parm,]
}

#or_ci = function(x) round(cbind(exp(summary(x)$coef), exp(confint.geeglm(x))), 2)[, c(1,6:7)]  # gee version
#or_ci = function(x, d=3) round(cbind(exp(summary(x)$coef), exp(confint.geeglm(x))), d)[, c(1,5:6)]  # geepack version
#or_ci.z = function(x, d=3) round(cbind(exp(summary(x)$coef), exp(confint.geeglm.z(x))), d)[, c(1,5:6)]

or_ci = function(x, d=3)
{
  est = data.frame( Estimate=round(exp(coef(x)), d) )  # calculate OR for param estimate
  est = cbind( est, round(exp(confint.geeglm(x)), d) )  # append CIs

  est = cbind(Parameter=rownames(est), est)  # convert row names into a 'Parameter' variable
  rownames(est) = NULL  # remove row names
  return(est)
}


# Simon attempt to add DEM data to DairyBase file using rsaga

# raster package can work with data on disk (doesn't need to be in memory)
# library(rgdal) # base spatial data package
library(raster) # see http://neondataskills.org/R/Raster-Data-In-R/
library(RSAGA) # http://www.saga-gis.org/en/index.html
# library(maptools)

# define coordinate systems
# http://spatialreference.org
# WGS84 - World Geodetic System 1984 - Commonly used datum. Changes with time.
# NZGD2000 - NZ Geodetic Datum 2000 - very close to WGS84. Static with time. Generally assumed = WGS84.
# NZMG = NZGD1949 - origin 41S 173E - obsolete
# NZTM2000 - NZ Tranverse Mercator - replaced NZMG - origin 0S 173E
nztm2000string <- "+proj=tmerc +lat_0=0 +lon_0=173 +k=0.9996 +x_0=1600000 +y_0=10000000 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
wgs84string <- "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"

# get some data to play with
# https://data.linz.govt.nz/group/national-elevation/data/tag/land-geodesy/global/oceania/new-zealand/?s=r&v=csv
# Actually got data from ASTER
# see also getData("alt", country='NZL')

# raster package for handling grided data
aster_dem <- "dem\\ASTGTM2_S38E175\\ASTGTM2_S38E175_dem.tif" # Hamilton-Hauraki Area, 25Mb (WGS84 longlat)
DEM <- raster(aster_dem)
projection(DEM) # it's in wgs84 (longlat)
plot(DEM, main="Hamilton-Hauraki DEM (wgs84)")

# change projection ?
# https://www.rdocumentation.org/packages/raster/versions/1.0.0-1/topics/projectRaster
new_aster_dem <- "dem\\ASTGTM2_S38E175\\ASTGTM2_S38E175_new_dem.tif"
new_DEM <- projectExtent(DEM, nztm2000string)
res(DEM)
res(new_DEM)
res(new_DEM) <- 50 # metres per cell ? affects memory requirement
new_DEM <- projectRaster(from=DEM, to=new_DEM)
plot(new_DEM, main="Hamilton-Hauraki DEM (nztm2000)")
writeRaster(new_DEM, new_aster_dem, overwrite=TRUE)

# RSAGA
# https://www.r-bloggers.com/rsaga-getting-started/
# http://gracilis.carleton.ca/CUOSGwiki/index.php/Introducing_Geoprocessing_Capabilities_of_SAGA_in_R_Environment_using_RSAGA_(Saga_%2B_Rstudio)
# https://gis.stackexchange.com/questions/175791/strange-output-from-rsaga-topographic-wetness-index
# had to put saga_2.2.3_x64/ in C:/Users/WoodwardS/Documents/R/win-library/3.4/RSAGA/SAGA-GIS

# import as SAGA files (writes set of 5 files)
work_env <- rsaga.env()
saga_dem <- "dem\\ASTGTM2_S38E175\\ASTGTM2_S38E175_dem"
rsaga.import.gdal(in.grid=new_aster_dem, out.grid=saga_dem, env=work_env) # use this instead

# how to explore SAGA functionality
# rsaga.get.libraries() # what's available ?
# rsaga.get.modules("grid_filter") # what's available ?
# rsaga.get.usage('grid_filter', 7) # how do you use it ?

# calculate slope of DEM as SAGA files (set of 5 files)
saga_slope <- "dem\\ASTGTM2_S38E175\\ASTGTM2_S38E175_slope"
rsaga.slope(in.dem=saga_dem, out.slope=saga_slope, env=work_env)
slope <- raster(paste(saga_slope, ".sdat", sep="")) # read SAGA files as raster for plotting
projection(slope)
plot(slope, main="Hamilton Hauraki Slope")

# calculate slope of DEM as SAGA files (set of 5 files)
saga_wetness <- "dem\\ASTGTM2_S38E175\\ASTGTM2_S38E175_wetness"
rsaga.wetness.index(in.dem=saga_dem, out.wetness.index=saga_wetness, env=work_env) # slow!!!
wetness <- raster(paste(saga_wetness, ".sdat", sep=""))
projection(wetness)
plot(wetness, main="Hamilton Hauraki Wetness") # possibly makes more sense on small scale.


rank.decreasing <- function(x) length(x) + 1 - rank(x,ties.method="first")

buildInteractions <- function(M,B,D,net_genes,net_regulators,GIDS,RIDS,cutoff)
{
	M.rank <- matrix(rank.decreasing(M),nrow=dim(M)[1],ncol=dim(M)[2])
	net_genes.indx <- match(net_genes,GIDS)
	net_regulators.indx <- match(net_regulators,RIDS)
	interactions <- c()
	for (rindx in net_regulators.indx)
	{
		tindx <- which(M[rindx,]>cutoff)
		tindx <- intersect(tindx,net_genes.indx)
		if (length(tindx)>0)
		{
			interactions <- rbind(interactions,cbind(rep(RIDS[rindx],times=length(tindx)),GIDS[tindx],M[rindx,tindx],sign(D[rindx,tindx]),sign(B[rindx,tindx]),(sign(D[rindx,tindx])+sign(B[rindx,tindx]))/2,M.rank[rindx,tindx]))
		}
	}

	colnames(interactions) <- c("REGULATOR","TARGET","SCORE","DSIGN","BSIGN","CSIGN","RANK")
	interactions
}

M <- as.matrix(read.table(file.path(outputDirectory, combinedAdjMtrFileName)))
B <- as.matrix(read.table(file.path(outputDirectory, lassoAdjMtrFileName)))
D <- as.matrix(read.table(differentialExpressionMatrixFile))
RIDS <- as.matrix(read.table(regulatorGeneNamesFileName))
GIDS <- as.matrix(read.table(targetGeneNamesFileName))

interactions <- buildInteractions(M,B,D,GIDS,RIDS,GIDS,RIDS,0)
write.table(as.table(interactions),file=file.path(outputDirectory,combinedAdjLstFileName),row.names=FALSE,quote=FALSE,sep='\t')


#' Multiple variance Brownian motion estimation
#'
#' Computes rescaled branch lengths using multiple variance Brownian motion as described in Smaers et al. (2016)
#' @param data a vector of tip values for species; should be in the same order as tiplabels in the tree
#' @param tree an object of class "phylo".
#' @param sigma sig2 value from a Bayesian MCMC run using standard Brownian motion (e.g. ?anc.Bayes)
#' @return dataframe with rescaled branch lengths (rBL) for all branches in the tree
#' @references Smaers, Mongle & Kandler (2016) A multiple variance Brownian motion framework for estimating variable rates and inferring ancestral states. Biological Journal of the Linnean Society. 118 (1): 78-94.
#' @examples tree<-pbtree(n=50) # simulate tree ('pbtree' requires the 'phytools' package)
#' x<-fastBM(tree,sig2=2) # simulate values ('pbtree' requires the 'phytools' package)
#' BMsigma2<-ace(x,tree,method="REML")$sigma2[1] # get BM sigma2 ('ace' requires the 'ape' package)
#' mvBMresults<-mvBM(x,tree,BMsigma2) # calculate rescaled branch lengths using mvBM
#' tree_mvBM<-tree
#' tree_mvBM$edge.length<-mvBMresults$rBL # create new tree with rescaled branch lengths
#' plot(tree_mvBM) # plot mvBM tree
#' ace(x,tree_mvBM,method="REML") # get ancestral estimates using mvBM tree
#' # To obtain the mvBM branch specific rate estimate: calculate sig2 for the trait in question using the mvBM tree; multiply the mvBM sig2 with the mvBM rescaled branch length of the lineage of interest; divide this value by the phylogenetic branch length of the lineage of interest.
#' # MCMC posterior distributions can be obtained by using anc.Bayes for the above calculations. ('anc.Bayes' requires the 'phytools' package)
#' @examples for other examples see https://smaerslab.com/software/

#' @export
mvBM <- function (data, tree, sigma2)
{
    data_original <- data
    N = length(data)
    phy.matrix = data.frame(tree$edge, tree$edge.length, data[tree$edge[,
        2]])
    names(phy.matrix) = c("Anc", "Desc", "Length", "Value")
    nodes_extant = 1:N
    nodes_extinct = (N + 1):(N + (N - 1))
    extant_values <- data.frame(data, nodes_extant)
    Pk_values <- c()

    dist.tree <- dist.nodes(tree)

    for (j in nodes_extinct) {
        nominator = c()
        denominator = c()

        for (i in nodes_extant) {
            nominator = rbind(nominator, (extant_values[i, 1]/dist.tree[i,
                j]^2))
            denominator = rbind(denominator, (1/dist.tree[i,
                j]^2))
        }

        Pk = sum(nominator)/sum(denominator)
        Pk_values = rbind(Pk_values, Pk)
    }

    Pk <- c()
    Pk <- cbind(Pk, Pk_values)
    Pk <- cbind(Pk, nodes_extinct)
    colnames(Pk) <- c("value", "nodes")
    rownames(Pk) <- 1:length(nodes_extinct)
    Pk <- as.data.frame(Pk)
    nodes_extinct_reverse = sort(nodes_extinct, decreasing = TRUE)
    rBL <- c()
    rBL_edge <- c()
    for (i in nodes_extinct_reverse) {
        sister_branches <- which(phy.matrix$Anc == i)
        X1 <- phy.matrix$Value[sister_branches[1]]
        X2 <- phy.matrix$Value[sister_branches[2]]
        Y1 <- sqrt(phy.matrix$Length[sister_branches[1]])
        Y2 <- sqrt(phy.matrix$Length[sister_branches[2]])
        Pk_anc <- Pk$value[which(Pk$nodes == i)]
        Ax <- (Pk_anc + X1 + X2)/3
        T1 <- ((X1 - Ax)^2)/sigma2 + Y1^2
        T2 <- ((X2 - Ax)^2)/sigma2 + Y2^2
        phy.matrix$Value[which(phy.matrix$Desc == i)] <- Ax
        rBL <- c(rBL, T1)
        rBL <- c(rBL, T2)
        rBL_edge <- c(rBL_edge, sprintf("%05.f", sister_branches[1]))
        rBL_edge <- c(rBL_edge, sprintf("%05.f", sister_branches[2]))
        names(rBL) <- rBL_edge
    }
    Output <- data.frame(tree$edge, tree$edge.length, rBL[sort(names(rBL))])
    names(Output) <- c("node_anc", "node_desc", "BL", "rBL")
    return(Output)
}


#Model comparison and variable selection.
#We want to carve down the number of predictors we use to avoid overfitting our prior.
#To do this we propose a few model structures.
#1. intercept only.
#2. linear combination of all predictors.
#3. 'Expert' opinion (Colin's opinion...). Incorporating interactions based on biological hypotheses. We may test multiple models like this.
#We then perform backward selection on each of these model structures (well, nothing to select in the intercept only case.)
#Within a model structure the bakwards variable selection proceeds like this:
#Step 1. calculate model deviance.
#Step 2. Rerun the model without a particular predictor, calculate deviance. Do this for all predictors.
#Step 3. Drop the predictor that results in the largest improvement in deviance (apparently this is the greedy part of a greedy algorithm.)
#Step 4. Using our new best model, repeat Steps 2 and 3 until either:
#         (a.) deviance no longer improves, or
#         (b.) deviance does not improve beyond a threshold change (say 2 units).

#testing with pseudo data.
rm(list = ls())
library(runjags)
library(doParallel)
source('NEFI_functions/ddirch_site.level_JAGS.r')
source('NEFI_functions/crib_fun.r')
source('NEFI_functions/tic_toc.r')

#### generate pseudo data ####
n.obs <- 60
x1 <- runif(n.obs,20,40)
x2 <- runif(n.obs, 2, 4)
x3 <- runif(n.obs,100,110)
intercept <- rep(1,n.obs)
y <- x1*0.5 + x2*3 + rnorm(n.obs)
#get two species abundances
y1 <- y
y2 <- rep(10, length(y1))
spp.y <- data.frame(cbind(y1,y2))
spp.y <- spp.y / rowSums(spp.y)
x_mu <- data.frame(intercept,x1,x2,x3)

#### Fit first JAGS model to all covariates. ####
#register parallel cores
registerDoParallel(cores = detectCores())

#fit first model, calculate deviance.
tic()
fit <- site.level_dirlichet_jags(y = spp.y, x_mu = x_mu, adapt = 100, burnin = 100, sample = 200)
dev <- fit$deviance
donezo <- 0
loop.count <- 1
cat('Initial model fit complete.')
toc()
while(donezo < 1){
  #sequentially leave out one predictor, except intercept.
  tic()
  fit.list <- list()
  fit.list <-
  foreach(i = 2:ncol(x_mu)) %dopar% {
    x_new <- x_mu[,-i]
    mod.fit <- site.level_dirlichet_jags(y=spp.y, x_mu = x_new, adapt = 100, burnin = 100, sample = 200)
    fit.list[[i-1]] <- mod.fit
  }
  #grab deviance statistics as data.frame.
  dev.list <- list()
  for(i in 1:length(fit.list)){
    dev.list[[i]] <- fit.list[[i]]$deviance
  }
  dev.list <-data.frame(do.call(rbind,dev.list))
  rownames(dev.list) <- colnames(x_mu)[2:ncol(x_mu)]

  #calculate difference in deviance scores.
  dev.list$diff <- dev[4] - dev.list$Mean
  ###Here I think I should compare deviance distributions, if 95% CI overlaps with reference model deviance, then set difference to zero.
  #removing predictor that results in the largest improvement in deviance score.
  max.diff <- max(dev.list$diff)
  to.drop <- rownames(dev.list[which.max(dev.list$diff),])

  #report how long current selection loop took to complete.
  cat('Model selection loop',loop.count,'complete. ')
  toc()

  #if the difference is less than 2 or negative you are done.
  if(max.diff < 2){
    cat('*Best* model found! results are in output.list. \n')
    to_keep <- colnames(x_mu)
    output.list <- list(dev.list, to_keep, fit)
    names(output.list) <- c('deviance_table','variables','jags_model')
    donezo <- 1
    next
  }

  #If removing the next predictor brings you to a single predictor remaining, you are done.
  if(ncol(x_mu) == 3){
    #Drop the predictor.
    x_mu <- x_mu[,-which(colnames(x_mu) %in% to.drop)]
    #Grab the model thats the best.
    pos <- which(rownames(dev.list) == to.drop)
    fit <- fit.list[[pos]]
    #wrap the restof the output.
    to_keep <- colnames(x_mu)
    output.list <- list(dev.list, to_keep, fit)
    names(output.list) <- c('deviance_table','variables','jags_model')
    #tell R you are done and report.
    donezo <- 1
    cat('No more predictors to remove. Returning *best* model. Results in output.list. \n')
    next
  }

  #If dropping the variables improves deviance by more than 2, awesome. Drop it and repeat the procedure!
  x_mu <- x_mu[,-which(colnames(x_mu) %in% to.drop)]
  #get new reference model to compare things to.
  pos <- which(rownames(dev.list) == to.drop)
  fit <- fit.list[[pos]]
  dev <- fit$deviance
  loop.count <- loop.count + 1
  #tell yourself whats going on.
  cat(to.drop,'removed from model. Refitting...\n')
}


library(gbm)
data(iris)

# Dataset
sample <- iris[sample(nrow(iris))]
train <- sample[1:105, ]
test <- sample[106:150, ]

# Training
model <- gbm(
    Species~.,
    data = train,
    distribution = "multinomial",
    n.trees = 5000,
    interaction.depth = 4
)
summary(model)

# Test
pred <- predict(model, newdata = test[, -5], n.trees = 5000)
p_pred <- apply(pred, 1, which.max)
table(p_pred, test$Species)