library(forecast)  # Required for tslm(), forecast(), Acf(), and Pacf()
library(nortest)   # For Kolmogorov-Smirnov Test
library(qpcR)      # For AICc
library(GeneCycle) # For Fisher test

# ==== Data Processing Tools ====
# Helper function: Modulus
mod<-function(x,m)
{
  t1<-floor(x/m)
  return(x-t1*m)
}

# Helper function: Create quarterly data from monthly
quarterize <- function(series) {
  # Set quarter value to value of last month in quarter
  output <- c()
  month <- 1

  for (i in seq(1, length(series))) {
    if (mod(month, 3) == 0) {
      output <- append(output, series[month])
    }
    month <- month + 1
  }

  return(output)
}

quarterize.avg <- function(series) {
  # Set quarter value to average of monthly values
  output <- c()
  month <- 1
  quarter.sum <- 0

  for (i in seq(1, length(series))) {
    quarter.sum <- quarter.sum + series[month]

    if (mod(month, 3) == 0) {
      quarter.avg <- quarter.sum/3
      quarter.sum <- 0
      output <- append(output, quarter.avg)
    }
    month <- month + 1
  }

  return(output)
}

# ==== Linear Regression Model Functions ====
lm.id <- function(x, y, log=TRUE, poly=TRUE, recip=TRUE) {
  # Used to help identify an appropriate linear regression model
  # x:    Predictor
  # y:    Response

  # Unused arguments (for now)
  # log:  If TRUE, regress against the log transformed predictor
  # poly: If TRUE, regress against polynomial predictors
  # reicp: ...

  lm.slr <- lm(y ~ x)
  lm.log <- lm(y ~ log(x))
  lm.recip <- lm(y ~ I(1/x))
  lm.poly <- lm(y ~ x + I(x^2) + I(x^3))
  models <- list(lm.slr, lm.log, lm.recip, lm.poly)

  par(mfrow=c(2, 2))

  # Plot a regression model
  plot.reg <- function(model, main) {
    # main: Main title for plot
    values.xlim = range(x)
    values.ylim = range(y, fitted(model))

    plot(x, y, xlim=values.xlim, ylim=values.ylim, main=main)
    par(new=TRUE)
    plot(x, fitted(lm.slr), xlim=values.xlim, ylim=values.ylim,
         type="l", xlab="", ylab="")
  }

  plot.reg(lm.slr, main="Simple Linear Regression Model")
  plot.reg(lm.poly, main="Polynomial Regression Model")
  plot.reg(lm.log, main="Log Transformed Predictor")
  plot.reg(lm.recip, main="Reciprocal Transformed Predictor")

  # Print summaries
  lapply(models, summary)

  # Return lm() function calls in a list for further analysis (if necessary)
  return(models)
}

# ======== ARIMA Model Functions ========
## ==== Helper Functions ====
arma.params <- function(model) {
  # Goal: Return well-formatted string of model parameters

  # Grab ARIMA parameters, assuming using arima() or auto.arima()
  # Result: (AR, MA, SAR, SMA, period, non-seasonal diff, seasonal diff)
  params <- model$arma

  formatted <- paste(
    "ARIMA (", paste(params[1], params[6], params[2], sep=","), ")(",
    paste(params[3], params[7], params[4], sep=","), ")",
    "[", params[5], "]", sep="")

  return(formatted)
}

# Goal: Create well formatted residual plots. Intended to be used with sapply().
resid.plot <- function(model, type, main=NULL, show.params=TRUE,
                       zline=FALSE, ...) {
  # model:        Fitted ARIMA model
  # type:         Plotting function to call, e.g. plot(), Acf(), Pacf(), ...
  # main:         Main title text
  # zline:        Plot abline at a=0, b=0
  # show.params:  Show ARIMA model parameters in the subtitle
  # ...:          Additional plotting parameters

  # If title not specified, use name of type of graph
  if (is.null(main)) { main=paste(toupper(type), "of Residuals") }

  # Add titles to list of graphing parameters
  if (show.params) { subtitle <- paste(arma.params(model), "on", model$series) }
  else { subtitle <- "" }

  params <- append(alist(...), alist(main=main, sub=subtitle))

  # Call plotting function
  do.call(what=type, args=append(alist(residuals(model)), params))

  # Draw lines
  if (zline) { abline(a=0, b=0) }
}

# Create well-formatted Normal quantile-quantile plots
resid.norm <- function(model, main="Normal Probability Plot of Residuals", ...) {
  do.call(what="resid.plot", args=append(
    alist(model, type="qqnorm", main=main), alist(...)))
  qqline(residuals(model))
}

resid.hist <- function(model, main="Histogram of Residuals", xlab="Residuals", ...) {
  do.call(what="resid.plot", args=append(
    alist(model, type="hist", main=main, xlab=xlab), alist(...)))
}

## ==== Main Functions =====
arma.id <- function(data, plot.data=FALSE, arch=TRUE, d=0, d2=0, lag.max=48) {
  # Used to help identify an appropriate ARMA model
  # plot.data:  Plot undifferenced data
  # arch:       Analyze data for ARCH/GARCH effects
  # d:          First-order difference at lag d
  # d2:         Second-order difference at lag d2

  # Plot undifferenced data
  if (plot.data) {
    plot(data)
    abline(a=0, b=0)
  }

  # Apply differencing
  if (d > 0) {
    if (d2 > 0) { data <- diff(diff(data, d), d2) }
    data <- diff(data, d)
  }

  # ==== ACF/PACF of Observations ====
  par(mfrow=c(1,2))

  Acf(data, lag.max=lag.max)
  Pacf(data, lag.max=lag.max)

  # Identify ARCH/GARCH Effects
  if (arch==TRUE) {
    Acf(data^2, lag.max=lag.max)
    Pacf(data^2, lag.max=lag.max)
  }
}

arma.diff <- function(data, lag, title=NULL, ylab="Data") {
  # Difference the data at specified lag, return the results, and plot graphs to help check for trend

  if (is.null(title)) { title = paste("Data after Lag-", lag, " Difference", sep="") }

  diff.data <- diff(data, lag)
  diff.tslm <- tslm(diff.data ~ trend)

  plot(diff.data, main=title, ylab=ylab)
  abline(a=0, b=0)          # Plot zero line
  lines(fitted(diff.tslm), lwd="5", col=rgb(0, 0, 1, 0.5))  # Plot trend line

  cat("Variance of the original data: ", var(data), "\n",
      "Variance of the lag-", lag, " differenced data: ", var(diff.data),
      sep="")

  return(diff.data)
}

arma.diag <- function(model, lag.max=48) {
  # ==== Plot Residuals vs. Time ====
  resid.plot(model, type="plot", main="Residual Values vs. Time",
             xlab="", ylab="Residuals", zline=TRUE)

  # ==== Check for Serial Correlation in Residuals ====
  par(mfrow=c(2,2))
  Acf(residuals(model), lag.max=lag.max)
  Pacf(residuals(model), lag.max=lag.max)

  # Normality Checks
  resid.hist(model, breaks=50, show.params=FALSE)
  resid.norm(model, show.params=FALSE)
}

# Formal Statistical Tests
arma.test <- function(model) {
  test.lag <- sqrt(length(fitted(model)))  # Take h = sqrt(number of observations)

  # ==== Normality Tests ====
  # Shapiro-Wilks
  nortest1 <- shapiro.test(residuals(model))

  # Anderson-Darling Test
  nortest2 <- ad.test(residuals(model))

  # ==== Portmanteau Tests ====

  # Grab ARIMA parameters, assuming using arima() or auto.arima()
  # Result: (AR, MA, SAR, SMA, period, non-seasonal diff, seasonal diff)
  params <- model$arma

  test.df <- sum(params[1:4])  # Take fitdf = p + q + P + Q

  # White Noise Hypothesis with h - p - q degrees of freedom
  box <- Box.test(residuals(model), type=c("Ljung-Box"), lag=test.lag, fitdf=test.df)

  # McLeod-Li Test with h degrees of freedom
  ml <- Box.test(residuals(model)^2, type=c("Ljung-Box"), lag=test.lag)

  #cat("Box-Pierce on h - p - q = ", test.lag - test.df,"df", "\n")
  #cat("h = sqrt(n): ", test.lag, "\n")
  #cat("AR/MA Coefficients: ", test.df, "\n")
  return(list(nortest1, nortest2, box, ml))
}

arma.forecast <- function(data, forecast, zoom=0, zoom.ylim=NULL) {
  # data:       Original data to plot forecast against
  # forecast:   A list of arguments to be passed to the forecast function
  # zoom:       Zoom in an x-year period around forecast
  # zoom.ylim:  Range for y-axis when zooming
   # TODO: Make this automatic

  predicted_values <- do.call(what="forecast", args=forecast)

  # ==== Automatically identify start/end of fitted values of forecast ====
  model.start <- min(time(predicted_values$fitted))
  model.freq <- predicted_values$model$arma[5]
  model.end <- max(time(predicted_values$fitted)) + forecast$h * (1/model.freq)

  # ==== Plotting Code ====
  if (zoom > 0) {
    main=c("Zoomed-In Forecast")

    if (!is.null(zoom.ylim)) {
      plot(predicted_values, main=main,
           xlim=range(model.end - zoom, end=model.end), ylim=range(zoom.ylim))
    }
    else {
      plot(predicted_values, main=main,
           xlim=range(model.end - zoom, end=model.end))
    }
  } else {
    plot(predicted_values)
  }

  # Plot actual data
  lines(window(data, start=model.start, end=model.end),
        lwd=5, col=rgb(0, 1, 0, 0.25))

  #return(predicted_values)
}

resid.compare <- function(model1, model2, share.axis=TRUE, lag.max=48, bins=50) {
  # Compare residuals of models
  # share.axis:  Make residuals vs. time plots share same y-axis range
  # lag.max:     Lag at which to display ACF/PACF graphs
  # bins:        Number of bars for the Normality histograms

  models <- list(model1, model2)
  resids <- lapply(models, FUN=residuals)

  # ==== Residuals vs. Time ====
  par(mfrow=c(1,2))

  if (share.axis) {
    # Identify range for residuals
    xlim=range(time(residuals(model1)), time(residuals(model2)))
    ylim=range(residuals(model1), residuals(model2))
    sapply(models, "resid.plot", type="plot", xlim=xlim, ylim=ylim, zline=TRUE,
           main="Residual Values vs. Time", xlab="", ylab="Residuals")
  } else {
    sapply(models, "resid.plot", type="plot", zline=TRUE,
           main="Residual Values vs. Time", xlab="", ylab="Residuals")
  }

  # ==== PACF, ACF ====
  par(mfrow=c(2,2))
  sapply(models, "resid.plot", type="Acf", lag.max=lag.max)
  sapply(models, "resid.plot", type="Pacf", lag.max=lag.max)

  # ==== Normality ====
  par(mfrow=c(2,2))
  sapply(models, "resid.hist", breaks=bins) # Histogram
  sapply(models, "resid.norm")              # Normal QQ-Plots
}

# Compare results of formal statistical tests
test.compare <- function(...) {
  # http://stackoverflow.com/questions/5754367/using-substitute-to-get-argument-name-with
  get.args <- function(a, ...) {
    arg <- deparse(substitute(a))
    dots <- substitute(list(...))[-1]
    c(arg, sapply(dots, deparse))
  }

  model.names.temp <- get.args(...)

  # ...: Fitted ARIMA models to run residual analysis on
  models <- list(...)

  # Ordering error
  # results <- lapply(models, arma.test)
  results <- list()

  for (i in seq(1, length(models))) {
    results <- append(results, list(arma.test(models[[i]])))
  }

  # Store test results
  statistics <- c()
  parameters <- c()  # Degrees of freedom
  p.values <- c()
  methods <- c()     # Test used
  # data.names <- c()  # Name of the time series
  model.names <- c() # Name of the model

  # Loop through models
  for (i in seq(1, length(results))) {

    # Loop through tests
    for (j in seq(1, length(results[[i]]))) {
      statistics <- append(statistics, round(results[[i]][[j]]$statistic, 2))
      parameters <- append(parameters, round(as.numeric(results[[i]][[j]]$parameter), 2))
      p.values <- append(p.values, round(results[[i]][[j]]$p.value, 2))

      # Add test names
      if (j == 1) { test.name <- "Shapiro-Wilk" }
      if (j == 2) { test.name <- "Anderson-Darling" }
      if (j == 3) { test.name <- "Box-Ljung" }
      if (j == 4) { test.name <- "McLeod-Li" }

      methods <- append(methods, test.name)

      # methods <- append(methods, results[[i]][[j]]$method)
      # data.names <- append(data.names, results[[i]][[j]]$data.name)
      model.names <- append(model.names, model.names.temp[i])
    }
  }

  results.df <- data.frame("Model"=model.names, "Test"=methods, "Statistic"=statistics,
                           "df"=parameters, "p-value"=p.values)
  return(results.df)
}

# ==== Functions for Comparing Fit ====
# Compare log-likelihood, AIC, AICc, etc.
fit.compare <- function(...) {
  get.args <- function(a, ...) {
    arg <- deparse(substitute(a))
    dots <- substitute(list(...))[-1]
    c(arg, sapply(dots, deparse))
  }

  model.names <- get.args(...)

  # ...: Fitted ARIMA models to analyze
  models <- list(...)

  n.coefs <- c()      # Number of total ARMA coefficients
  log.liks <- c()
  aics <- c()
  aiccs <- c()
  sigma2s <- c()
  codes <- c()    # Convergence code: 0 if converged, some other number o/w

  # Loop through models
  for (i in seq(1, length(models))) {
    n.coefs <- append(n.coefs, length(models[[i]]$coef))
    log.liks <- append(log.liks, round(models[[i]]$loglik, 2))
    aics <- append(aics, round(models[[i]]$aic, 2))
    aiccs <- append(aiccs, round(AICc(models[[i]]), 2))
    sigma2s <- append(sigma2s, round(models[[i]]$sigma2, 2))
    if (models[[i]]$code == 0) {
      codes <- append(codes, "Yes")
    } else {
      codes <- append(codes, "Error")
    }
  }

  results.df <- data.frame(
    "Model"=model.names, "Order"=n.coefs, "Log Lik"=log.liks,
    "AIC"=aics, "AICc"=aiccs, "sigma2"=sigma2s, "Convergence?"=codes)

  return(results.df)
}


# Data for Figure 1 for the paper
### takes about 1/2 hour at 100000 iterations
### takes a minute or less at 1000 iterations
library(CoDaSeq)

cohens.d <- function(dataset, size){
    apply(dataset, 1, function(x) (mean(x[1:size]) - mean(x[seq(from=size+1, to=size*2)])) / sqrt((var(x[1:size+1]) + var(x[seq(from=size+1, to=size*2)]))/2))
}
list.null <- vector()
list.null$rnorm.null.effect <- matrix(data=NA, nrow=39, ncol=8)
list.null$runif.null.effect <- matrix(data=NA, nrow=39, ncol=8)
list.null$rbeta.null.effect <- matrix(data=NA, nrow=39, ncol=8)
list.null$rcauchy.null.effect <- matrix(data=NA, nrow=39, ncol=8)

list.null$rnorm.cohen.null.effect <- matrix(data=NA, nrow=39, ncol=8)
list.null$runif.cohen.null.effect <- matrix(data=NA, nrow=39, ncol=8)
list.null$rbeta.cohen.null.effect <- matrix(data=NA, nrow=39, ncol=8)
list.null$rcauchy.cohen.null.effect <- matrix(data=NA, nrow=39, ncol=8)

for(i in 2:40){
size <- i
tests <- 100000

test.mat.rnorm <- matrix(data=rnorm(size*2*tests), nrow=tests, ncol=size*2)
test.mat.runif <- matrix(data=runif(size*2*tests), nrow=tests, ncol=size*2)
test.mat.rbeta <- matrix(data=rbeta(size*2*tests, 1,5), nrow=tests, ncol=size*2)
test.mat.rcauchy <- matrix(data=rcauchy(size*2*tests), nrow=tests, ncol=size*2)

conds <- c(rep("A",size), rep("B",size))

list.null$rnorm.null.effect[i-1,] <- c(i, quantile(codaSeq.effect(test.mat.rnorm, conds), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.null$runif.null.effect[i-1,] <- c(i, quantile(codaSeq.effect(test.mat.runif, conds), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.null$rbeta.null.effect[i-1,] <- c(i, quantile(codaSeq.effect(test.mat.rbeta, conds), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.null$rcauchy.null.effect[i-1,] <- c(i, quantile(codaSeq.effect(test.mat.rcauchy, conds), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.null$rnorm.cohen.null.effect[i-1,] <- c(i, quantile(cohens.d(test.mat.rnorm, size), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.null$runif.cohen.null.effect[i-1,] <- c(i, quantile(cohens.d(test.mat.runif, size), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.null$rbeta.cohen.null.effect[i-1,] <- c(i, quantile(cohens.d(test.mat.rbeta, size), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.null$rcauchy.cohen.null.effect[i-1,] <- c(i, quantile(cohens.d(test.mat.rcauchy, size), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
}

save(list.null, file="data/list.null.Rdata")

#### True difference of 1
# single-side overlap of distributions of 1/6
# this moves the location by 1 sd unit in a Normal distribution

# quantile(rnorm(100000), 1/3) = 0.96 or approximately 1
# quantile(runif(100000), 1/3) = .333
# quantile(rbeta(100000, 1,5), 1/3) = 0.078
# quantile(rcauchy(100000), 1/3) = 1.83
list.one$rnorm.diff1.effect <- matrix(data=NA, nrow=39, ncol=8)
list.one$runif.diff1.effect <- matrix(data=NA, nrow=39, ncol=8)
list.one$rbeta.diff1.effect <- matrix(data=NA, nrow=39, ncol=8)
list.one$rcauchy.diff1.effect <- matrix(data=NA, nrow=39, ncol=8)
list.one$rnorm.cohen1.effect <- matrix(data=NA, nrow=39, ncol=8)
list.one$runif.cohen1.effect <- matrix(data=NA, nrow=39, ncol=8)
list.one$rbeta.cohen1.effect <- matrix(data=NA, nrow=39, ncol=8)
list.one$rcauchy.cohen1.effect <- matrix(data=NA, nrow=39, ncol=8)

for(i in 2:40){
size <- i
tests <- 100000

n1 <- matrix(data=rnorm(size*tests), nrow=tests, ncol=size)
n2 <- matrix(data=rnorm(size*tests, mean=1), nrow=tests, ncol=size)
test.mat.rnorm <- cbind(n2,n1)

c1 <- matrix(data=rcauchy(size*tests), nrow=tests, ncol=size)
c2 <- matrix(data=rcauchy(size*tests, location=-2.2), nrow=tests, ncol=size)
test.mat.rcauchy <- cbind(c1,c2)

r1 <- matrix(data=runif(size*tests, min=0, max=1), nrow=tests, ncol=size)
r2 <- matrix(data=runif(size*tests, min=.333, max=1.333), nrow=tests, ncol=size)
test.mat.runif <- cbind(r2,r1)

b1 <- matrix(data=rbeta(size*tests, 1,5), nrow=tests, ncol=size)
b2 <- matrix(data=rbeta(size*tests, 1,5)-0.116, nrow=tests, ncol=size)
test.mat.rbeta <- cbind(b1,b2)

conds <- c(rep("A",size), rep("B",size))

list.one$rnorm.diff1.effect[i-1,] <- c(i, quantile(codaSeq.effect(test.mat.rnorm, conds), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.one$runif.diff1.effect[i-1,] <- c(i, quantile(codaSeq.effect(test.mat.runif, conds), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.one$rbeta.diff1.effect[i-1,] <- c(i, quantile(codaSeq.effect(test.mat.rbeta, conds), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.one$rcauchy.diff1.effect[i-1,] <- c(i, quantile(codaSeq.effect(test.mat.rcauchy, conds), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))

list.one$rnorm.cohen1.effect[i-1,] <- c(i, quantile(cohens.d(test.mat.rnorm, size), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.one$runif.cohen1.effect[i-1,] <- c(i, quantile(cohens.d(test.mat.runif, size), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.one$rbeta.cohen1.effect[i-1,] <- c(i, quantile(cohens.d(test.mat.rbeta, size), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))
list.one$rcauchy.cohen1.effect[i-1,] <- c(i, quantile(cohens.d(test.mat.rcauchy, size), probs=c(0.005,0.025,0.05, 0.5, 0.95,0.975,0.995)))

}

save(list.one, file="data/list.one.Rdata")


# Program to check if the input number is odd or even.
# A number is even if division by 2 give a remainder of 0.
# If remainder is 1, it is odd.
num = as.integer(readline(prompt="Enter a number: "))
if((num %% 2) == 0) {
print(paste(num,"is Even"))
} else {
print(paste(num,"is Odd"))
}


fizz_buzz <- function(){
  for (x in 1:100){
    out<-''
    mod3<- x%%3==0
    mod5 <- x%%5==0
    if (!mod3 && !mod5){
      out=x
    }
    if (mod3){
      out='Fizz'
    }
    if (mod5){
      out=paste0(out,'Buzz')
    }
    cat(out, "\n")
  }
}

fizz_buzz()


2 + 2
10/3

v = c(1, 4, 5, 3, 7)
v <- c(1, 4, 5, 3, 7)
class(v)
sum(v)
mean(v)
length(v)
max(v)
v[1]
v[3:5]
v[-(2:3)]
v^2
exp(v)
v[v >= 3]
sum(v >= 3)
sum(v >= 3)/2

n = 10
k = 5
sqrt(n)
log(n)
exp(-k)
factorial(n)
choose(n,k)
sample(n)
sample(n,replace=TRUE)
sample(4, 3, replace=TRUE, prob=c(0.1,0.2,0.3,0.4)) #samples three numbers between 1 and 4, with replacement, and with probabilities given by (0.1,0.2,0.3,0.4)
replicate(5,c(1:3))
prod(c(2, 4, 5))

x = c(1:10)
y = x*x
plot(x, y, type="l")


#' Multivariate normal mixture conditional likelihood model
#'
#' Gibbs sampling from the multivariate normal mixture conditional likelihood
#' model.
#'
#' @param y_train factor. Categorical response in the train data.
#' @param s_train matrix. Probabilistic predictions of candidate models for
#' train data, binded by columns.
#' @param s_test matrix. Probabilistic predictions of candidate models for test
#' data, binded by columns.
#' @param n_c numeric. Number of classes of the response.
#' @param n_s numeric. Number of candidate models.
#' @param iter numeric. Number of iterations for Gibbs sampling.
#' @param n_g numeric. Number of mixtures at the beginning of Gibbs sampling.
#' Redundant mixtures will collapse during sampling.
#' @param invalog logical. If TRUE, transform s_train and s_test with the
#' inverse logistic transformation. Defaults to TRUE.
#' @param prior_s2 numeric. Prior on the diagonal of the inverse-Wishart scale
#' matrix for covariance matrices.
#' @param prior_mu numeric. Prior on the means of latent multivariate normal
#' distributions.
#' @param prior_nu numeric. Prior on the inverse-Wishart degrees of freedom for
#' covariance matrices.
#'
#' @return Matrix with posterior means of probabilistic predictions for each
#' test observation. The number of columns is n_c and the number of rows is the
#' same as nrow(s_test).
#'
#' @examples
#' set.seed(1)
#' n <- 1000
#' t <- sample(1:2, n, replace = T)
#' M1 <- vector(mode = "numeric", length = n)
#' M2 <- vector(mode = "numeric", length = n)
#'
#' nt1 <- sum(t == 1)
#' nt2 <- n - nt1
#'
#' # Candidate model predictions
#' # M1: systematic error
#' # M2: random
#' M1[t == 1] <- rbeta(nt1, 1, 2)
#' M2[t == 1] <- rbeta(nt1, 2, 2)
#' M1[t == 2] <- rbeta(nt2, 2, 1)
#' M2[t == 2] <- rbeta(nt2, 1, 1)
#'
#' p         <- matrix(c(M1, 1-M1, M2, 1-M2), ncol = 4)
#' train_ind <- 1:500
#' test_ind  <- 501:1000
#'
#' t_train <- t[train_ind]
#' t_test  <- t[test_ind]
#' p_train <- p[train_ind, ]
#' p_test  <- p[test_ind, ]
#'
#' MM_fit <- model_MM(t_train, p_train, p_test, n_c = 2, n_s = 2)
#'
#'
#' @references Pirs, G. and Strumbelj, E. (2019). Bayesian Combination of
#' Probabilistic Classifiers using Multivariate Normal Mixtures. Journal of
#' Machine Learning Research, 20, 51-1.
#'
#' @export
model_MM <- function (y_train, s_train, s_test, n_c, n_s,
                            iter       = 100,
                            n_g        = 15,
                            invalog    = T,
                            regularize = F,
                            # priors
                            prior_s2   = 100,
                            prior_mu   = 0,
                            prior_nu   = 2 + (n_c - 1) * n_s
) {
  library(mvtnorm)
  library(MASS)

  invalog_transform <- function (x, n_s, n_c) {
    for (i in 1:n_s) {
      lo <- (i-1)*n_c + 1
      hi <- (i-1)*n_c + n_c
      x[,lo:hi] <- x[,lo:hi] + runif(nrow(x[,lo:hi]) * ncol(x[,lo:hi]), 0.00,0.001)
      x[,lo:hi] <- x[,lo:hi] / rowSums(x[,lo:hi])

      for (j in 1:n_c) {
        x[ ,(i-1)*n_c + j] <- log(x[ ,(i-1)*n_c + j] / x[ ,(i-1)*n_c+n_c])
      }
    }
    x[,(1:ncol(x) %% n_c) != 0]
  }

  vec_prod  <- function(vec) {return(vec %*% t(vec))}

  to_matrix <- function(vec) {return(matrix(vec,
                                            ncol = sqrt(length(vec)),
                                            byrow = TRUE))}

  sum_na    <- function (my_vec) {return (sum(is.na(my_vec)))}
  if (invalog) {
    t_train <- invalog_transform(s_train, n_s, n_c)
    t_test  <- invalog_transform(s_test, n_s, n_c)
  } else {
    x <- seq(1, ncol(s_train), n_c)
    t_train <- s_train[,-x]
    t_test  <- s_test[,-x]
  }
  t_all   <- rbind(t_train, t_test)

  collapsed <- array(F, dim = c(n_c, n_g))

  # priors ----
  nu_0       <- prior_nu
  Sigma_0    <- diag(prior_s2, ncol(t_train))
  S_0        <- diag(prior_s2, ncol(t_train))
  mu_0       <- rep(prior_mu, ncol(t_train))
  invSigma_0 <- solve(Sigma_0) # Prepare the inverse of the prior.

  # parameters ----
  par_y_test <- array(NA, dim = c(iter+1, nrow(t_test)))
  par_p_test <- array(NA, dim = c(iter+1, nrow(t_test), n_c))
  par_predict<- array(NA, dim = c(iter+1, nrow(t_test), n_c))
  par_group  <- array(NA, dim = c(iter+1, nrow(t_test) + nrow(t_train)))
  par_mu     <- array(NA, dim = c(iter+1, n_c, n_g, ncol(t_train)))
  par_invSigma  <- array(NA, dim = c(iter+1, n_c, n_g, ncol(t_train), ncol(t_train)))

  # assignment of starting values ----
  par_y_test[1,] <- sample(1:n_c, nrow(t_test), rep = T)
  par_group[1,]  <- sample(1:n_g, nrow(t_test) + nrow(t_train), rep = T)

  par_mu[1,,,] <- 0
  for (j in 1:n_c) {
    for (k in 1:n_g) {
      par_invSigma[1,j,k,,] <- diag(ncol(t_train))
    }
  }

  COMPLETE_DATA <- F

  # main loop ----
  for (i in 2:(iter + 1)) {
    cat(i, " ")

    y_all <- c(y_train, par_y_test[i-1,])
    # mu and Sigma ----
    for (j in 1:n_c) {
      # collapse groups
      for (k in n_g:1) {

        if (COMPLETE_DATA) {
          if (sum(par_group[i-1,] == k & y_all == j) <= 1) {
            collapsed[j,k] <- T
          }
        } else {
          if (sum(par_group[i-1,1:length(y_train)][y_train == j] == k) <= 1) {
            collapsed[j,k] <- T
          }
        }
      }

      # sample new params
      for (k in 1:n_g) if (!collapsed[j,k]) {

        # get data for this class and this group
        if (COMPLETE_DATA) {
          tmp_t_all <- t_all[y_all == j & par_group[i - 1, ] == k,]
        } else {
          tmp_t_all <- t_train[y_train == j & par_group[i-1,1:length(y_train)] == k,]
        }

        n_j       <- nrow(tmp_t_all)

        # Get values from the previous iteration.
        invSigma_j <- par_invSigma[i-1,j,k,,]
        mu_j     <- par_mu[i-1,j,k,]
        Sigma_n  <- solve(invSigma_0 + n_j*invSigma_j)
        umean    <- colMeans(tmp_t_all)

        mu_n     <- Sigma_n %*% (invSigma_0 %*% mu_0 +
                                   n_j * invSigma_j %*% umean)
        mu_j     <- mvrnorm(1, mu_n, Sigma_n)
        nu_n     <- nu_0 + n_j
        mu_mat   <- matrix(rep(mu_j, n_j), ncol = length(mu_j), byrow=TRUE)
        ecm      <- t(as.matrix(tmp_t_all - mu_mat))
        ecm      <- apply(ecm, 2, vec_prod)
        ecm      <- rowSums(ecm)
        ecm      <- matrix(ecm, ncol = length(mu_j), byrow = TRUE)
        S_n      <- S_0 + ecm
        invSigma_j <- rWishart(1, nu_n, solve(S_n))[,,1]

        # Insert new values into the current iteration.

        par_mu[i,j,k,]     <- mu_j
        par_invSigma[i,j,k,,] <- invSigma_j
      }
    }

    # groups ----
    par_group[i,] <- par_group[i-1,]
    group_all <- par_group[i,1:length(y_train)]
    g_probs <- array(0, dim = c(nrow(t_train), n_g))
    for (j in 1:n_c) {
      idxs      <- y_train == j
      tmp_t_all <- t_train[idxs,]
      for (k in 1:n_g) if (!collapsed[j,k]) {
        mu     <- par_mu[i,j,k,]
        Sigma  <- solve(par_invSigma[i,j,k,,])
        g_probs[idxs,k] <- dmvnorm(tmp_t_all, mean = mu, sigma = Sigma)
      }
    }

    g_probs <- g_probs / rowSums(g_probs)
    par_group[i,1:length(y_train)] <- apply(g_probs, 1, function(x){sample(1:n_g, 1, prob = x)})

    get_pred <- function(t_test, y_all, n_c, n_g, collapsed, par_mu, par_invSigma, group_all, lambda = rep(0, ncol(t_test))) {
      pred <- array(0, dim = c(nrow(t_test), n_c, n_g))
      for (j in 1:n_c) {
        for (k in 1:n_g) if (!collapsed[j,k]) {
          mu     <- par_mu[i,j,k,]
          Sigma  <- solve(par_invSigma[i,j,k,,])  + diag(lambda)

          pred[,j,k] <- dmvnorm(t_test, mean = mu, sigma = Sigma) * sum(group_all == k & y_all == j)
        }
      }

      pred <- sweep(pred, 1, apply(pred, 1, sum), FUN="/")
    }
    pred <- get_pred(t_test, y_train, n_c, n_g, collapsed, par_mu, par_invSigma, par_group[i,1:length(y_train)])
    tmp  <- apply(pred, 1, function(x){sample(1:(n_c * n_g), 1, prob = c(x))})
    par_y_test[i,] <- (tmp - 1) %% n_c + 1
    par_group[i,(length(y_train) + 1):length(par_group[i,])] <- floor((tmp - 1) / n_c) + 1

    # regularize
    fn_optim <- function(x, t_train, y_train, n_c, n_g, collapsed, par_mu, par_invSigma, par_group) {
      pred <- get_pred(t_train, y_train, n_c, n_g, collapsed, par_mu, par_invSigma, par_group, lambda = x)
      pred <-  apply(pred, c(1,2), sum)
      p_star <- pred[cbind(1:nrow(pred), y_train)]
      -mean(log(p_star))
    }

    if (regularize) {
      lambda <- rep(0, ncol(t_train))
      idx    <- sample(1:length(y_train), 100, rep = T)
      lambda_max <- 100000
      res <- optim(lambda, fn = fn_optim,
                   lower = rep(0, length(lambda)),
                   upper = rep(lambda_max, length(lambda)),
                   method = "L-BFGS-B", #control = list(trace = 1),
                   t_train = t_train[idx,], y_train = y_train[idx], n_c = n_c,
                   n_g = n_g, collapsed = collapsed, par_mu = par_mu, par_invSigma = par_invSigma, par_group = par_group[i,1:length(y_train)][idx])

      pred <- get_pred(t_test, y_train, n_c, n_g, collapsed, par_mu, par_invSigma, par_group[i,1:length(y_train)], lambda = res$par)
      par_predict[i,,] <- apply(pred, c(1,2), sum)

    } else {
      par_predict[i,,] <- apply(pred, c(1,2), sum)
    }
  }
  cat("\n")

  return(pred = apply(par_predict[-1,,], c(2,3), mean))
}


library(arules)
library(arulesViz)
library(lubridate)

l_movies = topmovies

# Convert dates to days of the year.
l_movies[, 4] = lapply(l_movies[, 4], as.Date, format="%B %d")
l_movies[, 4] = lapply(l_movies[, 4], yday)

# Remove dollar signs and convert to numeric types.
l_movies[, 3] = lapply(l_movies[, 3], substring, 2)
l_movies[, 3] = lapply(l_movies[, 3], as.numeric)

# Discretize column values.
l_movies[, 1] = discretize(as.matrix(l_movies[, 1]), categories = 5)
l_movies[, 3] = discretize(as.matrix(l_movies[, 3]), categories = 5)
l_movies[, 4] = discretize(as.matrix(l_movies[, 4]), categories = 4)
l_movies[, 5] = discretize(as.matrix(l_movies[, 5]), categories = 5)

col_names = names(l_movies)
l_movies[, col_names] = lapply(l_movies[, col_names], factor)

# Run the APRIORI algorithm.
rules.all <- apriori(l_movies, parameter = list(minlen=2, supp=0.2, conf=0.3))
rules.sorted <- sort(rules.all, by = "lift")

# Plot stuff.
plot(rules.all, method="grouped")


rm(list=ls())
############################################################
# Initial setup
############################################################

library(rstan)
library(dplyr)
library(loo)
require(MASS) # to generate from a multivariate normal distribution
require(Matrix) # to create sparse vectors

### TODO: change to your working directory where the .stan files are stored
#setwd("~/Desktop/")
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

##############################################
# Data Generating Process
##############################################
set.seed(2019)

sig.param = 2
num.param = 50
N_train = 100
N_test = 100
nobs= N_train+N_test
Sig <- matrix(0, ncol=num.param, nrow=num.param)
diag(Sig) <- 10
sd=1
beta0 = 0
beta = c(0.2, 0.8, rep(0,(num.param-sig.param)))
X <- mvrnorm(nobs, mu=c(15,35, rep(10,8), rep(20,10), rep(30,10), rep(40,10), rep(50,10)), Sigma=Sig)
y <- beta0 + X %*% beta + rnorm(nobs,0,sd)

trainX <- X[1:N_train, ]
testX <- X[(N_train+1):nrow(X), ]
trainY <- y[1:N_train]
testY <- y[(N_train+1):nrow(y)]

standat <- list(N_train=N_train, p=ncol(trainX), y_train=trainY, X_train=trainX,
                N_test=N_test, X_test=testX)

##############################################
# Main Simulation
##############################################

############################################################
# Horseshoe
############################################################
fit_horseshoe = rstan::stan_model(file = 'Horseshoe_Publish.stan')
fit_horseshoe <- sampling(object = fit_horseshoe, data=standat,
                          seed=2019, chains = 4,iter = 10,warmup = 5)

# LOO, WAIC
summary_horseshoe = summary(fit_horseshoe)
lik_horseshoe = extract_log_lik(fit_horseshoe)
loo_horseshoe = loo(lik_horseshoe)
waic_horseshoe = waic(lik_horseshoe)

############################################################
# Spike and Slab
############################################################
stan_normal_mixture = stan_model(file='Spike_Slab_Publish.stan')
fit_normal_mixture <- sampling(object = stan_normal_mixture, data=standat,
                               seed=2019, chains = 4,iter = 10,warmup = 2)

# LOO, WAIC
lik_normal_mixture = extract_log_lik(fit_normal_mixture)
loo_normal_mixture = loo(lik_normal_mixture)
waic_normal_mixture = waic(lik_normal_mixture)


# demo script for generating data from one of the models
# that will be fit with the other model
source("chartr-HelperFunctions.r")

nCoh = 5; # Create data with 7 coherence
nmc = 500; # Take 500 trials for simulations
saveFiles = FALSE;
saveDir = "caseStudy2"
subjectPrefix = "Subj"

model = "bUGMSv"
par(mfrow=c(2,3))
for(nSubj in seq(1,5)){
  fP = paramsandlims(model,nCoh, fakePars = TRUE)
  currParams = fP$fakeParams
  currParams["aU"] = 4900;
  currParams["eta"] = 5;
  currParams["intercept"] = 200 + 20*rnorm(1,0,1);

  dat = simulateRTs(model, currParams , n=nmc, nds=nCoh)

  saveFileName=paste(saveDir,subjectPrefix,nSubj,sep="");
  if(saveFiles){
   # save(file=saveFileName,dat, currParams, genModel=model);
  }
}


#' z_transform
#' z transforms all columns of a matrix or data farme by subtracting each vectors mean, dividing by sd.
#' if there no variance in a column, just returns the column untransformed.
#'
#' @param x matrix or dataframe
#'
#' @return martix or dataframe, z transformed.
#' @export
#'
#' @examples
z_transform <- function(x) {
  ifelse(sd(x, na.rm=T) == 0,
         return(x),
         return((x - mean(x, na.rm=T)) / sd(x, na.rm=T))
  )
}


#	functions to calculate paleoflow depth from preserved cross-sets.
#	Eric Barefoot
#	Nov 2017
#
#	largely taken from work by Suzanne Leclair, Chris Paola and methods in a review paper by Bradley and Venditti

#	first step is to relate the cross-set (xset) thickness to dune height (H)

#	require packages

# require(stats4)

#' Dune height calculation from cross-set thicknesses
#'
#' \code{xset2H} takes measured cross-set thicknesses (\code{y}) and converts it to dune heights (H).
#'
#' @param y 	A vector of measured cross-set thicknesses in meters.
#' @param mode	Takes two values: \code{simple} and \code{pdfFit}. \code{simple} uses a simple approximation to determine the beta value in Leclair's equation relating x-sets to dune heights. \code{pdfFit} uses a more complicated procedure, fitting a PDF from Paola  + Borgman to get the beta value. \code{pdfFit} is better suited when there are adequate data to estimate the distribution.
#' @param output 	Takes two values: \code{vanilla} and \code{rich}. \code{vanilla} only returns the estimated value of \code{H}, or dune height. \code{rich} returns \code{H}, as well as \code{beta} and either \code{startVal} which is the inital guess of a for the MLE algorithm in \code{pdfFit}, or a span of \code{H} values giving a reasonable range of one particular assumption.
#' @return Either a single numeric if \code{output = vanilla}, or a list if \code{output = rich}.
#' @export

xset2H = function(y, mode = 'simple', output = 'vanilla') {

	#	function takes two modes: 'simple' and 'pdfFit'
	#	y is a vector of cross-set thicknesses -- MUST BE IN METERS

	y = y * 1000 # 	convert to millimeters

	#	gives output in meters

	n = length(y)

	#	first a function to estimate the average dune height via fitting a PDF of x-set thicknesses to find the right parameters
	pdfFit = function(y) {

		#	define the probability density function from Paola and Borgman
		pfun = function(a,s) {
			p = a * exp(-a*s) * (exp(-a*s) + a * s - 1) / (1 - exp(-a*s))^2
			return(p)
		}

		#	construct a likelihood function which takes data as an external argument and the parameter as the internal argument.
		loglikely = function(data) {
			function(a) {
				R = R = pfun(a, data)
				-sum(log(R))
			}
		}

		#	construct likelihood function for these data.
		LL = loglikely(y)

		#	default starting a value for fitting
		#	and error handling sequence for finding an inital guess value for that works and doesnt crash the MLE.
		worked = FALSE
		startVal = 1
		try(stop(''), silent = T)
		j = 1
		while (!worked) {

			try_MLE = try(coef(mle(minuslogl = LL, start = list(a = startVal))), silent = T)

			if (class(try_MLE) == 'try-error' & j < 1000) {

				options(warn = -1)
				msg = as.character(try_MLE)

				if (grepl('initial value', msg)) {
					startVal = startVal / 2
					j = j + 1
#					message(paste(startVal))
				} else {
					stop('Something else happened, its real bad')
				}

			} else {

				worked = TRUE

			}
		}

		#	estimate parameter using MLE function
		a = coef(mle(minuslogl = LL, start = list(a = startVal)))

		#	get beta a la Leclair et al. 0.9 is for dune height/scour correction
		beta = 0.9/a

		#	get dune height from beta from Leclair et al. two ways.
#		H = 2.22 * beta ^ 1.32
		H = 5.3 * beta + 0.001 * beta ^ 2

		list(H = as.numeric(H) / 1000, beta = as.numeric(beta), startVal = startVal)
	}

	#	Here, a simpler function using only the empirical estimations made by Leclair et al.
	simple = function(y) {
		sm = mean(y, na.rm = T) #	find average set thickness
		hsd_tssd = seq(from = 0.7, to = 1.1, by = 0.1) #	find ratio of scour deviation to height deviation. supposedly an average of 0.9, but ranges randomly from 0.7 to 1.1 this function spits out a range.
		beta = sm / (1.64493 / hsd_tssd) #	use that to calculate beta
#		beta = sm / 1.8

#		H = 2.22 * beta ^ 1.32
		H = 5.3 * beta + 0.001 * beta ^ 2 #	use same equation as in pdfFit to get the average height

		list(H = mean(H) / 1000, beta = as.numeric(beta), vecH = H / 1000)
	}

	#	offer some recommendations to the user.
	if(n >= 25 & mode == 'simple') {

		message('this dataset may benefit from running a more complicated PDF based function.')

		H = simple(y)

	} else if (n < 25 & mode == 'simple' ) {

		H = simple(y)

	} else if (n < 25 & mode == 'pdfFit') {

		message('this dataset is small, and may benefit from running a less complicated empirical.')

		H = pdfFit(y)

	} else if (n >= 25 & mode == 'pdfFit') {

		H = pdfFit(y)

	}

	switch(output ,
		   vanilla = return(H$H),
		   rich = return(H)
		  )
}

#' Paleo-depth calculation from dune height
#'
#' \code{H2h} takes estimated dune heights (H) and calculates a flow depth.
#'
#' @param H 	A vector of measured cross-set thicknesses in meters.
#' @param CL	A pre-specified confidence level. If you pick a low confidence (50\%), the range in estimated flow depth will be smaller.
#' @param output 	Takes two values: \code{vanilla} and \code{rich}. \code{vanilla} only returns the estimated value of \code{h}. \code{rich} returns \code{h}, as well as \code{CI}, the confidence interval around the \code{h} estimate.
#' @return Either a single numeric if \code{output = vanilla}, or a list if \code{output = rich}.
#' @export

#	second step is to relate the dune height to the flow depth, following Bradley and Venditti

H2h = function(H, CL = 50, output = 'vanilla') {

	#	H is the height of a dune in meters.
	#	or if H is a vector, it is a set of dune heights
	#	CL is the confidence level in percent

	#	confidence ranges

	CR = data.frame(CL = c(50, 80, 90, 95), upper = c(10.1, 14.6, 23.9, 29.5), lower = c(4.4, 3.1, 2.8, 2.7))

	Cind = which.min(abs(CR$CL - CL)) # match closest one from the table

	h = 6.7 * H	#	using the median parameter from Bradley and Venditti

	CI = list(upper = H * CR$upper[Cind], lower = H * CR$lower[Cind]) # and based on Confidence Level, assign bounds of confidence

	returnval = switch(output ,
					   vanilla = return(h),
					   rich = return(list(h = h, CI = CI))
					  )
}

#	and now a function that combines both into one function, so you can go straight from xsets to flow depth with no extra frills, or depth

#' Paleo-depth calculation from cross-set thicknesses
#'
#' \code{xset2depthSimple} uses the simplest implementation of both \code{xset2H} and \code{H2h}. It uses the vanilla options of each one and spits out an estimate of paleo-depth based on the defaults. Look in the code for the other functions to see what those defaults are.
#' @param y 	A vector of measured cross-set thicknesses in meters.
#' @return The paleo-depth estimate in meters.
#' @export

xset2depthSimple = function(y) {

	#	y is a vector of thicknesses of xsets in meters

	H = xset2H(y)

	h = H2h(H)

	return(h)

}


#' Applies the Plan B smooth approach.
#'
#' Smooths data (Year and Biomass Index) using loess, applies log linear regression to most recent three years, and retransforms back to estimate multiplier for catch advice.
#' @param dat data frame of Year and avg (the biomass index)
#' @param od output directory where plots are saved (default=working directory)
#' @param my.title title for time series plot with loess smooth (default = "")
#' @param terminal.year last year used in smooth (allows easy retro analysis) (default = NA = most recent)
#' @param nyears number of years to use in loess (default = 33)
#' @param loess.span proportion time series used in smoothing (default = NA, calculates span=9.9/nyears)
#' @param saveplots true/false flag to save output to od (default=FALSE)
#' @param showplots true/false flag to display plots in window (default=TRUE)
#' @param nameplots added to start of saved files (default=""), spaces not recommended
#' @export

ApplyPlanBsmooth <- function(dat,
                             od            = ".\\",
                             my.title      = "",
                             terminal.year = NA,
                             nyears        = 33,
                             loess.span    = NA,
                             saveplots     = FALSE,
                             showplots     = TRUE,
                             nameplots     = ""){

  # select data to use
  if(is.na(terminal.year)) terminal.year <- max(dat$Year, na.rm=T)
  dat.use <- filter(dat, Year <= terminal.year, Year >= (terminal.year - nyears + 1)) %>%
    drop_na()  # removes years with missing index values
  nyears <- max(dat.use$Year) - min(dat.use$Year) + 1 # in case fewer years than (e.g., during retro)

  # apply loess
  if(is.na(loess.span)) loess.span <- 9.9 / nyears
  lfit <- loess(data=dat.use, avg ~ Year, span=loess.span)
  pred_fit <- predict(lfit, se=TRUE)

  # get last three predicted values
  reg.dat <- data.frame(Year = dat.use$Year,
                        pred = pred_fit$fit)
  reg.years <- seq(terminal.year - 2, terminal.year)
  reg.use <- filter(reg.dat, Year %in% reg.years, pred > 0)

  # add warning message if recent three year regression has less than three years
  if(dim(reg.use)[1] != 3){
    print("the log-linear regression to estimate the multiplier uses less than 3 years")
  }

  # trap holes in time series resulting in 0 or 1 data point for regression to avoid program crashing
  if (dim(reg.use)[1] <= 1){
    llr_fit <- NA
    llr_fit.df <- data.frame(Year  = integer(),
                             llfit = double())
    multiplier <- NA
    round_multiplier <- "NA"
  }

  if (dim(reg.use)[1] >= 2){
    # log linear regression of last three loess predicted values
    llr_fit <- lm(log(pred) ~ Year, data=reg.use)
    llr_fit.df <- data.frame(Year  = reg.use$Year,
                             llfit = exp(predict(llr_fit)))

    # convert back to regular scale
    multiplier <- as.numeric(exp(llr_fit$coefficients[2]))
    round_multiplier <- round(multiplier, 3)
  }

  # make plot
  ribbon <- data.frame(Year = dat.use$Year,
                       avg  = dat.use$avg,
                       pred = pred_fit$fit,
                       loci = pred_fit$fit - 1.96 * pred_fit$se.fit,
                       hici = pred_fit$fit + 1.96 * pred_fit$se.fit)
  if(saveplots) write.csv(ribbon, paste0(od, nameplots, "PlanBsmooth_table.csv"), row.names = FALSE)

  ribbon <- mutate(ribbon, loci0 = ifelse(loci < 0, 0, loci)) # to allow ggplot to show CI when low < 0

  tsplot <- ggplot(ribbon, aes(x=Year, y=avg)) +
    geom_point() +
    geom_ribbon(aes(x=Year, ymin=loci0, ymax=hici), fill="grey50", alpha=0.3) +
    geom_line(aes(x=Year, y=pred), color="blue", size=1.3) +
    geom_line(data=llr_fit.df, aes(x=Year, y=llfit), color="red", size=1.3, linetype="dashed") +
    scale_y_continuous(expand = c(0,0), limits = c(0, NA)) +
    ylab("Biomass Index") +
    labs(title = my.title, subtitle = paste0("Multiplier = ", round_multiplier)) +
    theme_bw()

  if(showplots==TRUE) print(tsplot)
  if(saveplots) ggsave(paste0(od, nameplots, "time_series_with_loess_smooth.png"), tsplot)

  # list of results
  res <- list()
  res$dat.use    <- dat.use
  res$lfit       <- lfit
  res$pred_fit   <- pred_fit
  res$reg.use    <- reg.use
  res$llr_fit    <- llr_fit
  res$multiplier <- multiplier
  res$tsplot     <- tsplot

  return(res)

}


#' @title Calculate probability based on zero inflated generalized Dirichlet-multinomial distribution
#'
#' @description
#' This function estimates parameters from zero inflated generalized Dirichlet-multinomial distribution, and test the pro.
#' @param Y Count table of microbiome
#' @param Xc design matrices for probability of absence model. The first column should contain "1" for the intercept. For intercept only model, the three matrices are simply contain vectors of 1.
#' @param Xa design matrices for mean model.  The first column should contain "1" for the intercept. For intercept only model, the three matrices are simply contain vectors of 1.
#' @param Xb design matrices for dispersion model. The first column should contain "1" for the intercept. For intercept only model, the three matrices are simply contain vectors of 1.
#' @param c0 c0: initial values for regression coefficients "c" organized in a matrix (dim: K x d, K+1 is the #taxa (i.e. K+1 = ncol(Y)), d is the number of columns in the corresponding design matrix)
#' @param alpha0: initial values for regression coefficients "alpha" organized in a matrix (dim: K x d)
#' @param beta0: initial values for regression coefficients "beta" organized in a matrix (dim: K x d)
#' @param tol: convergence tolerance
#' @param max.iter: maximum number of iterations

#' @return A vector containning the probablity of multinomial distribution
#' @export
#' @examples
####estimate probability of of absent matrix, mean and dispersion matrix from Y based on ZIGDM model
###Test_result <- ZIGDM.EM.PAR2(Y=Y, Xc=Xc, Xa=Xa, Xb=Xb, c0=c0, alpha0=alpha0, beta0=beta0, tol=tol, max.iter=max.iter)
#### using probability of of absent matrix to random generate present and absent value

ZIGDM_prob <- function(Test_result, row) {
 ####row is Xc[1,]
  Delta <- Bernoulli(c.est = Test_result$c.est, row = row)
  #### based on Delta, generate Z, row2 is Xa[1,], row3 is Xb[1,]. since Xc[1,]=Xa[1,]=Xb[1,],row is used for all
  Z_value <- Zvalue_Generator(Delta = Delta, Test_result = Test_result, row2 = row, row3 = row)
  #### based on Z, generate p vector for multinomial

  MultinomialP <- multinormial_P(Z=Z_value)
  MultinomialP[length(MultinomialP)+1] <- 1- sum(MultinomialP)  #### add the K+1 taxa back

  return (MultinomialP)

  #probability = apply(Y,1,dmultinom, prob = MultinomialP)

  #return (probability)
}


test_that("simulate_residuals return an object of class DHARMa", {

  check_tf_version <- greta::.internals$utils$misc$check_tf_version
  skip_if_not(check_tf_version())

  set.seed(1234)

  intercept <- normal(0, 1)
  slope <- normal(0, 1)
  sd_resid <- cauchy(0, 1, truncation = c(0, 100))

  x <- runif(100)
  y <- as_data(rnorm(100, 1 + 2 * x, 1))

  linpred <- intercept + slope * x

  distribution(y) <- normal(linpred, sd_resid)

  m <- model(intercept, slope, sd_resid)
  draws <- mcmc(m, warmup = 10, n_samples = 10)

  # results
  expect_s3_class(simulate_residual(draws, y, linpred), "DHARMa")

})


# ----------------------------------------
#  App Title: Chaos Game -- 2 Dimensions
#     Author: Jimmy Doi
# ----------------------------------------

library(shiny)
library(shinyBS)
library(shape)

###################################################################
# Triangle
###################################################################

tri.gen <- function(wt){
  	weight <- wt

		len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=3,nrow=3)

		loci[1,] <- c(1,0,0)
		loci[2,] <- c(2,0.5,sqrt(3)/2)
		loci[3,] <- c(3,1,0)

    # vertices contains all random vertex points
    vertices <- runif(len)
		vertices[which(vertices>2/3)]<- 3
		vertices[which(1/3<vertices & vertices<=2/3)]<- 2
		vertices[which(vertices<=1/3)]<- 1

		coords <- matrix(NA,ncol=2,nrow=(len+1))
		colnames(coords)<-c("x","y") #needed for ggvis

		coords[1,] <- c(runif(1),runif(1)*sqrt(3)/2)

		for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      x.new <- weight*x + (1-weight)*coords[i,1]
      y.new <- weight*y + (1-weight)*coords[i,2]
	    coords[row,]<-c(x.new,y.new)
	    x <- x.new
	    y <- y.new
		}
    return(list(loci,vertices,coords))
}

###################################################################
# Square
###################################################################

sqr.gen <- function(wt){

    weight <- wt

		len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=3,nrow=8)

		loci[1,] <- c(1,0.0,0.0)
		loci[2,] <- c(2,0.5,0.0)
		loci[3,] <- c(3,1.0,0.0)
  	loci[4,] <- c(4,1.0,0.5)
  	loci[5,] <- c(5,1.0,1.0)
  	loci[6,] <- c(6,0.5,1.0)
  	loci[7,] <- c(7,0.0,1.0)
  	loci[8,] <- c(8,0.0,0.5)

    # vertices contains all random vertex points
    vertices <- runif(len)
		vertices[which(vertices>7/8)]<- 8
  	vertices[which(6/8<vertices & vertices<=7/8)]<- 7
  	vertices[which(5/8<vertices & vertices<=6/8)]<- 6
  	vertices[which(4/8<vertices & vertices<=5/8)]<- 5
  	vertices[which(3/8<vertices & vertices<=4/8)]<- 4
  	vertices[which(2/8<vertices & vertices<=3/8)]<- 3
		vertices[which(1/8<vertices & vertices<=2/8)]<- 2
		vertices[which(vertices<=1/8)]<- 1

		coords <- matrix(NA,ncol=2,nrow=(len+1))
		colnames(coords)<-c("x","y") #needed for ggvis

    # randomly selected initial point in field of view
		coords[1,] <- c(runif(1),runif(1))

  	for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      x.new <- (weight)*x + (1-weight)*coords[i,1]
	    y.new <- (weight)*y + (1-weight)*coords[i,2]
	    coords[row,]<-c(x.new,y.new)
		}

    return(list(loci,vertices,coords))
}

###################################################################
# Pentagon
###################################################################

pent.gen <- function(wt){

    weight <- wt

  	len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=3,nrow=5)

    c1 <- 0.25*(sqrt(5)-1)
    c2 <- 0.25*(sqrt(5)+1)
    s1 <- 0.25*(sqrt(10+2*sqrt(5)))
    s2 <- 0.25*(sqrt(10-2*sqrt(5)))

		loci[1,] <- c(1,0,1)
		loci[2,] <- c(2,s1,c1)
		loci[3,] <- c(3,s2,-c2)
  	loci[4,] <- c(4,-s2,-c2)
  	loci[5,] <- c(5,-s1,c1)

    # vertices contains all random vertex points
    vertices <- runif(len)
		vertices[which(vertices>4/5)]<- 5
  	vertices[which(3/5<vertices & vertices<=4/5)]<- 4
  	vertices[which(2/5<vertices & vertices<=3/5)]<- 3
		vertices[which(1/5<vertices & vertices<=2/5)]<- 2
		vertices[which(vertices<=1/5)]<- 1

		coords <- matrix(NA,ncol=2,nrow=(len+1))
		colnames(coords)<-c("x","y") #needed for ggvis

    # randomly selected initial point in field of view
		coords[1,] <- c(runif(1,-s1,s1),runif(1,-c2,1))

  	for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      x.new <- (weight)*x + (1-weight)*coords[i,1]
	    y.new <- (weight)*y + (1-weight)*coords[i,2]
	    coords[row,]<-c(x.new,y.new)
		}

    return(list(loci,vertices,coords))
}

###################################################################
# Hexagon
###################################################################

hex.gen <- function(wt){

    weight <- wt

    len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=3,nrow=6)

    alpha <- 0.5
    beta  <- sqrt(3)/2

		loci[1,] <- c(1,0,2*alpha)
		loci[2,] <- c(2,beta,alpha)
		loci[3,] <- c(3,beta,-alpha)
  	loci[4,] <- c(4,0,-2*alpha)
  	loci[5,] <- c(5,-beta,-alpha)
    loci[6,] <- c(6,-beta,alpha)

    # vertices contains all random vertex points
    vertices <- runif(len)
		vertices[which(vertices>5/6)]<- 6
    vertices[which(4/6<vertices & vertices<=5/6)]<- 5
  	vertices[which(3/6<vertices & vertices<=4/6)]<- 4
  	vertices[which(2/6<vertices & vertices<=3/6)]<- 3
		vertices[which(1/6<vertices & vertices<=2/6)]<- 2
		vertices[which(vertices<=1/6)]<- 1

		coords <- matrix(NA,ncol=2,nrow=(len+1))
		colnames(coords)<-c("x","y") #needed for ggvis

    # randomly selected initial point in field of view
		coords[1,] <- c(runif(1,-beta,beta),runif(1,-2*alpha,2*alpha))

  	for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      x.new <- (weight)*x + (1-weight)*coords[i,1]
	    y.new <- (weight)*y + (1-weight)*coords[i,2]
	    coords[row,]<-c(x.new,y.new)
		}

    return(list(loci,vertices,coords))
}

##############################################################################
# Shiny Server Contents
##############################################################################

shinyServer(function(input, output, session) {

output$my.init <- renderUI({
  input$shape
    sliderInput(inputId = "init",
      "Number of points (n):",
      min = 1,
      max = 100,
      step = 1,
      value = 1,
      animate=animationOptions(interval = 1000))
  })

output$my.extend <- renderUI({
  input$shape
    sliderInput("extend",
      "Number of points (n):",
      min = 100,
      max = 1000,
      step = 25,
      value = 100,
      animate=animationOptions(interval = 400))
  })

output$my.pts <- renderUI({
  input$shape
    sliderInput("pts",
      "Number of points (n):",
      min = 1000,
      max = 50000,
      step = 1000,
      value = 1000,
      animate=animationOptions(interval = 200))
    })

  updateButton(session, "gen", style = "primary", size = "default", disabled = FALSE)

  all.list <- reactive({
    if (input$shape == "tri") {
      return(tri.gen(input$dist.tri*(input$gen>-1)))
      }
    if (input$shape == "sqr") {
      return(sqr.gen(input$dist.sqr*(input$gen>-1)))
      }
    if (input$shape == "pent") {
      return(pent.gen(input$dist.pent*(input$gen>-1)))
      }
    if (input$shape == "hex") {
      return(hex.gen(input$dist.hex*(input$gen>-1)))
      }
    })

##################################
# initPlot                       #
##################################

  output$initPlot <- renderPlot({

    loci      <- all.list()[[1]]
    vertices  <- all.list()[[2]]
    coords    <- all.list()[[3]]

    #############################
    # Triangle:INIT             #
    #############################
    if (input$shape == "tri") {

        par(mar=c(0.5,0.5,0.5,0.5))
    plot(0,0,xlim=c(0,1),ylim=c(0,sqrt(3)/2),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")

    if (!is.null(input$init)) {
      if (input$init==1) {
      points(coords[1,1],coords[1,2],pch=20,cex=3,col="blue")

      if (coords[1,1]>=0.5 & coords[1,2]<=sqrt(3)/4) {
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]>=0.5 & coords[1,2]>sqrt(3)/4) {
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]<0.5 & coords[1,2]>sqrt(3)/4) {
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=4)
      }
      if (coords[1,1]<0.5 & coords[1,2]<=sqrt(3)/4) {
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=4)
      }
    }
    }
    }

    #############################
    # Square:INIT               #
    #############################
    if (input$shape == "sqr") {

          par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(0,1),ylim=c(0,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")

    if (input$init==1) {
      points(coords[1,1],coords[1,2],pch=20,cex=3,col="blue")

      if (coords[1,1]>=0.5 & coords[1,2]<=0.5) { # LOWER RIGHT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]>=0.5 & coords[1,2]>0.5) {  # UPPER RIGHT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]<0.5 & coords[1,2]>0.5) {   # UPPER LEFT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=4)
      }
      if (coords[1,1]<0.5 & coords[1,2]<=0.5) {  # LOWER LEFT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=4)
      }
    }
    }

    #############################
    # Pentagon:INIT             #
    #############################
    if (input$shape == "pent") {

    c1 <- 0.25*(sqrt(5)-1)
    c2 <- 0.25*(sqrt(5)+1)
    s1 <- 0.25*(sqrt(10+2*sqrt(5)))
    s2 <- 0.25*(sqrt(10-2*sqrt(5)))

      par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-s1,s1),ylim=c(-c2,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")

    if (input$init==1) {
      points(coords[1,1],coords[1,2],pch=20,cex=3,col="blue")

      if (coords[1,1]>=0 & coords[1,2]<=0) { # LOWER RIGHT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]>=0 & coords[1,2]>0) {  # UPPER RIGHT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]<0 & coords[1,2]>0) {   # UPPER LEFT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=4)
      }
      if (coords[1,1]<0 & coords[1,2]<=0) {  # LOWER LEFT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=4)
      }
    }
    }

    #############################
    # Hexagon:INIT              #
    #############################
    if (input$shape == "hex") {

      alpha <- 0.5
      beta  <- sqrt(3)/2

      par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-beta,beta),ylim=c(-2*alpha,2*alpha),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")

    if (input$init==1) {
      points(coords[1,1],coords[1,2],pch=20,cex=3,col="blue")

      if (coords[1,1]>=0 & coords[1,2]<=0) { # LOWER RIGHT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]>=0 & coords[1,2]>0) {  # UPPER RIGHT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]<0 & coords[1,2]>0) {   # UPPER LEFT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=4)
      }
      if (coords[1,1]<0 & coords[1,2]<=0) {  # LOWER LEFT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=4)
      }
    }
    }
    ##################################################################################
    ### APPLIED TO ALL

    if (!is.null(input$init)) {
      if (input$init!=1) {
    points(coords[1:input$init-1,1],coords[1:input$init-1,2],pch=20,cex=1,col="blue")

    points(coords[input$init-1,1],coords[input$init-1,2],pch=20,cex=2.75,col="blue")
    points(coords[input$init,1],coords[input$init,2],pch=21,cex=3,col="blue",bg="white")
    points(coords[input$init,1],coords[input$init,2],pch=20,cex=2.75,col="blue")

    x0 <- coords[input$init-1,1]
    y0 <- coords[input$init-1,2]
    x1 <- coords[input$init,1]
    y1 <- coords[input$init,2]

    Arrows((.6*x0+.4*x1),(.6*y0+.4*y1),(.4*x0+.6*x1),(.4*y0+.6*y1),col="blue",lwd=2)

    v.x <- loci[loci[,1]==vertices[input$init-1],2]
    v.y <- loci[loci[,1]==vertices[input$init-1],3]

    points(v.x,v.y,pch=1,cex=4,lwd=2)
    points(v.x,v.y,pch=1,cex=3,lwd=2)
    }
        }

    points(loci[,2],loci[,3],pch=20,cex=2,col="red")

  }) # initPlot's renderPlot

##################################
# extendPlot                     #
##################################
  output$extendPlot <- renderPlot({

    loci      <- all.list()[[1]]
    vertices  <- all.list()[[2]]
    coords    <- all.list()[[3]]

    #############################
    # Triangle:EXTEND           #
    #############################
    if (input$shape == "tri") {

        par(mar=c(0.5,0.5,0.5,0.5))
    plot(0,0,xlim=c(0,1),ylim=c(0,sqrt(3)/2),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Square:EXTEND             #
    #############################
    if (input$shape == "sqr") {

        par(mar=c(0.5,0.5,0.5,0.5))
    plot(0,0,xlim=c(0,1),ylim=c(0,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Pentagon:EXTEND           #
    #############################
    if (input$shape == "pent") {

    c1 <- 0.25*(sqrt(5)-1)
    c2 <- 0.25*(sqrt(5)+1)
    s1 <- 0.25*(sqrt(10+2*sqrt(5)))
    s2 <- 0.25*(sqrt(10-2*sqrt(5)))

    par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-s1,s1),ylim=c(-c2,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Hexagon:EXTEND            #
    #############################
    if (input$shape == "hex") {

      alpha <- 0.5
      beta  <- sqrt(3)/2

      par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-beta,beta),ylim=c(-2*alpha,2*alpha),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    ############################################################################
    ### APPLIED TO ALL
    if (!is.null(input$extend)) {
    if (input$extend!=0) {
    points(coords[1:input$extend,1],coords[1:input$extend,2],pch=20,cex=1,col="blue")
    }
    }

    points(loci[,2],loci[,3],pch=20,cex=2,col="red")

  }) # extendPlot's renderPlot

##################################
# compPlot                       #
##################################
  output$compPlot <- renderPlot({

    loci      <- all.list()[[1]]
    vertices  <- all.list()[[2]]
    coords    <- all.list()[[3]]

    #############################
    # Triangle:COMPLETE         #
    #############################
    if (input$shape == "tri") {

        par(mar=c(0.5,0.5,0.5,0.5))
    plot(0,0,xlim=c(0,1),ylim=c(0,sqrt(3)/2),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Square:COMPLETE           #
    #############################
    if (input$shape == "sqr") {

        par(mar=c(0.5,0.5,0.5,0.5))
    plot(0,0,xlim=c(0,1),ylim=c(0,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Pentagon:COMPLETE         #
    #############################
    if (input$shape == "pent") {

      c1 <- 0.25*(sqrt(5)-1)
      c2 <- 0.25*(sqrt(5)+1)
      s1 <- 0.25*(sqrt(10+2*sqrt(5)))
      s2 <- 0.25*(sqrt(10-2*sqrt(5)))

      par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-s1,s1),ylim=c(-c2,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Hexagon:COMPLETE          #
    #############################
    if (input$shape == "hex") {

      alpha <- 0.5
      beta  <- sqrt(3)/2

      par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-beta,beta),ylim=c(-2*alpha,2*alpha),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    ##############################################################################
    ### APPLIED TO ALL
    if (!is.null(input$pts)) {
      if (input$pts!=0) {
    points(coords[1:input$pts,1],coords[1:input$pts,2],pch=".",cex=2.5,col="blue")
      }
    }
    points(loci[,2],loci[,3],pch=20,cex=2,col="red")

  }) # compPlot's renderPlot

})


# Quick test to see how gradient boosting with binary relevance performs

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

Cores = 31
TempDir = "../../userdata/temp/"
OutputDir = "../../userdata/predictions/"

alldata = LoadClassificationData()
TrainingData = alldata[,GetTrainingNames(exclude=c("osavi", "aspect", "is.water", "height"))]
TrainingRasters = LoadTrainingRasters()

GBRP = function(Model, blockvals, ...)
{
    PredRaw = predict(Model, newdata=as.matrix(blockvals), ...)
    return(PredRaw)
}

AllPredictions = stack()
print("Starting prediction phase 1...")
for (Class in GetValidationNames())
{
    print(Class)
    TrainMatrix = xgb.DMatrix(as.matrix(TrainingData@data), label=alldata@data[,Class]/100)
    Model = xgboost(TrainMatrix, nrounds=50, objective="reg:logistic")

    print(system.time(predicted <- predict(TrainingRasters, Model, fun=GBRP,
        filename=paste0(TempDir, Class, ".grd"), progress="text", overwrite=TRUE)))

    AllPredictions = stack(AllPredictions, predicted)
}

print("Starting prediction phase 2...")
RasterScaling = function(x)
{
    return(round(x / sum(x) * 100))
}
system.time(ScaledPredictions <- calc(AllPredictions, RasterScaling, progress="text"))
names(ScaledPredictions) = GetValidationNames()
print("Writing...")
ScaledPredictions = writeRaster(ScaledPredictions, filename = paste0(OutputDir, "gbregression-gblinear.tif"),
    datatype="INT1U", options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4"), overwrite=TRUE)


#Let's build a dataset : height of 10 sorgho and poacee sample in 3 environmental conditions (A, B, C)
A=c(rep("sorgho" , 10) , rep("poacee" , 10) )
B=rnorm(20,10,4)
C=rnorm(20,8,3)
D=rnorm(20,5,4)
data=data.frame(A,B,C,D)
colnames(data)=c("specie","cond_A","cond_B","cond_C")

#Let's calculate the average value for each condition and each specie with the *aggregate* function
bilan=aggregate(cbind(cond_A,cond_B,cond_C)~specie , data=data , mean)
rownames(bilan)=bilan[,1]
bilan=as.matrix(bilan[,-1])

#Then it is easy to make a classical barplot :
lim=1.2*max(bilan)
ze_barplot = barplot(bilan , beside=T , legend.text=T , col=c("blue" , "skyblue") , ylim=c(0,lim))

#I becomes a bit more tricky when we want to add the error bar representing the confidence interval.
#First I create a smell function that takes...in entry
error.bar <- function(x, y, upper, lower=upper, length=0.1,...){
  arrows(x,y+upper, x, y-lower, angle=90, code=3, length=length, ...)
}

#Then I calculate the standard deviation for each specie and condition :
stdev=aggregate(cbind(cond_A,cond_B,cond_C)~specie , data=data , sd)
rownames(stdev)=stdev[,1]
stdev=as.matrix(stdev[,-1]) * 1.96 / 10

I am ready to add the error bar on the plot using my "error bar" function !
png("#4_barplot_with_IC.png" ,  width = 480, height = 480)
ze_barplot = barplot(bilan , beside=T , legend.text=T ,
                  col=c("blue" , "skyblue") , ylim=c(0,lim) , ylab="height")
error.bar(ze_barplot,bilan, stdev)
dev.off()


source("4-mapping-pointdata.r")
#proj4string(OA.Census) <- CRS("+init=EPSG:27700")
#proj4string(House.Points) <- CRS("+init=EPSG:27700")

# Declaire points in polygon
pip <- over(House.Points, OA.Census)

#This is the function of the libarary spover package, used to connect spatial points

# include pip into the dataset
House.Points@data <- cbind(House.Points@data, pip)

#View(House.Points@data)

# plot the relationshiop between price and unemployment
plot(log(House.Points@data$Price), House.Points@data$Unemployed)

# because there is many house to be sold in one place (polygon), we now care about the average housing for each polygon

OA <- aggregate(House.Points@data$Price, by = list(House.Points@data$OA11CD), mean)

# rename it
names(OA) <- c("OA11CD", "Price")

# include this into OA.Cencus
OA.Census@data <- merge(OA.Census@data, OA, by = "OA11CD", all.x = TRUE)

head(OA.Census@data)

### plot on the map
tm_shape(OA.Census) +
  tm_fill(col = "Price", style = "quantile", title = "Mean House Price (£)")

## regression model

model <- lm(OA.Census@data$Price ~ OA.Census@data$Unemployed)
summary(model)

###### Buffer.

# a buffer zone of 200 m diameter
house_buffers <- gBuffer(House.Points, width = 200, byid = TRUE)

# plot
tm_shape(OA.Census) + tm_borders() +
  tm_shape(house_buffers) + tm_borders(col = "blue") +
  tm_shape(House.Points) + tm_dots(col = "red")

# ----> unite them
union.buffers <- gUnaryUnion(house_buffers)

# map
tm_shape(OA.Census) +
  tm_borders() +
  tm_shape(union.buffers) +
  tm_fill(col = "blue", alpha = .4) +
  tm_borders(col = "blue") +
  tm_shape(House.Points)+
  tm_dots(col = "red")

###Interractive map
#tmap_mode("view")

tm_shape(House.Points) +
  tm_dots(title = "House Prices (£)", border.col = "black", border.lwd = 0.1, border.alpha = 0.2, col = "Price", style = "quantile", palette = "Reds")

tm_shape(House.Points) +
  tm_bubbles(size = "Price", title.size = "House Prices (£)", border.col = "black", border.lwd = 0.1, border.alpha = 0.4, legend.size.show = TRUE)

tm_shape(OA.Census) +
  tm_fill("Qualification", palette = "Reds", style = "quantile", title = "% with a Qualification") +
  tm_borders(alpha=.4)

#ttm() #stop interactive
##


library(survival)
options(warn=-1)

Args<-commandArgs()
in_file<-Args[6]
#out_file<-Args[7]
out_textfile<-Args[7]
cutoff<-as.numeric(Args[8])
#pvalue<-as.numeric(Args[10])

data<-read.table(in_file, header=T, com='', sep="\t")
data$Exp <- as.numeric(as.character(data$Exp))
data$Time <- as.numeric(as.character(data$Time))
data$strata = data$Exp <= cutoff
s<-Surv(data$Time, data$Status == 1)
km <- survfit(s~(data$strata), conf.type = "log-log")
sm = summary(km, censored=T)
m <- cbind(sm$time, sm$surv, sm$strata, sm$n.event, sm$n.censor)
#summary(km)$n.censor
write.table(m, out_textfile, sep="\t", row.names=FALSE, col.names=FALSE)
#svg(out_file)
#plot(km, xlab="Time ( Days )",ylab="Probability of survival",lty = 1:1,lwd=3:3, col=c("red","blue"))
hight_num = sum(data$Exp > cutoff)
low_num = sum(data$Exp <= cutoff)
cat(hight_num,low_num)
#group = c(paste("High (", hight_num, ")"), paste("Low (", low_num, ")"))
#legend("topright", legend=unique(group), col=c("red","blue"), lty = 1:1,lwd=3:3, horiz=FALSE, bty='n')
#title(main=paste("Exp-cutoff =  ", cutoff, " ; p-value = ",  pvalue))
#dev.off()


#' @export
#' @title ellipse.2d
#' @description This function calculates a 2D kernel density then plot highest density regions with contour().
#' @param \code{x}
#' @param \code{y}
#' @param \code{pv} the density of the region to be outlined - defaults to 95 percent (i.e. 0.05)
#' @param \code{sc} a scaling factor? defaults to 50
#' @references \url{https://stat.ethz.ch/pipermail/r-help/2000-March/005973.html}
#' @family  plotting
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
ellipse.2d = function( x, y, pv=0.05, sc=50 ) {
  library(KernSmooth)
  xr = range( x, na.rm=T)
  yr = range( y, na.rm=T)
  dx = (xr[2] - xr[1] ) / sc
  dy = (yr[2] - yr[1] ) / sc
  z = bkde2D(cbind(x,y), bandwidth=c(dx,dy))
  zsort <- sort(z$fhat)
  p <- cumsum(zsort)/sum(zsort)
  contour(z$x1, z$x2, z$fhat, levels=min(zsort[p>=pv]), add=T, labels="", drawlabels=F )
  # points(x,y, pch=20)
}


  ## Avoid printing to unwarranted accuracy
  od <- options(digits = 5)
  x <- 0:10
  y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)

  ## Easy one-dimensional MLE:
  nLL <- function(lambda) -sum(stats::dpois(y, lambda, log = TRUE))
  fit0 <- mle(nLL, start = list(lambda = 5), nobs = NROW(y))
  # For 1D, this is preferable:
  fit1 <- mle(nLL, start = list(lambda = 5), nobs = NROW(y),
              method = "Brent", lower = 1, upper = 20)
  stopifnot(nobs(fit0) == length(y))

  ## This needs a constrained parameter space: most methods will accept NA
  ll <- function(ymax = 15, xhalf = 6) {
    if(ymax > 0 && xhalf > 0)
      -sum(stats::dpois(y, lambda = ymax/(1+x/xhalf), log = TRUE))
    else NA
  }
  (fit <- mle(ll, nobs = length(y)))
  mle(ll, fixed = list(xhalf = 6))
  ## alternative using bounds on optimization
  ll2 <- function(ymax = 15, xhalf = 6)
    -sum(stats::dpois(y, lambda = ymax/(1+x/xhalf), log = TRUE))
  mle(ll2, method = "L-BFGS-B", lower = rep(0, 2))

  AIC(fit)
  BIC(fit)

  summary(fit)
  logLik(fit)
  vcov(fit)
  plot(profile(fit), absVal = FALSE)
  confint(fit)

  ## Use bounded optimization
  ## The lower bounds are really > 0,
  ## but we use >=0 to stress-test profiling
  (fit2 <- mle(ll, method = "L-BFGS-B", lower = c(0, 0)))
  plot(profile(fit2), absVal = FALSE)

  ## a better parametrization:
  ll3 <- function(lymax = log(15), lxhalf = log(6))
    -sum(stats::dpois(y, lambda = exp(lymax)/(1+x/exp(lxhalf)), log = TRUE))
  (fit3 <- mle(ll3))
  plot(profile(fit3), absVal = FALSE)
  exp(confint(fit3))

  options(od)


# source("rf.my.r");

# run customized random forest and return testing dataset confusion matrix

library(randomForest)
source("getKappa.r");

rf.my <- function(xtrain, ytrain, xtest, ytest) {

	yftrain <- factor(ytrain);
	yftext  <- factor(ytest );
	ntrees <- 500;
	# iris.rf2 <- randomForest(x=xtrain, y=yftrain,  xtest=xtest, ytest=yftext, importance=TRUE, replace=FALSE, ntree=ntrees, keep.forest=TRUE, keep.inbag=TRUE);
	iris.rf2 <- randomForest(x=xtrain, y=yftrain,  xtest=xtest, ytest=yftext, replace=FALSE, ntree=ntrees);

	classn <- length(iris.rf2$classes)
	conf <- mat.or.vec(classn+2,classn+2);

	## Notice here is the swith
	tempconf = iris.rf2$test$confusion;
	# tempconf = iris.rf2$confusion;

	colnames(conf) <- c(colnames(tempconf)[1:classn],"Total","User's accuracy");
	rownames(conf) <- c(rownames(tempconf)[1:classn],"Total","Producer's accuracy");
	conf[1:(classn),1:(classn)] <- tempconf[1:(classn),1:(classn)];
	conf[classn+1,1:classn] <- colSums(conf[1:classn,1:classn])
	conf[classn+2,1:classn] <- diag(conf[1:classn,1:classn])/conf[classn+1,1:classn];
	conf[1:classn,classn+1] <- rowSums(conf[1:classn,1:classn])
	conf[1:classn,classn+2] <- diag(conf[1:classn,1:classn])/conf[1:classn,classn+1];
	conf[classn+1,classn+1] <- sum(conf[1:classn,classn+1]);
	conf[classn+2,classn+2] <- sum(diag(conf[1:classn,1:classn]))/sum(conf[1:classn,classn+1]);

	##kappa
	qqq <- conf[classn+1,1:classn]/conf[classn+1,classn+1]
	ppp <- conf[1:classn,classn+1]/conf[classn+1,classn+1]
	expAccuracy <- sum(ppp*qqq)
	kappaa <- (conf[classn+2,classn+2] - expAccuracy)/(1 - expAccuracy);
	OA <- conf[classn+2,classn+2];
	conf[classn+1,classn+2] <- kappaa;

    conf <- conf*100;

	OA <- sum(iris.rf2$predicted==yftrain)/length(yftrain);
	# source("getKappa.r");
	# kappaa <- getKappa(iris.rf2$predicted, yftrain);
	print(paste("kappaa =", sprintf("%.4f", kappaa), "OA =", sprintf("%.2f", OA*100)  ));

	list("Kappa"=kappaa, "Accuracy"=OA, "Confusion"=conf);
}


library(gtools)

# permutation function
permu <- function(n, m){
    t(combn(1:n, m, FUN=function(y){
        replace(rep(0,n), y, 1)
    }))
}
#permu(4,2)

# robustness test function
robust = function(data, dim_lib_var, lags){
    n = NROW(data) # length of time series
    num_var = NCOL(data[, -1]) # number of variables, first one is library variable
    lib_var = names(data)[1]

    # a mask data frame to choose variables
    mask = data.frame(permu(num_var, dim_lib_var-1))
    coeff.mean = apply(mask, 1, FUN=function(x){
        vars = names(data)[-1][x==1] # variables chosen in this permutation
        lags = lags[x==1] # lags of variables

        # generate lagged variable
        block.m = subset(data, select = vars)
        block.m = apply(matrix(seq_along(lags)), 1, FUN=function(y){
            if (lags[y] > 0){
                c(rep(NA,lags[y]), block.m[, y][-c((n-lags[y]+1):n)])
            } else {block.m[, y]}
        })
        block.m = cbind(subset(data, select=lib_var), block.m)

        # find the optimal theta
        theta = c(0, 1e-04, 3e-04, 0.001, 0.003, 0.01, 0.03,
                  0.1, 0.3, 0.5, 0.75, 1, 1.5, 2, 3, 4, 6, 8)
        rho.theta = data.frame(matrix(0, length(theta), 2))
        colnames(rho.theta) = c('theta', 'rho')
        rho.theta[, 'theta'] = theta

        # compute rho under each theta
        for (i in 1:length(theta)){
            block_lnlp_output <- block_lnlp(block.m, columns = c(1:dim(block.m)[2]), target_column = 1,
                                            tp = 1, method = "s-map", num_neighbors = 0, stats_only = F,
                                            theta = rho.theta[i, 'theta'], save_smap_coefficients = T)
            rho.theta[i, 'rho'] = block_lnlp_output$rho
        }
        theta.opt = rho.theta$theta[which.max(rho.theta$rho)]

        block_lnlp_output <- block_lnlp(block.m, columns = c(1:dim(block.m)[2]), target_column = 1,
                                        tp = 1, method = "s-map", num_neighbors = 0, stats_only = F,
                                        theta = theta.opt, save_smap_coefficients = T)
        coeff = data.frame(block_lnlp_output$smap_coefficients[[1]])  # s-map coefficient
        coeff.m = colMeans(coeff[, -c(1, dim(coeff)[2]), drop = FALSE], na.rm = T)

        # S-map coefficients
        x1 = x
        x1[which(x1==0)] = NA
        x1[which(x1==1)] = coeff.m

        rho = block_lnlp_output$rho

        # test on the significance of rho
        n_pred = block_lnlp_output$num_pred
        t = rho*sqrt(n_pred-2)/sqrt(1-rho^2)
        if (t >= 0){
            pvalue = 1 - pt(t, df = n_pred-2)
        } else {
            pvalue = pt(t, df = n_pred-2)
        }

        return(c(x1, theta.opt, rho, pvalue))  # c(coefficients, theta, rho, pvalue)
    })
    output = data.frame(t(coeff.mean))
    colnames(output) = c(names(data)[-1], 'theta', 'rho', 'pvalue')

    return(output)
}

## robustness test on each lag
smap_each_lag = function(raw_data, embed_dim, lib_var, ccm_most_sig, ccm_sig){
    num_sample = dim(raw_data)[1]
    num_variable = embed_dim
    ccm_result = ccm_most_sig[1:(num_variable-1), ]

    smap_data = data.frame(matrix(0, nrow = num_sample, ncol = 0))
    smap_data[, lib_var] = raw_data[lib_var]

    output = data.frame(0)
    for (i_var in 1:(num_variable-1)){
        select_var = as.character(ccm_result$target[i_var])
        ccm_select_var = subset(ccm_sig, subset=ccm_sig$target==select_var)
        ccm_temp = ccm_result[-i_var, ]

        num_remain_var = dim(ccm_temp)[1]
        if (num_remain_var > 0){
            for (j_var in 1:num_remain_var){
                vars = as.character(ccm_temp$target[j_var])
                lags = abs(ccm_temp$tar.lag[j_var])
                smap_data[, vars] = c(rep(NA,lags), raw_data[, vars][1:(num_sample-lags)])
            }
        }

        num_lag = dim(ccm_select_var)[1]
        for (j_var in 1:num_lag){
            lags = abs(ccm_select_var$tar.lag[j_var])
            smap_data[, select_var] = c(rep(NA,lags), raw_data[, select_var][1:(num_sample-lags)])

            smap_result_list = performSmap(smap_data)

            coeff = smap_result_list$coefficients
            smap_mean = data.frame(lag=lags,
                                   lag_var=select_var,
                                   data.frame(as.list(colMeans(coeff, na.rm=TRUE))),
                                   rho=smap_result_list$rho,
                                   pvalue=smap_result_list$pvalue,
                                   theta=smap_result_list$theta)
            output = merge(output, smap_mean, all=TRUE, sort=FALSE)
        }
    }
    return(output)
}

## aggregate results of robustness test on each lag
aggregate_each_lag = function(results){
    # keep significant results
    sig_results = subset(results, subset=results[['pvalue']] < 0.1)

    # remove duplicated results
    results_for_var = subset(sig_results, select=-c(lag, lag_var, theta, rho, pvalue))
    duplicated_row = duplicated(results_for_var)
    results_for_var = results_for_var[!duplicated_row, , drop=FALSE]

    # take average results for each variable
    if (nrow(results_for_var) > 0){
        return(colMeans(results_for_var))
    } else {
        return(NULL)
    }
}


#library(psych)
#library(xlsx)
library(cluster)
#library(RColorBrewer)
library(data.table)
library(dendextend)
library(ggplot2)
#library(NbClust)
library(scales)
library(extrafont)
library(gridExtra)
library(stats)
#setwd('Projects/covid-analysis/')

d <- read.csv('../../results/disimilarity-matrix-mobility-google.csv',row.names = 1)
num_clust = 4
clusterFit <- function(dm, m) {
  fit <- hclust(as.dist(dm), method=m) # apply hierarchical clustering
  #fit$labels = f8scores$city
  return(fit)
}

## Get clustering for 8 and 9-factor solutions
results = clusterFit(transpose(d), "ward.D")

#optClustWardScaled9 <- NbClust(as.data.frame(scaled.f9scores),distance="manhattan", method="ward.D2",min.nc=10,max.nc=15,index="gap")
#fitness_metrics <- NbClust(diss=as.matrix(transpose(d)), distance=NULL,method="ward.D2",min.nc=7) #,index="all")
#needs to be fixed...

## Group countries into clusters based on number of clusters desired
getClusters <- function (clusfit, k, labels) {
  #cluster <- dendextend:::cutree(clusfit, k, order_clusters_as_data = TRUE)
  cluster = cutree(clusfit, k)
  clusters = data.frame(cluster)
  row.names(clusters) = labels
  return(clusters)
}

clustered.data <- getClusters(results, num_clust, row.names(d)) #f9scores only for names!!
clustered.data.ordered <- clustered.data[order(clustered.data$cluster),,drop=FALSE]
write.csv(clustered.data.ordered, "../results/country-clusters.csv")

colors = c( # '#ffff99', ##d8ac93', # '#ffff99', #or yellowversions
    '#66c2a5',
    '#fc8d62',
    '#8da0cb',
    '#e78ac3',
    '#a6d854',
    '#ffd92f',
    '#e5c494')

colors = colors[1:num_clust]

dendtypolist = c('C1', 'C2', 'C3', 'C4', 'C5', 'C6', 'C7')

##################################################################################################################
#### Plot dendrogram
##################################################################################################################
# https://gist.github.com/jslefche/eff85ef06b4705e6efbc
theme_black = function(base_size = 12, base_family = "") {

  theme_grey(base_size = base_size, base_family = base_family) %+replace%

    theme(
      # Specify axis options
      axis.line = element_blank(),
      axis.text.x = element_text(size = base_size*0.8, color = "white", lineheight = 0.9),
      axis.text.y = element_text(size = base_size*0.8, color = "white", lineheight = 0.9),
      axis.ticks = element_line(color = "white", size  =  0.2),
      axis.title.x = element_text(size = base_size, color = "white", margin = margin(0, 10, 0, 0)),
      axis.title.y = element_text(size = base_size, color = "white", angle = 90, margin = margin(0, 10, 0, 0)),
      axis.ticks.length = unit(0.3, "lines"),
      # Specify legend options
      legend.background = element_rect(color = NA, fill = "black"),
      legend.key = element_rect(color = "white",  fill = "black"),
      legend.key.size = unit(1.2, "lines"),
      legend.key.height = NULL,
      legend.key.width = NULL,
      legend.text = element_text(size = base_size*0.8, color = "white"),
      legend.title = element_text(size = base_size*0.8, face = "bold", hjust = 0, color = "white"),
      legend.position = "right",
      legend.text.align = NULL,
      legend.title.align = NULL,
      legend.direction = "vertical",
      legend.box = NULL,
      # Specify panel options
      panel.background = element_rect(fill = "black", color  =  NA),
      panel.border = element_rect(fill = NA, color = "white"),
      panel.grid.major = element_line(color = "grey35"),
      panel.grid.minor = element_line(color = "grey20"),
      panel.margin = unit(0.5, "lines"),
      # Specify facetting options
      strip.background = element_rect(fill = "grey30", color = "grey10"),
      strip.text.x = element_text(size = base_size*0.8, color = "white"),
      strip.text.y = element_text(size = base_size*0.8, color = "white",angle = -90),
      # Specify plot options
      plot.background = element_rect(color = "black", fill = "black"),
      plot.title = element_text(size = base_size*1.2, color = "white"),
      plot.margin = unit(rep(1, 4), "lines")

    )

}

plotD <- function (clusfit,kk,meth,labels)
{
  nodeP <- list(lab.cex = 0.8, pch = c(NA, NA), cex = 1.5,font=1)
  dend <- as.dendrogram(clusfit)
  #dend <- reorder(dend, 1:13, mean)
  labels(dend) <- as.character(labels[clusfit$order])
  dend <- set(dend, "labels_cex", .65)
  #dend <- set(dend, "hang_leaves", 1)
  d1=color_branches(dend,k=kk,col = colors) # brewer.pal(kk,"Paired"))
  dcol <- get_leaves_branches_col(d1)
  d1 <- color_labels(d1,k=kk,col=colors) #brewer.pal(kk,"Paired"))
  #png(file=paste0("../results/Dendrogram-",kk,"-clusters-","-Method-",meth,".png"),family="CM Sans", width=2400,height=2000, res=240) #5300 #2600
  plot(d1)
  #colored_bars(dcol, dend, rowLabels = c("13 Typologies"))
  #dev.off()
}

plotD(results,num_clust,"Ward.D2",row.names(d))

# plotDgg <- function (clusfit,kk,meth,scores,ff)
# {
#   dend <- as.dendrogram(clusfit)
#   dend <- assign_values_to_branches_edgePar(dend=dend, value = "white", edgePar = "col")
#   dend <- color_branches(dend,k=kk,col = colors) # brewer.pal(kk,"Paired"))
#   ggd1 <- as.ggdend(dend)
#   base <- ggplot(ggd1,labels=FALSE)
#   base +
#     geom_hline(yintercept=6.2, color="gray",lty=2,lwd=1) +
#     geom_hline(yintercept=3.6, color="gray",lty=3,lwd=1) +
#     theme_black() +
#     theme(panel.border = element_blank(),
#             panel.grid.major = element_blank(),
#             panel.grid.minor = element_blank(),
#             axis.title=element_blank(),
#             axis.ticks=element_blank(),
#             axis.text=element_blank(),
#             legend.position=c(0,1)
#           )
# }
# p1 <- plotDgg(results,num_clust,"Ward.D2",row.names(d))

# idx = c(1:length(row.names(d)))
# df2<-data.frame(cluster=cutree(results,num_clust) ,states=factor(idx)) #,levels=idx)) #[clusfit9scaled.ward$order]))
# head(df2)
# df3 <- df2[order(df2$cluster),]
# df3$states <- factor(1:length(row.names(d)))
# df3$cluster <- factor(df3$cluster, labels = dendtypolist[1:num_clust])

# p2 <- ggplot(df3,aes(states,y=1,fill=factor(cluster)))+
#   geom_tile()+
#   #scale_y_continuous(expand=c(0,0)) +
#   scale_fill_manual(values = colors,breaks=dendtypolist[1:num_clust])+
#   #scale_fill_discrete( #+ scale_fill_manual(values = colors)+
#   theme(axis.title=element_blank(),
#         axis.ticks=element_blank(),
#         axis.text=element_blank(),
#         legend.position=c(.85,9.3),
#         legend.title=element_blank(),
#         legend.text = element_text(colour="white", size=16),
#         legend.key.size = unit(1.5, 'lines'),
#         legend.key = element_rect(fill = "gray", colour = "transparent"),
#         legend.background = element_rect(fill = "transparent", colour = "transparent")
#         )

# ggplotGrob(p1)
# #gp2<-ggplotGrob(p2)

# #maxWidth = grid::unit.pmax(gp1$widths[2:5], gp2$widths[2:5])
# #gp1$widths[2:5] <- as.list(maxWidth)
# #gp2$widths[2:5] <- as.list(maxWidth)

# loadfonts()
# png(file=paste0("results/Dendrogram-GG-",num_clust,"-clusters-","-Method-","Ward.D2",".png"),family="CM Sans",width=1200,height=1000,res=100)
# #grid.arrange(gp1, gp2, ncol=1,heights=c(9/10,1/10))

# dev.off()


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     06.12.2019
#modificado: 09.12.2019

library("OneR")

trainset <- read.csv("../data/golf.csv",header=TRUE)
testset <- read.csv("../data/golf-testset.csv",header=TRUE)

#Discretize numerical variables
trainset <- bin(trainset,              #training set
                nbins=2)               #binning by intervals of equal length
testset <- bin(testset,                #training set
                nbins=2)               #binning by intervals of equal length

#Perform Decision Rule fit
mod <- OneR(Play ~.,                   #model design
            trainset)                  #training set

#Summarize model
summary(mod)

#Test model
res <- predict(mod,                    #model
               testset,                #testing set
               type="class")           #returns classification/probabilities

#Confusion Matrix
conf_mat <- table(testset[,"Play"],res)
conf_mat

#Error rate
err_rt <- 100*(sum(conf_mat) - sum(diag(conf_mat)))/sum(conf_mat)
err_rt


A -> D (3): 3
A -> B (3): 3
A -> C (0): 0
B -> C (4): 4
B -> A (0): 0
B -> E (0): 0
C -> A (3): 3
C -> D (1): 1
C -> E (2): 2
C -> B (0): 0
D -> E (2): 2
D -> F (6): 6
D -> A (0): 0
D -> C (0): 0
E -> B (1): 1
E -> C (0): 0
E -> D (0): 0
F -> D (0): 0


#Decision trees
#Examples illustrate the major algorithmic operations
#related to decision trees using the weather data, the small size of which makes
#it easy to manually verify the results. to illustrate continuous attribute handling,
#the weatherc data will be used. The following code prepares the environment for
#subsequent examples by loading the datasets as well as DMR and CRAN packages that
#will be needed

setwd("/home/users/chojnar1/Desktop/STUD/MOW/Book/Packages") #set the working directory to the path of the packages
pkgs <- list.files()
print(pkgs)

install.packages(c(print(as.character(pkgs), collapse="\",\"")), repos = NULL)

library(dmr.claseval)
library(dmr.stats)
library(dmr.util)
library(rpart)
library(rpart.plot)
library(lattice)
data(weather, package="dmr.data")
data(weatherc, package="dmr.data")

install.packages("/home/users/chojnar1/Desktop/STUD/MOW/Book/Packages/dmr.rpart",
repos = NULL, type = "source")

dtdat <- expand.grid(a1=seq(1, 10, 3), a2=seq(1, 10, 3))
dtdat$c <- as.factor(ifelse(dtdat$a1<=7 & dtdat$a2<=1, 1,
                            ifelse(dtdat$a1<=7 & dtdat$a2<=7, 2,
                                   ifelse(dtdat$a1<=7, 3,
                                          ifelse(dtdat$a2<=4, 4, 5)))))
  # decision tree structure
prp(rpart(c`., dtdat, minsplit=2, cp=0))
  # the corresponding domain decomposition
levelplot(c`a1*a2, dtdat, at=0.5+0:5, col.regions=gray(seq(0.1, 0.9, 0.1)),
          colorkey=list(at=0.5+0:5))

##############################################################################
data <- weather
attributes <- names(weather)[1:4]
print(attributes)
class <- names(weather)[5]
print(class)

init <- function()
{
  clabs <<- factor(levels(data[[class]]),
                   levels=levels(data[[class]]))      # class labels
  tree <<- data.frame(node=1, attribute=NA, value=NA, class=NA, count=NA,
                      `names<-`(rep(list(NA), length(clabs)),
                                paste("p", clabs, sep=".")))
  cprobs <<- (ncol(tree)-length(clabs)+1):ncol(tree)  # class probability columns
  nodemap <<- rep(1, nrow(data))
  n <<- 1
}
init()

#pdisc function for estimating discrete probability distributions
#to implement class probability calculation for a decision tree node
class.distribution <- function(n)
{
  tree$count[tree$node==n] <<- sum(nodemap==n)
  tree[tree$node==n,cprobs] <<- pdisc(data[nodemap==n,class])
}
print(class.distribution(n))

class.label <- function(n)
{
  tree$class[tree$node==n] <<- which.max(tree[tree$node==n,cprobs])
}
class.label(n)
print(class.label(n))

maxprob <- 0.999
minsplit <- 2
maxdepth <- 8
stop.criteria <- function(n)
{
  n>=2^maxdepth || tree$count[tree$node==n]<minsplit ||
    max(tree[tree$node==n,cprobs])>maxprob
}
print(stop.criteria(n))


#' Covariance
#'
#' An optimized, efficient implemntation for computing covariance.
#'
#' @details
#' See \code{?coop-package} for implementation details.
#'
#' @param x
#' A numeric dataframe/matrix or vector.
#' @param y
#' A vector (when \code{x} is a vector) or missing (blank) when
#' \code{x} is a matrix.
#' @param use
#' The NA handler, as in R's \code{cov()} and \code{cor()}
#' functions.  Options are "everything", "all.obs", and
#' "complete.obs".
#' @param inplace
#' Logical; if \code{TRUE} then the method used is slower but
#' uses less memory than if \code{FALSE}.  See \code{?coop-package}
#' for details.
#' @param inverse
#' Logical; should the inverse covariance matrix be returned?
#'
#' @return
#' The covariance matrix.
#'
#' @examples
#' x <- matrix(rnorm(10*3), 10, 3)
#'
#' coop::pcor(x)
#' coop::pcor(x[, 1], x[, 2])
#'
#' @author Drew Schmidt
#' @seealso \code{\link{cosine}}
#' @name covar
#' @rdname covar
NULL

#' @rdname covar
#' @export
covar <- function(x, y, use="everything", inplace=FALSE, inverse=FALSE) UseMethod("covar")

#' @export
covar.matrix <- function(x, y, use="everything", inplace=FALSE, inverse=FALSE)
{
  co_matrix(x, y, CO_VAR, use, inplace, trans=FALSE, inverse=inverse)
}

#' @export
covar.data.frame <- function(x, y, use="everything", inplace=FALSE, inverse=FALSE)
{
  x_mat = as.matrix(x)
  if (!missing(y) && is.data.frame(y))
    y = as.matrix(y)

  covar.matrix(x_mat, y, use=use, inplace=inplace, inverse=inverse)
}

#' @export
covar.default <- function(x, y, use="everything", inplace=FALSE, inverse=FALSE)
{
  co_vecvec(x, y, CO_VAR, use)
}

### tcovar

#' @rdname covar
#' @export
tcovar <- function(x, y, use="everything", inplace=FALSE, inverse=FALSE) UseMethod("tcovar")

#' @export
tcovar.matrix <- function(x, y, use="everything", inplace=FALSE, inverse=FALSE)
{
  co_matrix(x, y, CO_VAR, use, inplace, trans=TRUE, inverse=inverse)
}

#' @export
tcovar.data.frame <- function(x, y, use="everything", inplace=FALSE, inverse=FALSE)
{
  x_mat = as.matrix(x)
  if (!missing(y) && is.data.frame(y))
    y = as.matrix(y)

  tcovar.matrix(x_mat, y, use=use, inplace=inplace, inverse=inverse)
}


# A scaffolding for a mixed ANOVA in R

library(reshape2)
library(car)
library(dplyr)
library(ez)
library(knitr)

# Read in the data
data = read.csv2('YOUR_FILE', sep=',', encoding='1250')

# Slice the original frame if needed
data <- data %>% select(YOUR_COLUMNS)

# Convert some data into factors if needed
data$sex <- factor(data$sex, levels=c(0, 1), labels=c('Female', 'Male'))

# Rename your subject ID column if needed
colnames(data)[1] <- 'subject'

# Melt the dataframe (`id` takes your BETWEEN-SUBJECT vars, `measured` takes your WITHIN-SUBJECT vars)
data_long <- melt(data, id=c('subject', 'grp', 'fdbk', 'sex'), measured=c('compet', 'cooper'))

# Rename melted (WITHIN) cols if needed:
colnames(data_long)[5] <- 'Choice'
colnames(data_long)[6] <- 'Rank'

# Perform Levene's Test
leveneTest(Rank ~ grp*fdbk*sex, data=data_long, center=mean)

# Perform ANOVA (Maulchy's test included):
output <- ezANOVA(data=data_long,
                  dv=Rank,
                  wid=subject,
                  within=Choice,
                  between=c(fdbk, grp),
                  detailed=TRUE,
                  type=3)

# Print results in a nice-formatted table
knitr::kable(output, digits = 2, caption = 'Anova results')


arglist <- list(x=runif(10), trim=0.1, na.rm=TRUE)
do.call(mean, arglist)


rm(list=ls())
library(fitdistrplus)
library(tidyverse)
library(cowplot)

# inference for infectiousness (results for Fig 1)

#--- data ---
# package: readxl
data = data.frame(readxl::read_xlsx("data-raw/Fig1c_data.xlsx"))
ref.date = as.Date("2020-01-01")
data$x.lb <- as.numeric(as.Date(data$x.lb)-ref.date)
data$x.ub <- as.numeric(as.Date(data$x.ub)-ref.date)
data$y <- as.numeric(as.Date(data$y)-ref.date)
data$SI.lb <- (data$y - data$x.ub) - 0.5
data$SI.ub <- (data$y - data$x.lb) + 0.5

# data: (x.lb, x.ub): lower and upper bounds of infectors symtpom onset dates
# y: symptom onset dates of infectee

#--- incubation period ---
# from Li et al NEJM 2020
# lognormal mean = 5.22; 95% CI = c(4.1, 7.0)
ln.par = c(1.434065, 0.6612)

# Initial values (taken from He et al.)
inf.par <- c()
inf.par[1] <- 2.12
inf.par[2] <- 0.69
inf.par[3] <- 12.3

# Function for calculating log-likelihood
LLfun <- function(inf.par,ln.par,data,N){
  if(inf.par[1] <= 0 | inf.par[2] <=0){ # ensure Gamma parameters are >0
    return(-Inf)
  }
  SIs <- c()
  for(i in 1:N) {
    incubs <- rlnorm(2,ln.par[1],ln.par[2]) # sample infector and infectee incubation periods
    GI <- 0 # set reference generation interval = 0
    while (GI < 0.5) { # require positive generation interval >= 1/2 a day
      inf.time <- rgamma(1,inf.par[1],inf.par[2]) - inf.par[3] # sample infection time (relative to infector symptom onset)
      SI <- inf.time + incubs[2] # serial interval
      GI <- inf.time + incubs[1] # generation interval
    }
    SIs[i] <- SI
  }
  SI.par <- fitdist(SIs+inf.par[3], "lnorm")$estimate # fit a lognormal distribution to empirical SI distribution
  # Likelihood calculations:
  Lik <- plnorm(data$SI.ub + inf.par[3],SI.par[1],SI.par[2]) - plnorm(data$SI.lb + inf.par[3],SI.par[1],SI.par[2])
  LLik <- sum(log(Lik))
  return(LLik)
}

# Maximise LLfun - log-likelihood function
fit <- optim(par=inf.par,
             fn=LLfun,
             ln.par=ln.par,
             data=data,
             N=50000,
             control=list(fnscale=-1))

#####################################################
# Plotting

# A colour-blind-friendly palette
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
ln.par = c(1.434065, 0.6612)

# Gamma distribution parameters for infection time distribution
# shape = 17.773, rate = 1.388, shift = 12.979
# inf.par <- fit$par
inf.par <- c(17.773,1.388,12.979)
inf.par_He <- c(20.516508, 1.592124, 12.272481)
ser.par_He <- c(8.1237578, 0.6361684)
dgamma.shift <- function(x,min.serial,gpar1,gpar2) dgamma(x-min.serial,gpar1,gpar2)
min.serial <- -7

# Calculate empirical SI and GI distributions (as before)
N <- 100000
SIs <- c()
GIs <- c()
for(i in 1:N) {
  incubs <- rlnorm(2,ln.par[1],ln.par[2])
  GI <- 0
  while (GI < 0.5) {
    inf.time <- rgamma(1,inf.par[1],inf.par[2]) - inf.par[3]
    SI <- inf.time + incubs[2]
    GI <- inf.time + incubs[1]
  }
  SIs[i] <- SI
  GIs[i] <- GI
}

# Fit distributions to outputs
SI.ln <- fitdist(SIs+inf.par[3], "lnorm")
SI.par <- SI.ln$estimate
GI.g <- fitdist(GIs, "gamma")
GI.par <- GI.g$estimate

# Serial interval
x1 <- c(seq(0,33,0.1)-inf.par[3],seq(0,33,0.1)+min.serial)
y1 <- c(dlnorm(seq(0,33,0.1),SI.par[1],SI.par[2]),dgamma.shift(seq(-7,26,0.1)+0.5, min.serial, ser.par_He[1], ser.par_He[2]))
ref1 <- c(rep('model fit',331),rep('He et al.',331))
df1 <- tibble(x = x1, y = y1, ref=ref1)
g1 <- ggplot(df1,aes(x=x,y=y,col=ref,linetype=ref)) + geom_line(size=1.5) +
  theme_cowplot(font_size=16) +
  scale_colour_manual(values=cbPalette[c(1,5)],name="") +
  scale_linetype_manual(values=c(3,1),name="") +
  ggplot2::theme(legend.position = c(0.6,0.8), legend.key.width = unit(1,"cm")) +
  labs(tag="c",x="Serial interval (days)",y="") +
  xlim(c(-5,20)) +
  ylim(c(0,0.15))

# Infectiousness
x2 <- c(seq(0,33,0.1)-inf.par[3],seq(0,33,0.1)+-inf.par[3])
y2 <- c(dgamma(seq(0,33,0.1),inf.par[1],inf.par[2]),dgamma(seq(0,33,0.1), inf.par_He[1], inf.par_He[2]))
ref2 <- c(rep('model fit',331),rep('He et al.',331))
df2 <- tibble(x = x2, y = y2, ref=ref2)
g2 <- ggplot(df2,aes(x=x,y=y,col=ref,linetype=ref)) + geom_line(size=1.5) +
  theme_cowplot(font_size=16) +
  scale_colour_manual(values=cbPalette[c(1,5)],name="") +
  scale_linetype_manual(values=c(3,1),name="") +
  ggplot2::theme(legend.position = c(0.6,0.8), legend.key.width = unit(1,"cm")) +
  labs(tag="b",x="Time from symptom onset (days)",y="Density") +
  xlim(c(-10,15)) +
  ylim(c(0,0.15))

GI <- data.frame(gamma_sing = dgamma(seq(0,20,0.1),shape=1.819,scale=2.821),
                 gamma_china = dgamma(seq(0,20,0.1),shape=2.1217,scale=1.028))
GI2 <- data.frame(num=c(GI$gamma_sing,GI$gamma_china),x = c(seq(0,20,0.1),seq(0,20,0.1)),Source=c(rep('Ganyani et al. (1)',201),rep('Ganyani et al. (2)',201)))

# Generation interval
x3 <- rep(seq(0,20,0.1),1)
y3 <- c(dgamma(seq(0,20,0.1),GI.par[1],GI.par[2]))
ref3 <- c(rep("model fit",201))
df3 <- tibble(x = x3, y = y3, ref=ref3)
g3 <- ggplot(df3,aes(x=x,y=y,col=ref,linetype=ref)) + geom_line(size=1.5) +
  theme_cowplot(font_size=16) +
  scale_colour_manual(values=cbPalette[c(5)],name="") +
  scale_linetype_manual(values=c(1),name="") +
  ggplot2::theme(legend.position = c(0.6,0.8), legend.key.width = unit(1,"cm")) +
  labs(tag="d",x="Generation interval (days)",y="") +
  xlim(c(0,20)) +
  ylim(c(0,0.15))

# Incubation period
x4 <- rep(seq(0,20,0.1),1)
y4 <- dgamma(seq(0,20,0.1),ln.par[1],ln.par[2])
ref4 <- rep("Li et al.",201)
df4 <- tibble(x = x4, y = y4, ref=ref4)
g4 <- ggplot(df4,aes(x=x,y=y,col=ref,linetype=ref)) + geom_line(size=1.5) +
  theme_cowplot(font_size=16) +
  scale_colour_manual(values=cbPalette[c(1)],name="") +
  scale_linetype_manual(values=c(1),name="") +
  ggplot2::theme(legend.position = c(0.6,0.8), legend.key.width = unit(1,"cm")) +
  labs(tag="a",x="Time from exposure to onset (days)",y="Density") +
  xlim(c(0,10)) +
  ylim(c(0,0.4))

g4/g2 | g1/g3