library(bcf)
# Uncomment the following for the modified bcf package
# source("bcf/R/RcppExports.R")
# source("bcf/R/bcf.R")

args <- commandArgs(TRUE)
ntrain <- as.double(args[1])
ncandidate <- as.double(args[2])
n_seqential <- as.double(args[3])
sigma <- as.double(args[4]) # observation noise of y
homogeneous <- as.double(args[5]) # 1 if true
linear <- as.character(args[6]) # 1 if linear
num_cv <- as.character(args[7]) # 1 if linear
which_experiment <- as.double(args[8]) # 1 or 2

print(paste0("Beginning with num_cv = ", num_cv))
# ntrain <- 50
# ncandidate <- 2000
# sigma <- 2
# homogeneous <- 1
# linear <- 1
# n_seqential <- 1
# which_experiment <- 2
n <- ntrain + ncandidate
set.seed(num_cv)
p <- 5

# Experiment
if (which_experiment == 1) {
  source("bcf/util_experiment1.R")

  # Create covariates x
  x <- generate_x(n, p)
  x_input <- dbarts::makeModelMatrixFromDataFrame(x)

  # Compute tau, mu and pi
  mu <- prognostic_func(x, linear)
  tau <- treatment_func(x, homogeneous)
  propensity <- 0.8 * pnorm(3 * mu / sd(mu) - 0.5 * x[, 1]) + 0.05 + 0.1 * runif(n)
  z <- rbinom(n, rep(1, n), propensity)

} else if (which_experiment) {
  source("bcf/util_experiment2.R")

  # Create covariates x
  x <- generate_x(n, p)
  x_input <- dbarts::makeModelMatrixFromDataFrame(x)

  # Compute tau, mu and pi
  # RIC
  mu <- prognostic_func(x, linear)
  tau <- treatment_func(x, mu)
  propensity <- 0.6 * pnorm(mu - mean(mu), 0, 0.75 * sd(mu)) + 0.2
  z <- rbinom(n, rep(1, n), propensity)

}

# Model:
# Y_i = f(x_i, Z_i) + epsilon_i
# epsilon_i ~ N(0, sigma^2)
# f(x_i, z_i) = mu(x_i) + tau(x_i) * z_i
Ey <- mu + tau * z
noiseVar <- sigma * sd(Ey)
y <- Ey + noiseVar*rnorm(n)

# If pi is unknown, we would need to estimate it here
# pihat <- propensity
library(nnet)
x.mod <- dbarts::makeModelMatrixFromDataFrame(data.frame(x))
fitz <- nnet(z~., data = x.mod, size = 4, rang = 0.1, maxit = 1000, abstol = 1.0e-8, decay = 5e-2, trace=FALSE)
pihat <- fitz$fitted.values

# BCF
# bcf_fit <- bcf(y[1:ntrain], z[1:ntrain], x_input[1:ntrain, ], x_input[1:ntrain, ], pihat[1:ntrain], nburn=2000, nsim=2000, nthin= 5)
bcf_fit <- bcf(y[1:ntrain], z[1:ntrain], x_input[1:ntrain, ], x_input[1:ntrain, ], pihat[1:ntrain], 10000, 3000)

# Get posterior samples of treatment effects
tau_post <- bcf_fit$tau
tauhat <- colMeans(tau_post)
# plot(tau[1:ntrain], tauhat); abline(0,1)

# Posterior of the averaged treatment effects
print(paste0("Mean of |CATE - CATE_hat|: ", mean(abs(tau[1:ntrain] - tauhat))))

if (homogeneous == 1 & which_experiment == 1){
  # Sample ATE
  y_treated <- bcf_fit$yhat
  y_controled <- bcf_fit$yhat
  y_treated[z == 0] <- (y_treated + tauhat)[z == 0]
  y_controled[z == 1] <- (y_controled - tauhat)[z == 1]
  sate <- mean(y_treated - y_controled)
  true_sate <- mean(tau[1:ntrain])
  print(paste0("True ATE: ", true_sate, " . Estimated: ", sate, ". Abs. diff: ", abs(sate - 3)))
} else {
  y_treated <- bcf_fit$yhat
  y_controled <- bcf_fit$yhat
  y_treated[z == 0] <- (y_treated + tauhat)[z == 0]
  y_controled[z == 1] <- (y_controled - tauhat)[z == 1]
  sate <- mean(y_treated - y_controled)
  true_sate <- mean(tau[1:ntrain])
  print(paste0("True SATE: ", true_sate, ". Estimated: ", sate, ". Abs. diff: ", abs(sate - true_sate)))
}

# Gaussian processes
# makeGPBQModelMatrix <- function(df, treatment) {
#   return(data.frame(df, treatment))
# }
makeGPBQModelMatrix <- function(df, treatment) {
  return(data.frame(df, treatment))
}
# Uncomment the following to exclude treatment z in the data input
# makeGPBQModelMatrix <- function(df) {
#   return(dbarts::makeModelMatrixFromDataFrame(df))
# }

# Uncomment the following to include treatment z in the data input
trainX <- makeGPBQModelMatrix(x[1:ntrain,], z[1:ntrain])
trainY <- y[1:ntrain]
candidateX <- makeGPBQModelMatrix(x[-(1:ntrain),], z[-(1:ntrain)])
candidateY <- y[-(1:ntrain)]
# Uncomment the following to exclude treatment z in the data input
# trainX <- makeGPBQModelMatrix(x[1:ntrain,])
# trainY <- y[1:ntrain]
# candidateX <- makeGPBQModelMatrix(x[-(1:ntrain),])
# candidateY <- y[-(1:ntrain)]

library(reticulate)
source("src/optimise_gp.R")
lengthscale <- optimise_gp_r(dbarts::makeModelMatrixFromDataFrame(trainX), trainY, kernel = "matern32", epochs = 500)
print("...Finished training for the lengthscale")

source("bcf/GPBQ.R")
GPBQResults <- computeGPBQEmpirical(
  X=trainX,
  Y=trainY,
  candidateX=candidateX,
  candidateY=candidateY,
  kernel="matern32",
  lengthscale=lengthscale,
  epochs=n_seqential
)

# BART
source("bcf/BART.R")
BARTResults <- computeBARTWeighted(trainX, trainY, candidateX, candidateY, n_seqential, num_cv=num_cv, linear=linear)
print(paste0("True ATE: ", true_sate, " . Estimated: ", BARTResults$meanValueBART, ". Abs. diff: ", abs(BARTResults$meanValueBART - sate)))

# Bayesian Quadrature methods: with BART and Gaussian Process
print("Final ATE:")
print(c("Actual integral:", true_sate))
print(c("BCF integral:", sate))
print(c("BART integral:", BARTResults$meanValueBART[(n_seqential+1)]))
print(c("GP integral:", GPBQResults$meanValueGP[(n_seqential+1)]))

results <- data.frame(
  "epochs" = c(1:(n_seqential+1)),
  "BARTMean" = BARTResults$meanValueBART, "BARTsd" = BARTResults$standardDeviationBART,
  "GPMean" = GPBQResults$meanValueGP, "GPsd" = sqrt(GPBQResults$varianceGP),
  "actual" = rep(3, n_seqential+1)
)

write.csv(results, paste0("bcf/results/exp", which_experiment, "_", "sigma", sigma, "_", ntrain, "_", num_cv, ".csv"))


#' @name BMGL-EV
#' @rdname  BMGL-EV
#' @title Bivarite MGL-EV and survival MGL-EV copula
#' @description  Density, distribution function, and h-function the bivariate MGL-EV and survival MGL-EV copula with copula parameter delta.
#' @param u1,u2 numeric vectors of equal length with values in \eqn{[0,1]}.
#' @param param copula parameter, denoted by delta.
#' @md
#' @importFrom stats qbeta
#' @importFrom stats pbeta
#' @details
#' The h-function is defined as the conditional distribution function of a bivariate copula, i.e.,
#' \deqn{h_1(u_2|u_1,\delta) := P(U_2 \leq u_2 | U_1 = u_1) = \partial C(u_1,u_2) / \partial u_1,}
#'
#' \deqn{h_2(u_1|u_2,\delta) := P(U_1 \leq u_1 | U_2 = u_2) := \partial C(u_1,u_2) / \partial u_2,}
#'
#' where \eqn{(U_1, U_2) \sim C}, and \eqn{C} is a bivariate copula distribution function with parameter(s) \eqn{\delta}. For more details see Aas et al. (2009).
#' @references #' Zhengxiao Li, Jan Beirlant, Liang Yang. A new class of copula regression models for modelling multivariate heavy-tailed data. 2021, arXiv:2108.05511.
#'
#' @return
#' * \code{dcMGLEV.bivar}, \code{pcMGLEV.bivar} and \code{hMGLEV.bivar}  give values of density distribution and h-function for the 2-dimensional MGL copula with copula parameter \eqn{\delta>0}.
#' * \code{dcMGLEV180.bivar}, \code{pcMGLEV180.bivar} and \code{hMGLEV180.bivar}  give values of density and distribution and h-function for the 2-dimensional MGL copula with copula parameter \eqn{\delta>0}.
#' *  \code{hMGLEV.bivar} and \code{hMGLEV180.bivar} return a list with
#' ** hfunc1: \eqn{\partial C(u_1,u_2) / \partial u_1,}
#' ** hfunc2: \eqn{\partial C(u_1,u_2) / \partial u_2,}
NULL

#' @rdname  BMGL-EV
#' @export
#' @examples
#' pcMGLEV.bivar(u1 = c(0.3, 0.9), u2 = c(0.5, 0.8), param = 2)
pcMGLEV.bivar <- function(u1, u2, param) {
  out <- u1 + u2 - 1 + pcMGLEV180.bivar(1 - u1, 1 - u2, param = param)
  return(out)
}

#' @rdname  BMGL-EV
#' @export
#' @examples
#' dcMGLEV.bivar(u1 = 0.001, u2 = 0.999, param = 1)
dcMGLEV.bivar <- function(u1, u2, param) {
  dcMGLEV180.bivar(1 - u1, 1 - u2, param = param)
}

#' @rdname  BMGL-EV
#' @export
#' @examples
#' pcMGLEV180.bivar(u1 = c(0.3, 0.9), u2 = c(0.5, 0.8), param = 2)
pcMGLEV180.bivar <- function(u1, u2, param) {
  lf <- function(y1, y2, param) {
    delta <- param
    z2 <- (y2)^(-delta) / (y1^(-delta) + y2^(-delta))
    z1 <- (y1)^(-delta) / (y1^(-delta) + y2^(-delta))
    out <- y1 * pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + y2 * pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    return(out)
  }

  out <- exp(-lf(-log(u1), -log(u2), param = param))
  index1 <- u1 == 0 | u2 == 0
  index2 <- u1 == 1 & u2 != 0
  index3 <- u1 == 0 & u2 == 1
  out[index1] <- 0
  out[index2] <- u2[index2]
  out[index3] <- u1[index3]

  return(out)
}

#' @rdname  BMGL-EV
#' @export
#' @examples
#' dcMGLEV180.bivar(u1 = 0.5, u2 = 0.78, param = 1.8)
dcMGLEV180.bivar <- function(u1, u2, param) {
  lf <- function(y1, y2, param) {
    delta <- param
    z2 <- (y2)^(-delta) / (y1^(-delta) + y2^(-delta))
    z1 <- (y1)^(-delta) / (y1^(-delta) + y2^(-delta))
    out <- y1 * pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + y2 * pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    return(out)
  }

  pbeta_dev <- function(y, shape1, shape2) {
    (1 - y)^(shape2 - 1) * y^(shape1 - 1) / beta(shape1, shape2)
  }

  pbeta_dev2 <- function(y, shape1, shape2) {
    -(1 - y)^(shape2 - 2) * y^(shape1 - 2) * ((y - 1) * shape1 + (shape2 - 2) * y + 1) / beta(shape1, shape2)
  }
  z2_x1 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta * x1^(-delta - 1) * x2^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z1_x1 <- function(x1, x2, param) {
    delta <- param
    part1 <- -delta * x1^(-delta - 1) * x2^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z2_x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- -delta * x2^(-delta - 1) * x1^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z1_x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta * x2^(-delta - 1) * x1^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z2_x1x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta^2 * (x1 * x2)^(-delta - 1) * (x2^(-delta) - x1^(-delta))
    part2 <- (x2^(-delta) + x1^(-delta))^3
    part1 / part2
  }

  z1_x1x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta^2 * (x1 * x2)^(-delta - 1) * (x1^(-delta) - x2^(-delta))
    part2 <- (x2^(-delta) + x1^(-delta))^3
    part1 / part2
  }

  lf_dev_x1 <- function(x1, x2, param) {
    delta <- param
    z2 <- x2^(-delta) / (x2^(-delta) + x1^(-delta))
    z1 <- 1 - z2
    out <- pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + x1 * pbeta_dev(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z2_x1(x1 = x1, x2 = x2, param = delta) + x2 * pbeta_dev(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z1_x1(x1 = x1, x2 = x2, param = delta)
    out
  }

  lf_dev_x2 <- function(x1, x2, param) {
    delta <- param
    z2 <- x2^(-delta) / (x2^(-delta) + x1^(-delta))
    z1 <- 1 - z2
    out <- pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) + x2 * pbeta_dev(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z1_x2(x1 = x1, x2 = x2, param = delta) + x1 * pbeta_dev(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z2_x2(x1 = x1, x2 = x2, param = delta)
    out
  }

  lf_dev2 <- function(x1, x2, param) {
    delta <- param
    z2 <- x2^(-delta) / (x2^(-delta) + x1^(-delta))
    z1 <- 1 - z2
    If <- function(z) {
      pbeta(z, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    }
    If_dev <- function(z) {
      pbeta_dev(y = z, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    }
    If_dev2 <- function(z) {
      pbeta_dev2(y = z, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    }
    p1 <- If_dev(z2) * z2_x2(x1 = x1, x2 = x2, param = delta)
    p2 <- x1 * (If_dev2(z2) * z2_x2(x1 = x1, x2 = x2, param = delta) * z2_x1(x1 = x1, x2 = x2, param = delta)
      + If_dev(z2) * z2_x1x2(x1 = x1, x2 = x2, param = delta))
    p3 <- ((If_dev(z1) + x2 * If_dev2(z1) * z1_x2(x1 = x1, x2 = x2, param = delta)) * z1_x1(x1 = x1, x2 = x2, param = delta)
      + x2 * If_dev(z1) * z1_x1x2(x1 = x1, x2 = x2, param = delta))
    out <- p1 + p2 + p3
    out
  }
  # final results
  p1 <- pcMGLEV180.bivar(u1 = u1, u2 = u2, param = param) / (u1 * u2)
  p2 <- lf_dev_x1(-log(u1), -log(u2), param = param) * lf_dev_x2(-log(u1), -log(u2), param = param) - lf_dev2(-log(u1), -log(u2), param = param)
  out <- p1 * p2
  return(out)
}

#' @rdname  BMGL-EV
#' @export
#' @examples
#' hcMGLEV180.bivar(u1 = 0.5, u2 = 0.78, param = 1.8)
hcMGLEV180.bivar <- function(u1, u2, param) {
  delta <- param
  lf <- function(y1, y2, param) {
    delta <- param
    z2 <- (y2)^(-delta) / (y1^(-delta) + y2^(-delta))
    z1 <- (y1)^(-delta) / (y1^(-delta) + y2^(-delta))
    out <- y1 * pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + y2 * pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    return(out)
  }

  pbeta_dev <- function(y, shape1, shape2) {
    (1 - y)^(shape2 - 1) * y^(shape1 - 1) / beta(shape1, shape2)
  }

  pbeta_dev2 <- function(y, shape1, shape2) {
    -(1 - y)^(shape2 - 2) * y^(shape1 - 2) * ((y - 1) * shape1 + (shape2 - 2) * y + 1) / beta(shape1, shape2)
  }
  z2_x1 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta * x1^(-delta - 1) * x2^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z1_x1 <- function(x1, x2, param) {
    delta <- param
    part1 <- -delta * x1^(-delta - 1) * x2^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z2_x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- -delta * x2^(-delta - 1) * x1^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z1_x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta * x2^(-delta - 1) * x1^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z2_x1x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta^2 * (x1 * x2)^(-delta - 1) * (x2^(-delta) - x1^(-delta))
    part2 <- (x2^(-delta) + x1^(-delta))^3
    part1 / part2
  }

  z1_x1x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta^2 * (x1 * x2)^(-delta - 1) * (x1^(-delta) - x2^(-delta))
    part2 <- (x2^(-delta) + x1^(-delta))^3
    part1 / part2
  }

  lf_dev_x1 <- function(x1, x2, param) {
    delta <- param
    z2 <- x2^(-delta) / (x2^(-delta) + x1^(-delta))
    z1 <- 1 - z2
    out <- pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + x1 * pbeta_dev(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z2_x1(x1 = x1, x2 = x2, param = delta) + x2 * pbeta_dev(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z1_x1(x1 = x1, x2 = x2, param = delta)
    out
  }

  lf_dev_x2 <- function(x1, x2, param) {
    delta <- param
    z2 <- x2^(-delta) / (x2^(-delta) + x1^(-delta))
    z1 <- 1 - z2
    out <- pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) + x2 * pbeta_dev(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z1_x2(x1 = x1, x2 = x2, param = delta) + x1 * pbeta_dev(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z2_x2(x1 = x1, x2 = x2, param = delta)
    out
  }

  # final results
  Cu1u2 <- pcMGLEV180.bivar(u1 = u1, u2 = u2, param = delta)
  index1 <- u1 == 0 & u2 != 0
  index2 <- u1 != 0 & u2 == 0

  hfunc1 <- Cu1u2 / u1 * lf_dev_x1(x1 = -log(u1), x2 = -log(u2), param = delta)
  hfunc2 <- Cu1u2 / u2 * lf_dev_x2(x1 = -log(u1), x2 = -log(u2), param = delta)

  u10 <- rep(1e-10, length(u1[index1]))
  u20 <- rep(1e-10, length(u2[index2]))
  hfunc1[index1] <- pcMGLEV180.bivar(u1 = u10, u2 = u2[index1], param = delta) / u10 * lf_dev_x1(x1 = -log(u10), x2 = -log(u2[index1]), param = delta)
  hfunc2[index1] <- 0.0000000001

  hfunc1[index2] <- 0.0000000001
  hfunc2[index2] <- pcMGLEV180.bivar(u1 = u1[index2], u2 = u20, param = delta) / u20 * lf_dev_x2(x1 = -log(u1[index2]), x2 = -log(u20), param = delta)

  list(hfunc1 = hfunc1, hfunc2 = hfunc2) # h_1(u_2|u_1,??)
}

#' @rdname  BMGL-EV
#' @export
#' @examples
#' hcMGLEV.bivar(u1 = 0.5, u2 = 0.78, param = 1.8)
hcMGLEV.bivar <- function(u1, u2, param) {
  hfunc1 <- 1 - hcMGLEV180.bivar(u1 = 1 - u1, u2 = 1 - u2, param = param)$hfunc1
  hfunc2 <- 1 - hcMGLEV180.bivar(u1 = 1 - u1, u2 = 1 - u2, param = param)$hfunc2
  list(hfunc1 = hfunc1, hfunc2 = hfunc2)
}

#' @title  the Pickands dependence function \eqn{A} in survival MGL-EV copula
#'
#' @param w \eqn{w \in [0,1]}.
#' @param param copula parameter in survival MGL-EV copula.
#'
#' @return the value of the Pickands dependence function in \eqn{[0.5,1]}
#' @md
#' @details
#' - In the bivariate case
#' \eqn{d=2} the stable tail dependence function \eqn{\ell} can be represented in terms of the Pickands dependence function \eqn{A}:
#'
#' \deqn{
#' 		\begin{align}
#' 		A_{\delta}\left(w\right)=w I_{{\frac{1}{2}, \frac{1}{\delta}+\frac{1}{2}}}\left[\frac{\left(1-w \right)^{-\delta}}{\left(1-w \right)^{-\delta} + w^{-\delta} }\right]  + \left(1-w\right) I_{{\frac{1}{2}, \frac{1}{\delta}+\frac{1}{2}}}\left[\frac{w^{-\delta}}{\left(1-w \right)^{-\delta} + w^{-\delta} }\right].
#' 		\end{align}
#' }
#' where \eqn{A_{\delta}} is the Pickands dependence function of  survival MGL-EV copula.
#' Here \eqn{I_{m,n}^{-1}()} denotes the inverse of the beta cumulative distribution function \eqn{I_{m,n}()} (or regularized incomplete beta function)
#' with parameters shape1 = m and shape2 = n
#' implemented by R's \code{\link[stats]{qbeta}} and \code{\link[stats]{pbeta}} respectively.
#'
#'
#' - The extreme value copula  \eqn{\bar{C}^{MGL-EV}} of the  survival MGL copula is given by
#' 	\deqn{
#' 		\bar{C}^{MGL-EV}(u_1,u_2;\delta)=\exp\left[\log\left(u_1u_2\right)A_{\delta}\left(\frac{\log\left(u_2\right)}{\log\left(u_1u_2\right)}\right)\right].
#' }
#'
#' @importFrom stats qbeta
#' @importFrom stats pbeta
#'
#' @export
#' @examples
#' Afunction(w = 0.7, param = 1.2)
#'
#' delta <- 0.7
#' w.vector <- seq(0.0001, 0.9999, length.out = 100)
#' y.vector <- Afunction(w = w.vector, param = delta)
#' plot(w.vector, y.vector, lwd = 2, col = 3, ylim = c(0.5, 1))
#'
#' delta <- 1
#' w.vector <- seq(0.0001, 0.9999, length.out = 100)
#' y.vector <- Afunction(w = w.vector, param = delta)
#' lines(w.vector, y.vector, lwd = 2, col = 4)
#'
#' delta <- 3
#' w.vector <- seq(0.0001, 0.9999, length.out = 100)
#' y.vector <- Afunction(w = w.vector, param = delta)
#' lines(w.vector, y.vector, lwd = 2, col = 5)
#'
#' delta <- 5
#' w.vector <- seq(0.0001, 0.9999, length.out = 100)
#' y.vector <- Afunction(w = w.vector, param = delta)
#' lines(w.vector, y.vector, lwd = 2, col = 1)
Afunction <- function(w, param) {
  delta <- param
  k <- -delta
  z2 <- (1 - w)^k / (w^k + (1 - w)^k)
  z1 <- (w)^k / (w^k + (1 - w)^k)
  out <- w * pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + (1 - w) * pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5)
  return(out)
}


library(randomForest)
data(iris)

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

# Training
model <- randomForest(
    Species~.,
    data = train,
    mtry = 2,
    importance = TRUE,
    proximity = TRUE
)

# Test
pred <- predict(model, test[, -5])
table(pred, test$Species)


bills = data.frame(
    month = c(1,2,3,4,5),
    bill = c(120.0,131.2,142.1,152.9,164.3)
)
model = lm(bill ~ month, data = bills)
print(model)


#### FUNCTIONS FOR CREATING GRAPHS

#' Cast data.frame to sparse matrix
#'
#' Create a sparse matrix from matching vectors of row indices, column indices and values
#'
#' @param rows a vector of row indices: [i,]
#' @param columns a vector of column indices: [,j]
#' @param values a vector of the values for each (non-zero) cell: [i,j] = value
#' @return a sparse matrix of the dgTMatrix class (\code{\link{Matrix}} package)
#' @export
cast.sparse.matrix <- function(rows, columns, values=NULL, agg.func='sum') {
  if(is.null(values)) values = rep(1, length(rows))
  d = data.frame(rows=rows, columns=columns, values=values)
  if(nrow(d) > nrow(unique(d[,c('rows','columns')]))){
    message(paste('(Aggregating duplicate row-column matches. agg.func =', agg.func))
    d = aggregate(values ~ rows + columns, d, FUN=agg.func)
  }
  unit_index = unique(d$rows)
  char_index = unique(d$columns)
  sm = spMatrix(nrow=length(unit_index), ncol=length(char_index),
                match(d$rows, unit_index), match(d$columns, char_index), d$values)
  rownames(sm) = unit_index
  colnames(sm) = char_index
  sm
}

#' Calculates the similarity between rows of a matrix
#'
#' Calculates the similarity between rows of a matrix using various similarity/distance measures. Output can be a matrix or a graph object in the \code{\link{igraph}} format
#'
#' @param matrix A matrix object, which can be a sparse matrix.
#' @param similarity.measure A character string giving a method for computing similarity. Options are: 'correlation', 'cosine','conditional_probability','coincidence_count' and 'overlap_jacard'.
#' @param as.graph A character string indicating whether output should be a 'graph' (instead of a matrix). The graph is directed if assymetrical similarity measures are used ('conditional_probability' or 'overlap_jacard')
#' @return An adjacency matrix or graph object
#' @export
matrix.rowsimilarities <- function(mat, similarity.measure, as.graph=F, min.similarity=NULL, decimals=3){
  if(similarity.measure=='correlation') output = matrix.correlation(t(mat))
  if(similarity.measure=='cosine') output = matrix.cosine(t(mat))
  if(similarity.measure=='conditional_probability') output=matrix.conprob(t(mat))
  if(similarity.measure=='coincidence_count') output=matrix.coincidence.count(t(mat))
  if(similarity.measure=='overlap_jacard') output=matrix.overlap.jacard(t(mat))

  if(!is.null(min.similarity)) output[which(output < min.similarity)] = 0
  mat = round(mat, decimals)
  if(as.graph==T) {
    if(similarity.measure %in% c('overlap_jacard','conditional_probability')) edge.type = 'directed' else edge.type = 'undirected'
    colnames(output) = rownames(output) = rownames(mat)
    output = graph.adjacency(as.matrix(output), mode=edge.type, weighted=TRUE, diag=FALSE)
  }
  output
}

#' Compute coincidence count for matrix columns
#'
#' Computes the coincidence of all columnso of a matrix
#'
#' @param m A matrix object. Can be a sparse matrix.
#' @return An adjacency matrix
#' @export
matrix.coincidence.count <- function(mat){
  mat[which(mat > 0)] = 1
  crossprod(mat)
}

#' Compute jacard for matrix columns
#'
#' Computes jacard between all columnso of a matrix
#'
#' @param m A matrix object. Can be a sparse matrix.
#' @return An adjacency matrix
#' @export
matrix.overlap.jacard <- function(mat){
  mat[which(mat > 0)] = 1
  output = crossprod(mat) / colSums(mat)
}

#' Compute correlations for matrix columns
#'
#' Computes correlations between all columnso of a matrix
#'
#' @param m A matrix object. Can be a sparse matrix.
#' @return An adjacency matrix
#' @export
matrix.correlation <- function(mat){
  covmat = tcrossprod(colMeans(mat), (-2*colSums(mat)+nrow(mat)*colMeans(mat)))
  crossp = crossprod(mat)
  covmat = covmat + crossp
  sdvec = sqrt(diag(covmat))
  covmat / crossprod(t(sdvec))
}

#' Compute cosine for matrix columns
#'
#' Computes the cosine distance for all columns of a matrix
#'
#' @param m A matrix object. Can be a sparse matrix.
#' @return An adjacency matrix
#' @export
matrix.cosine <- function(mat){
  cp = crossprod(mat)
  cp / crossprod(t(diag(sqrt(cp))))
}

#' Compute conditional probability for matrix columns
#'
#' Computes the conditional probability for all columns of a matrix
#'
#' @param mat A matrix object. Can be a sparse matrix.
#' @param alpha A weighting value to transform count to probabilities
#' @return An adjacency matrix
#' @export
matrix.conprob <- function(mat, alpha=2){
  mat = 1 - ((1/alpha) ^ mat)
  colsums = colSums(mat)
  mat = crossprod(mat) / colsums
  mat[is.na(mat)] = 0
  mat
}

#' Aggregates a (sparse) matrix
#'
#' Uses the \code{\link{slam}} package rollup function to efficiently aggregate a sparse matrix. Also allows multiple vectors to be used as grouping vars.
#'
#' @param mat A matrix object, can be a sparse matrix
#' @param grouping.vars The grouping elements. Can be a single vector, or a list or data.frame with multiple vectors
#' @param The name of the function to be applied
#' @return A list containing a (sparse) matrix and a data.frame with the variables matching the matrix rows
#' @export
matrix.aggregate <- function(mat, grouping.vars, FUN='sum'){
  grouping.vars = data.frame(grouping.vars)
  index = match(apply(grouping.vars, 1, list), apply(unique(grouping.vars), 1, list)) # silly but efficient way to get unique ids for 1 or more columns

  ncolumns = ncol(mat)
  mat = rollup(as.simple_sparse_array(mat), 1L, index, FUN=FUN)
  mat = Matrix(mat, ncol=ncolumns, sparse=T)

  grouping.vars = unique(grouping.vars)
  grouping.vars$n = as.numeric(tapply(rep(1,length(index)), index, FUN='sum'))
  list(matrix=mat, vars=grouping.vars)
}

#' Create a content similarity graph
#'
#' Makes a document similarity graph in the \code{\link{igraph}} format, based on a matrix in which rows are documents, and columns are content characteristics (e.g., terms, issues, topics).
#' Vertices (i.e. nodes) are defined as unique combinations of vertex.grouping.vars. If vertices cover multiple documents (e.g., authors of several documents) then content characteristics are first aggregated.
#' The (aggregated) content characteristics are used to calculate the similarities between vertices, for which various similarity measures can be used
#'
#' @param m A (sparse) matrix where rows are documents (e.g., news articles, forum posts) and columns are content characteristics (e.g., terms, topics). Values represent the presence of content characteristics within documents. Examples are: a \code{\link{DocumentTermMatrix}} or the transposed $document_sums (topics by documents matrix) created with \code{\link{lda.collapsed.gibbs.sampler}}.
#' @param vertex.grouping.vars A data.frame or list with named vectors representing vertex characteristics. Each unique combination of characteristics will be considered a vertex. In the graph object these characteristics are stored as vertex attributes.
#' @param similarity.measure A character string giving a method for computing similarity. Options are: 'correlation', 'cosine','conditional_probability','overlap_count' and 'overlap_jacard'.
#' @param min.similarity A numeric scalar representing the threshold for similarities. All ties with a value below min.similarity will be deleted. Can be used to reduce the size of large graphs with many weak ties.
#' @param content.totals.as.vertexmeta Can be used to include the sum values per node per content characteristic. if 'all', all content characteristics will be included. Can also be a numeric vector to select specific content characteristics. The attribute names for content characteristics are C followed by the number (C1, C2, etc)
#' @param content.totals.relative Logical. If content.totals.as.vertexmeta is used, use relative attention for content characteristic
#' @return A graph object in the \code{\link{igraph}} format
#' @export
content.similarity.graph <- function(m, vertex.grouping.vars, similarity.measure='cosine', min.similarity=NULL, content.totals.as.vertexmeta=NULL, content.totals.relative=T){
  matlist = matrix.aggregate(m, vertex.grouping.vars)
  g = matrix.rowsimilarities(matlist$matrix, similarity.measure, as.graph=T, min.similarity)

  #if(!is.null(min.similarity)) g = delete.edges(g, which(E(g)$weight < min.similarity))
  E(g)$similarity = E(g)$weight

  matlist$vars$values_sum = rowSums(matlist$matrix)
  if(!is.null(content.totals.as.vertexmeta)) matlist$vars = cbind(matlist$vars, get.attribute.totals(matlist$matrix, content.totals.as.vertexmeta, content.totals.relative))

  vertex.attributes(g) = as.list(matlist$vars)
  g = default.graph.attributes(g)
  g
}

#' Sets basic default values for content.similarity.graph
#'
#' Sets basic default values for content.similarity.graph
#'
#' @param g A graph object in the \code{\link{igraph}} format
#' @return A graph object in the \code{\link{igraph}} format
default.graph.attributes <- function(g){
  g$layout = layout.fruchterman.reingold
  V(g)$size = log(V(g)$values_sum)*2
  V(g)$label = as.character(1:length(V(g)))
  V(g)$label.cex = V(g)$size / 15
  V(g)$label.color = 'black'
  E(g)$weight = E(g)$similarity
  E(g)$width = E(g)$weight*10
  g
}

#' Create a graph based on similarites of vertices/nodes
#'
#' Makes a graph (in the \code{\link{igraph}} format) in which ties represent similarities between nodes, based on a matrix in which rows are cases (e.g., documents, authors, organizations), and columns are attributes of these cases (e.g., terms, authored-documents, countries).
#' Vertices (i.e. nodes) are defined as unique combinations of vertex.grouping.vars. If vertices cover multiple documents (e.g., authors of several documents) then content characteristics are first aggregated.
#' The (aggregated) content characteristics are used to calculate the similarities between vertices, for which various similarity measures can be used.
#'
#' @param m A (sparse) matrix where rows represent cases and columns represent attributes. Similarities are calculated between cases based on their scores on attributes. For example, if rows are documents, and columns are terms (e.g., a \code{\link{DocumentTermMatrix}}), then the similarities between documents are calculated based on their terms. Or, if rows are authors and columns are documents, then similarity between authors is calculated based on what documents they co-authored.
#' @param vertex.grouping.vars Vectors of the same length and order as the rows of m, representing vertex/node characteristics. Each unique combination of characteristics will be considered a vertex. In the graph object these characteristics are stored as vertex attributes.
#' @param similarity.measure A character string giving a method for computing similarity. Options (currently) are: 'correlation', 'cosine','conditional_probability','overlap_count' and 'overlap_jacard'.
#' @param min.similarity A numeric scalar representing the threshold for similarities. All ties with a value below min.similarity will be deleted. Can be used to reduce the size of large graphs with many weak ties.
#' @param attributes.as.vertexmeta Can be used to include the sum of values of attributes for each vertex as vertex meta. if 'all', all attributes will be included. Can also be a numeric vector to select specific attributes. If m has row names, these are used to name the attributes. Otherwise, they are labeled 'att' followed by the number (att1, att2, etc)
#' @param attributes.relative Logical. If attributes.as.vertexmeta is used, should the summed attribute scores per vertex be made relative to all attribute scores of the vertex?
#' @return A graph object in the \code{\link{igraph}} format
#' @export
similarity.graph <- function(m, vertex.grouping.vars, similarity.measure='cosine', min.similarity=NULL, attributes.as.vertexmeta=NULL, attributes.relative=T){
  matlist = matrix.aggregate(m, vertex.grouping.vars)
  g = matrix.rowsimilarities(matlist$matrix, similarity.measure, as.graph=T, min.similarity)

  matlist$vars$values_sum = rowSums(matlist$matrix)
  if(!is.null(attributes.as.vertexmeta)) matlist$vars = cbind(matlist$vars, get.attribute.totals(matlist$matrix, attributes.as.vertexmeta, attributes.relative))

  vertex.attributes(g) = as.list(matlist$vars)
  g
}

get.attribute.totals <- function(mat, attributes.as.vertexmeta, attributes.relative){
  mat = as.matrix(mat)
  colnames(mat) = paste('att', 1:ncol(mat),sep='')
  if(attributes.relative==T) mat = mat / rowSums(mat)
  if(class(attributes.as.vertexmeta) %in% c('integer','numeric')) mat = mat[,attributes.as.vertexmeta, drop=F]
  if(attributes.as.vertexmeta[1] == 'all') mat = mat
  mat
}

#' Calculate adjacency of units
#'
#' Calculate the adjacency (or coincidence) of units based on the contexts in which the units occured, and optionally a value for how often they occured in this context.
#' Various measures for calculating the adjacency/similarity are possible. Output is returned either as an adjacency matrix or as a graph in the \code{\link{igraph}} format.
#'
#' @param unit.vars Vectors representing the units. Can be a single vector or multiple vectors (as a data.frame or list). Units are then defined as unique combinations of vectors (e.g., first and last name of a person)
#' @param context A vector representing the context in which the units occured. For instance, conversations in which they participated or communities they are members of.
#' @param values Optional, a numerical vector with values for how often a unit occured in the context.
#' @param measure The measure for adjacency that is used. Use 'coincidence_count' to get the number of context in which units co-occured. To take into account how many times units co-occured in the same context, 'cosine' is advised.
#' @param as.graph Logical. If TRUE, the output is returned as a graph. Otherwise output is a list containing the adjacency matrix and vectors representing its rows/columns
#' @return Either a list containing the adjacency matrix and vectors representing the rows/columns, or a graph (if as.graph == T)
#' @export
adjacency <- function(unit.vars, context, values=NULL, measure='coincidence_count', as.graph=FALSE){
  row.vars = data.frame(unit.vars)
  col.vars = data.frame(context)
  row.index = match(apply(row.vars, 1, list), apply(unique(row.vars), 1, list))
  col.index = match(apply(col.vars, 1, list), apply(unique(col.vars), 1, list))
  mat = cast.sparse.matrix(rows=row.index, columns=col.index, values=values)

  if(as.graph == TRUE) {
    g = matrix.rowsimilarities(mat, measure, TRUE, min.similarity=NULL, decimals=3)
    vertex.attributes(g) = as.list(unique(row.vars))
    g
  } else {
    mat = matrix.rowsimilarities(mat, measure, FALSE, min.similarity=NULL, decimals=3)
    list(matrix=mat, dim.vars=unique(row.vars))
  }
}

location.matrix <- function(location, shift.by, context=NULL, value=NULL){
  if(is.list(context) | is.data.frame(context)) context = match(apply(data.frame(context), 1, list), apply(unique(data.frame(context)), 1, list))
  i = 1:length(location)
  if(is.null(value)) value = rep(1, length(location))
  if(is.null(context)){
    columns = unique(location)
    col.index = match(location-1, columns)
  } else {
    columns = unique(apply(cbind(context, location), 1, list))
    col.index = match(apply(cbind(context, location+shift.by), 1, list), columns)
  }
  index = data.frame(i=i, j=col.index, value=value)
  index = index[!is.na(index[,2]),]
  spMatrix(nrow=max(i), ncol=length(columns), i=index$i, j=index$j, index$value)
}

location.window.matrix <- function(location, context, window.size, value=NULL, window.shape=NULL, two.sided=F){
  if(is.null(value)) value = rep(1, window.size-1)
  window.index = data.frame(shift.by=1:(window.size-1), value=value)
  if(two.sided==T) window.index = rbind(window.index, data.frame(shift.by=-(window.size-1):-1, value=value))
  mat = location.matrix(location, 0, context)
  if(!is.null(window.shape)){
    ### hippe functies om de window te wegen (exp decay)
  }
  if(nrow(window.index > 0)) for(i in 1:nrow(window.index)) mat = mat + location.matrix(location, window.index$shift.by[i], context, window.index$value[i])
  mat
}

#' Calculate adjacency of units within moving windows
#'
#' Calculate the adjacency (or coincidence) of units within moving windows over the order in which they occur. For instance, the adjacency of words in a given word distance or actors within converstations in a given distance of messages.
#' Additionally, the context in which the units occured can be given. For instance, the documents in which words occur or the converstations in which messages occur.
#' Optionally, the order of units can also be used to indicate the direction in which units co-occur. For instance, only counting how often an actor responded to another actor in a conversation.
#'
#' @param unit.vars Vectors representing the units. Can be a single vector or multiple vectors (as a data.frame or list). Units are then defined as unique combinations of vectors (e.g., first and last name of a person)
#' @param order A numerical vector indicating the order in which units occured (within each context)
#' @param context A vector representing the context in which the units occured.
#' @param window.size A numerical scalar indicating the size of the moving window. The default (and minimum) is 2, which means that only units directly next to each other are counted.
#' @param count.double Logical. If TRUE, multiple occurence of the same unit within a window are summed. If FALSE, units are only counted once.
#' @param direction A character string. If 'undirected', the co-occurence of units in windows is counted. If 'up', it is counted how often a unit occured after other units in windows. if 'down', it is counted how often a unit occured before other units (simply the inverse of 'up')
#' @param as.graph Logical. If TRUE, the output is returned as a graph. Otherwise output is a list containing the adjacency matrix and vectors representing its rows/columns
#' @return Either a list containing a (sparse) matrix and vector representing rows/columns, or a graph (if as.graph == T)
#' @export
windowed.adjacency <- function(unit.vars, order, context=NULL, window.size=2, count.once=F, direction='undirected', as.graph=FALSE){
  mat = location.matrix(order, 0, context)
  if(direction=='undirected') two.sided=T else two.sided=F
  mat.lag = location.window.matrix(order, context, window.size,two.sided=two.sided)
  diag(mat.lag) = 0
  matagg = matrix.aggregate(mat, unit.vars)
  if(count.once==T) agg.func = 'max' else agg.func = 'sum'
  mat.lagagg = matrix.aggregate(mat.lag, unit.vars, FUN=agg.func)
  adjmat = crossprod(t(matagg$matrix),t(mat.lagagg$matrix))

  if(direction == 'down') adjmat = t(adjmat)

  if(as.graph == TRUE) {
    g = graph.adjacency(adjmat, mode='directed', weighted=TRUE, diag=FALSE)
    vertex.attributes(g) = as.list(matagg$vars)
    E(g)$average.XY = E(g)$weight / V(g)$n[get.edgelist(g)[,1]]
    E(g)$average.YX = E(g)$weight / V(g)$n[get.edgelist(g)[,2]]
    g
  } else list(matrix=adjmat, dim.vars=matagg$vars)
}

graph.as.dataframes <- function(g){
  edgelist = get.edgelist(g)
  e = data.frame(x=edgelist[,1], y=edgelist[,2])
  e = cbind(e, data.frame(edge.attributes(g)))
  v = data.frame(vertex.attributes(g))
  list(edges=e, vertices=v)
}

#' Assign vertex colors to a graph
#'
#' A convenience function to add colors to a graph of the \code{\link{igraph}} format based on a vector of vertex attributes.
#'
#' @param g A graph object in the \code{\link{igraph}} format
#' @param attribute A vertex attribute to organize the colors. Either use a categorical vector (factor, character) to color categories in different colors, or use a numerical vector (numerical, integer) to highlight with one color (like a heat map)
#' @param pallete Optional. Add a custom pallete, which should be a character vector with color codes that igraph can use.
#' @return A graph object in the \code{\link{igraph}} format
#' @export
graph.color.vertices <- function(g, attribute, pallete=NULL){
  if(class(attribute) %in% c('character','factor')) {
    if(is.null(pallete)) pallete = colors()[grep('[0-9]', colors(), invert=T)]
    unique.att = unique(attribute)
    if(length(unique.att) > length(pallete)) replace_colors = TRUE else replace_colors = FALSE
    pallete = data.frame(attribute=unique.att, color=sample(pallete, replace=replace_colors, length(unique.att)))
    V(g)$color = as.character(pallete$color[match(attribute, pallete$attribute)])
    print(pallete)
  }
  if(class(attribute) %in% c('numeric','integer')) {
    attribute = attribute / max(attribute)
    attribute = round(attribute*1000)
    pallete = colorRampPalette(c("white","darkred"), bias=0.5, interpolate='spline')(max(attribute)+1)
    V(g)$color = as.character(pallete)[attribute+1]
  }
  g
}

#' A wrapper for plotting graphs
#'
#' A wrapper for plotting graphs in the \code{\link{igraph}} format that incorporates the functions to delete edges and vertices
#'
#' @param g A graph object in the \code{\link{igraph}} format
#' @param min.edge.value Numerical scalar. Edges with a lower weight will be deleted
#' @param max.edge.value Like min.edge.value, but for the max value
#' @param delete.vertices Either a logical vector (TRUE/FALSE) with TRUE meaning that a vertex will be deleted, or indices for vertices that will be deleted
#' @param select.vertices Same as delete.vertices, but inversed
#' @param min.degree Numerical scalar, indicating the minimum number of edges a vertex needs to have in order to be included in the graph. Set to 1 to ignore unconnected vertices
#' @param use.tkplot Logical. If TRUE, tkplot is used instead of plot, which allows some interactive editing of the network
#' @param return.graph Logical. If TRUE, the function will return the (filtered) graph object
#' @return if return.graph is TRUE, A graph object in the \code{\link{igraph}} format
#' @export
graph.plot <- function(g, edge.weight=NULL, min.edge=NULL, max.edge=NULL, delete.vertices=NULL, select.vertices=NULL, min.degree=NULL, use.tkplot=FALSE, ego=NULL, return.graph=FALSE){
  if(!is.null(edge.weight)) {
    E(g)$weight = edge.weight
    E(g)$width = edge.weight*3
  }
  if(!is.null(ego)){
    if(class(ego) == 'logical') ego = which(ego)
    g = delete.edges(g, which(!get.edgelist(g)[,1] %in% ego & !get.edgelist(g)[,2] %in% ego))
  }
  if(!is.null(min.edge)) g=delete.edges(g, which(E(g)$weight < min.edge))
  if(!is.null(max.edge)) g=delete.edges(g, which(E(g)$weight > max.edge))
  if(!is.null(delete.vertices)){
    if(class(delete.vertices) == 'logical') delete.vertices = which(delete.vertices)
    g=delete.vertices(g, delete.vertices)
  }
  if(!is.null(select.vertices)){
    if(class(select.vertices) == 'logical') select.vertices = which(select.vertices)
    all.vertices = 1:length(V(g))
    g=delete.vertices(g, all.vertices[-select.vertices])
  }
  if(!is.null(min.degree)) g = delete.vertices(g, which(degree(g) < min.degree))

  if(use.tkplot == TRUE) tkplot(g) else plot(g)
  if(return.graph == TRUE) g
}

#### SOCIAL NETWORK FUNCTIONS

#' Split strings to rows with matching ids
#'
#' A convenience function. Mainly designed for preparing data for co-author type networks, if an unknown number of authors per document is stored as a single character string with delimiters.
#' A character string is split by a given character vector. For each part of the string a new row is created. An id value indicates which parts belong together. An order value indicates which part of the original string the stringpart was
#'
#' @param x A character vector.
#' @param split_by The character vector by which x will be split. By default should be a regular expression (see \code{\link{strsplit}}) but can be changed using the ellipsis parameters
#' @param id The id to be assigned to the rows. If a vector of the same lengt of x is given, these values will be used.
#' @param ... additional parameters to be passed to the strsplit function
#' @return A data.frame with the columns id, order and substring
#' @export
strsplit.to.rows <- function(x, id=NULL, split_by=';', ...){
  if(is.null(id)) id = 1:length(x)
  tmp = strsplit(as.character(x), split_by, ...)
  nMax = max(sapply(tmp, length))
  cols = t(sapply(tmp, function(i) i[1:nMax]))
  substring = as.vector(t(cols))
  ord = rep(1:nMax, times=length(id))
  id = rep(id, each=nMax)
  d = data.frame(id=id, order=ord, substring=substring)
  unique(d[!is.na(d$substring),])
}

########### OBSOLETE #############

#' Create a coincidence graph
#'
#' Create a graph from conversation data
#'
#' @param conversation.id A vector representing the conversation authors were engaged in (e.g. a thread, meeting)
#' @param author A vector with unique author names/ids
#' @return A graph object in the \code{\link{igraph}} format
#' @export
#' @examples
#' d = data.frame(conversation=c(1,1,1,1,1,1,2,2,2,2),
#'               author=c('Alice','Bob','Alice','Dave','Bob','Bob','Alice','Bob','Alice','Bob'),
#'               order.nr=c(1,2,3,4,5,6,1,2,3,4))
#' g = author.coincidence.graph(d$conversation, d$author) # In how many conversations did author.X and author.Y communicate?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
#' g = author.coincidence.graph(d$conversation, d$author, 'overlap_jacard') # Similar to default (coincidence_count) but with direction (by dividing coincidence by number of conversations author participated in)
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.messages*15)
#' g = author.coincidence.graph(d$conversation, d$author, 'cosine') # Cosine can be used to also take into account how many times each author participated within conversations
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.messages*15)
coincidence.graph <- function(participation.id, author, similarity.measure='coincidence_count'){
  m = cast.sparse.matrix(author, participation.id)
  g = matrix.rowsimilarities(m, similarity.measure=similarity.measure, output.as='graph')
  g = add.author.participation.meta(g, participation.id, author)
  g
}

add.author.participation.meta <- function(g, participation.id, author){
  conauth = data.frame(participation.id, author)
  n.document = data.frame(table(unique(conauth)$author))
  n.messages = data.frame(table(conauth$author))
  V(g)$author = V(g)$name
  V(g)$n.context = n.document[match(V(g)$name, n.document[,1]),2]
  V(g)$n.messages = n.messages[match(V(g)$name, n.messages[,1]),2]
  g
}

#' Create a graph from conversation data
#'
#' Create a graph from conversation data, in which ties are drawn between each authors in the conversation and the first author.
#'
#' @param conversation.id A vector representing the conversation authors were engaged in (e.g. a thread, meeting)
#' @param author A vector with unique author names/ids
#' @param order.nr Optional. A vector representing the order in which authors communicated within a conversation.
#' @param direction A character string, indicating the direction of the ties. If 'undirected', ties between authors go both ways. If 'directed.up', ties are directed from author to previous authors (only if order is given). if 'directed.down', ties are directed from author to later authors.
#' @param once.per.conversation Logical. If TRUE, count only the number of conversations in which a first-author <-> later-author coincidence occurs. It is then ignored how many times the later author participated in the conversation. If FALSE, the number of participation times is counted.
#' @return A graph object in the \code{\link{igraph}} format
#' @export
#' @examples
#' d = data.frame(conversation=c(1,1,1,1,1,1,2,2,2,2),
#'               author=c('Alice','Bob','Alice','Dave','Bob','Bob','Alice','Bob','Alice','Bob'),
#'               order.nr=c(1,2,3,4,5,6,1,2,3,4))
#' g = first.author.graph(d$conversation, d$author, d$order.nr) # in how many conversations initiated by author.Y did author.X communicate?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
#' g = first.author.graph(d$conversation, d$author, d$order.nr, once.per.conversation=FALSE) # how many times did author.X communicate in a conversation initiated by author.Y?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.messages*15)
#' g = first.author.graph(d$conversation, d$author, d$order.nr, direction='undirected') # drop direction author.X and author.Y
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
#' g = first.author.graph(d$conversation, d$author, d$order.nr, direction='directed.down') # switch direction
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
first.author.graph <- function(conversation, author, order.nr, direction='directed.up', once.per.conversation=TRUE){
  index = unique(author)
  author = match(author, unique(author))
  m = ties.per.message(conversation, author, order.nr, 1)
  m = aggregate.ties(m, conversation, author, once.per.conversation)
  rownames(m) = colnames(m) = index

  g = authormatrix.to.graph(m, direction)
  g = add.author.participation.meta(g, conversation, index[author])
  g
}

#' Create a graph from conversation data
#'
#' Create a graph from conversation data, in which ties are drawn between authors and the authors that communicated within a given distance (lookback) before them.
#'
#' @param conversation.id A vector representing the conversation authors were engaged in (e.g. a thread, meeting)
#' @param author A vector with unique author names/ids
#' @param order.nr Optional. A vector representing the order in which authors communicated within a conversation.
#' @param lookback The number of previous author with whom a tie with an author should be drawn
#' @param direction A character string, indicating the direction of the ties. If 'undirected', ties between authors go both ways. If 'directed.up', ties are directed from author to previous authors (only if order is given). if 'directed.down', ties are directed from author to later authors.
#' @param once.per.conversation Logical. If TRUE, max one tie between two unique authors will be counted per conversation, even if an author communicated within the given distance multiple times within the conversation.
#' @return A graph object in the \code{\link{igraph}} format
#' @export
#' @examples
#' d = data.frame(conversation=c(1,1,1,1,1,1,2,2,2,2),
#'              author=c('Alice','Bob','Alice','Dave','Bob','Bob','Alice','Bob','Alice','Bob'),
#'               order.nr=c(1,2,3,4,5,6,1,2,3,4))
#' g = previous.authors.graph(d$conversation, d$author, d$order.nr, lookback=1) # how many times did author.X communicate directly after author.Y?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
#' g = previous.authors.graph(d$conversation, d$author, d$order.nr, lookback=1, once.per.conversation=TRUE) # in how many conversations did author.X communicate directly after author.Y?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
#' g = previous.authors.graph(d$conversation, d$author, d$order.nr, lookback=2) # how many times did author.X communicate within two messages after author.Y?
#' plot(g, edge.label=E(g)$weight, vertex.size=V(g)$n.documents*25)
previous.authors.graph <- function(conversation, author, order.nr, lookback=1, direction='directed.up', once.per.conversation=F){
  index = unique(author)
  author = match(author, unique(author))
  id = 1:length(author)
  for(lb in 1:lookback) {
    order.nr.Y = order.nr - lb
    if(lb == 1) m = ties.per.message(conversation, author, order.nr, order.nr.Y)
    if(lb > 1) m = m + ties.per.message(conversation, author, order.nr, order.nr.Y)
  }
  m = aggregate.ties(m, conversation, author, once.per.conversation)
  rownames(m) = colnames(m) = index

  g = authormatrix.to.graph(m, direction)
  g = add.author.participation.meta(g, conversation, index[author])
  g
}

ties.per.message <- function(conversation, author, order.nr.X, order.nr.Y){
  nauthors = length(unique(author))
  id = 1:length(author)
  previous_author = author[match(apply(cbind(conversation, order.nr.Y), 1, list), apply(cbind(conversation,order.nr.X), 1, list))]
  xy = cbind(id=id, y=previous_author)
  xy = xy[!is.na(xy[,2]),]
  if(is.null(nrow(xy))) next
  spMatrix(nrow=max(id), ncol=nauthors, i=xy[,1], j=xy[,2], rep(1, nrow(xy)))
}

aggregate.ties <- function(m, conversation, author, once.per.conversation=T){
  m[which(m > 0)] = 1 # count max 1 tie for each message.
  if(once.per.conversation == TRUE) {
    m = matrix.aggregate(m, list(conversation=conversation, author=author))
    m$matrix[which(m$matrix > 0)] = 1
    m = matrix.aggregate(m$matrix, list(author=m$vars$author))$matrix
  } else m = matrix.aggregate(m, list(author=author))$matrix
  m
}

authormatrix.to.graph <- function(m, direction){
  if(direction == 'undirected') {
    m = forceSymmetric(m, uplo='U') + forceSymmetric(m, uplo='L')
    g = graph.adjacency(m, mode='undirected', weighted=TRUE, diag=FALSE)
  }
  if(direction == 'directed.up') g = graph.adjacency(m, mode='directed', weighted=TRUE, diag=FALSE)
  if(direction == 'directed.down') g = graph.adjacency(t(m), mode='directed', weighted=TRUE, diag=FALSE)
  E(g)$author.ties = E(g)$width = E(g)$weight
  g
}


d = read.csv('times.csv')

# duration in minutes
d$duration = abs( d$t1 - d$t2 ) / 60

# clip outliers/errors
d = d[d$duration<60,]
d = d[d$duration>1,]

# set the time of the trip (average)
d$meantime = ((d$t1+d$t2)/2) -5*3600
# shift everything to the left
d$meantime  = d$meantime - 4*3600
# time of day in hours
d$daytime = (d$meantime %% (24*3600)) / 3600 + 4

#do a quick statistical test to see if there is a difference of means
d$pre = d$meantime<1510462800
t.test(duration~pre,data=d)
ks.test(d[d$pre,'duration'],d[!d$pre,'duration'])
# separate into two distinct periods
#d = d[d$pre,]
unique_days_in_d = length(unique(d$meantime - d$meantime %% (24*3600)))

# plot the points
par(
	family = 'Ubuntu Mono',
	mar = c(3.1,5,3,0.5)
)
plot(
	x = d$daytime,
	y = d$duration,
	pch = '.',
	ylim = c(3,33),
	xlim = c(4,28),
	axes = FALSE,
	xlab = '',
	ylab = 'Jarvis <-> Bathurst (minutes)',
	main = 'Streetcar travel times pre/post overlaid'
)
axis(
	side = 1, # X
	at = c(4,8.5,12,17.5,24,24+4),
	labels = c('4am','8:30am','Noon','5:30pm','Midnight','4am')
)
axis(
	side = 2, # Y
	at = c(5,10,15,20,25,30)
)
# grid
abline(h=c(30,25,20,15,10,5),col=rgb(0,0,0,0.1))
abline(v=c(8.5,12,17.5,24),col=rgb(0,0,0,0.1))

# kernel parameters
bandwidth = 0.5 # standard deviation (gaussian kernel bandwidth)

# sort by duration
d = d[order(d$duration),]

# points to iterate over
times = seq(4,28,0.1)
p05 = p25 = p50 = p75 = p95 = rep(0,length(times))

# get an hourly local median
for(ti in 1:length(times)){
	# calculate distances from this time
	d$dist = abs( times[ti] - d$daytime )
	d$w = exp( -( d$dist^2 / (2*bandwidth)^2 ) )
	d$cum_w = cumsum(d$w) / sum(d$w)
	# p05
	di = which( abs(d$cum_w-0.05) == min(abs(d$cum_w-0.05)) )
	p05[ti] = mean(d[di,'duration'])
	# p25
	di = which( abs(d$cum_w-0.25) == min(abs(d$cum_w-0.25)) )
	p25[ti] = mean(d[di,'duration'])
	# median (Q2)
	di = which( abs(d$cum_w-0.5) == min(abs(d$cum_w-0.5)) )
	p50[ti] = mean(d[di,'duration'])
	# p75
	di = which( abs(d$cum_w-0.75) == min(abs(d$cum_w-0.75)) )
	p75[ti] = mean(d[di,'duration'])
	# p90
	di = which( abs(d$cum_w-0.95) == min(abs(d$cum_w-0.95)) )
	p95[ti] = mean(d[di,'duration'])
}
# plot percentile boundaries
# 0.05 - 0.95
polygon(
    x=c(times,rev(times)),
    y=c(p05,rev(p95)),
    col=rgb(1,0,0,0.3),
    border=rgb(1,0,0,0.25)
)
# 0.25 - 0.75
polygon(
  x=c(times,rev(times)),
  y=c(p25,rev(p75)),
  col=rgb(0,0.5,1,0.3),
  border=rgb(0,0,1,0.25)
)
lines( x=times, y=p50, col='darkblue', lty=1, lwd=1 )


library(WatershedTools)
library(sp)
library(ggplot2)
ws <- readRDS("vjosa/res/watershed_vjosaSpring2018.rds")
stream <- raster("vjosa/res/vjosa_stream.grd")

cutpoints <- data.frame(x = c(19+ 48/60 + 2.7/3600, 20 + 28/60 + 4.2/3600),
	y = c(40 + 23/60 + 58.8/3600, 40 + 15/60 + 40.1/3600))
coordinates(cutpoints) <- c(1,2)
proj4string(cutpoints) <- CRS("+init=epsg:4326")
cutpoints <- spTransform(cutpoints, CRS("+init=epsg:3035"))
cutpoints <- snapToStream(cutpoints, stream, 200)

plot.Watershed(ws) + geom_point(data = as.data.frame(cutpoints), col = 'red', aes(x=X1, y=X2)) + coord_fixed() #+ xlim(5212000, 5213000) + ylim(1968000, 1969000)

## total network length, in km
sum(ws[,'length'])/1000

#length upstream from points
pts <- extract(ws, cutpoints)
sapply(pts, function(x) sum(ws[connect(ws, upstream=Inf, downstream=x), 'length']))/1000


library(mathart)
library(ggforce)
library(Rcpp)
library(tidyverse)

draw <- function(df, n) {
	p <- ggplot() +
		geom_point(aes(x, y), df, size = 0.35) +
		geom_path(aes(x, y), df, size = 0.35) +
		theme_blankcanvas(margin_cm = 0.5) +
		coord_equal()
	file = paste("./output/shell-", n, ".png", sep="")
	ggsave(file, width = 30, height = 30, units = "cm")
}

draw(mollusc(n_s = 100, n_t = 2500), 1)
draw(mollusc(n_s = 100, n_t = 1250), 2)
draw(mollusc(n_s = 100, n_t = 625), 3)
draw(mollusc(n_s = 100, n_t = 312), 4)
draw(mollusc(n_s = 100, n_t = 156), 5)
draw(mollusc(n_s = 100, n_t = 78), 6)
draw(mollusc(n_s = 500, n_t = 800), 7)


gdp=France.GDP$Value
plot(gdp)
plot(gdp,type="l")
ts(gdp)
plot(ts(gdp,start=1961,frequency = 4))
acf(gdp)


#' Plot parameters with unusually high or low CVs
#'
#' Identify parameters with CVs < 0.05 or CVs > 0.55.
#' @param a1 list file produced by grab.aux.files function
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @return matrix of parameters that meet criteria
#' @export

PlotHighCVs <- function(a1,save.plots,od,plotf) {

  asap.name <- a1$asap.name
  npar <- a1$npar
  if ((npar != -999) & any(!is.na(a1$asap.std))){
    # drop last 5 params (or only if steepness is fixed at 1?)
    asap.std <- a1$asap.std
    nCV1 <- length(asap.std[,1])
    asap.std <- asap.std[c(-(nCV1-4):(-nCV1) ),]
    nCV <- length(asap.std[,1])
    nCV.par <-as.numeric(a1$npar)

    CVmat <- matrix(NA, nrow=nCV, ncol=(length(asap.std[1,])+1)       )
    CV.vec <- rep(NA, length(asap.std[1,])  )
    log.pars <- which(substr(asap.std$name,1,3)=="log")

    for (p in 1:nCV) {

      CV.vec[p] <- asap.std[p,4]/asap.std[p,3]
      if (substr(asap.std$name[p],1,3)=="log")  CV.vec[p] <- sqrt( exp(asap.std[p,4]) -1)

    }  #end p loop
    CVmat <- cbind(asap.std, "CV"= CV.vec)
    trouble.pars1 <- CVmat[CVmat$CV<0.05 | CVmat$CV>0.55,]
    trouble.pars <- trouble.pars1[trouble.pars1$index<(nCV.par+1),]

    if (length(trouble.pars[,1]>0) ) {
      cex.par <- rep(1, length(trouble.pars[,1])  )
      pch.par <- rep(4, length(trouble.pars[,1])  )
      pch.par[which(trouble.pars$CV<0.05)]<- 8
      cex.par[which(trouble.pars$CV<0.05)]<- 1.5
      trouble.pars2 <- trouble.pars
      trouble.pars2$CV[which(trouble.pars$CV>1)]<- 1  #truncate CV at 1 so you can read plot

      write.csv(trouble.pars, file=paste0(od, "CV.Check.Params.",asap.name,".csv"), row.names=F)
      write.csv(CVmat, file=paste0(od, "CV.All.Params.",asap.name,".csv"), row.names=F)

      plot(trouble.pars$index, trouble.pars$CV, type='p', pch=pch.par, col='red', cex=cex.par,
           xlab="Parameter number", ylab="CV (parameter estimate)", ylim=c(0,1.05) )

      if (save.plots) savePlot(paste0(od, "CV.Check.Params.",plotf), type=plotf)
    }  #end check for length(trouble.pars)>0

  } else { # if npar == -999

    plot(1:10,1:10,type='n',axes=FALSE,xlab="",ylab="")
    text(5,5,"Problem with run, no .std file")

  } # end if npar check

  return()
}


qiime_dist_2_pco <<-  function(
                                file_in,
                                file_out= "./my_PCoA"
                                #dist_method = "weighted_unifrac"
                                )

{
  # load packages
  #suppressPackageStartupMessages(library(matlab))
  suppressPackageStartupMessages(library(ecodist))
  #suppressPackageStartupMessages(library(Cairo))
  #suppressPackageStartupMessages(library(gplots))

  # define sub functions
  func_usage <- function() {
    writeLines("
     You supplied no arguments

     DESCRIPTION: (import_qiime_dist.r):
     Import a qiime distance matrix from file to a \"dist\" object.

     USAGE: MGRAST_plot_pca(
                            file_in = no default arg                               # (string)  input data file
                            file_out = \"./my_PCoA\"                                       # (string) file out
                             )\n"
               )
    stop("import_qiime_dist stopped\n\n")
  }

  # import a qiime created distance matrix (very easy, already fomratted for R)
  unifrac.table <- read.table(file_in) # pain in the neck -- just use this to extract names -- can't do it from dist with standard methods
  unifrac.dist <- as.dist(read.table(file_in))

#################################################
  # convert unifrac dist to plot_pco *.DIST
  #dist_matrix <<- find_dist(my_data, dist_method)
  #DIST_file_out <- gsub(" ", "", paste(output_DIST_dir, file_in, ".", dist_method, ".DIST"))
  #if (print_dist > 0) { write_file(file_name = DIST_file_out, data = data.matrix(dist_matrix)) }
#################################################

  # perform the pco
  my_pco <<- pco(unifrac.dist)

  # scale eigen values from 0 to 1, and label them
  eigen_values <<- my_pco$values
  scaled_eigen_values <<- (eigen_values/sum(eigen_values))
  for (i in (1:dim(as.matrix(scaled_eigen_values))[1])) {names(scaled_eigen_values)[i]<<-gsub(" ", "", paste("PCO", i))}
  scaled_eigen_values <<- data.matrix(scaled_eigen_values)

  # label the eigen vectors
  eigen_vectors <<- data.matrix(my_pco$vectors)
  #dimnames(eigen_vectors)[[1]] <<- dimnames(my_data)[[1]]
  dimnames(eigen_vectors)[[1]] <<- dimnames(unifrac.table)[[1]]

  # write eigen values and then eigen vectors to file_out
  #PCoA_file_out = gsub(" ", "", paste(output_dir, file_in, ".", dist_method, ".PCoA"))

  write(file=file_out, paste("# file_in: ", file_in,
          "\n#________________________________",
          "\n# EIGEN VALUES (scaled 0 to 1) >",
          "\n#________________________________"),
        append=FALSE)

  write.table(scaled_eigen_values, file=file_out, col.names=FALSE, row.names=TRUE, append = TRUE, sep="\t")
  write(file=file_out, paste("#________________________________",
          "\n# EIGEN VECTORS >",
          "\n#________________________________"),
          append=TRUE)
  write.table(eigen_vectors, file=file_out, col.names=FALSE, row.names=TRUE, append = TRUE, sep="\t")

}


# Classify images based on the fuzzy c-means algorithm
library(Hmisc)
library(GSIF)
library(caret)
library(ggplot2)
source("utils/load-data.r")
source("utils/accuracy-statistics.r")

OutputDir = "../data/"

# Load data
alldata = LoadClassificationData()
alldata$dominant = as.character(alldata$dominant)
pixels = LoadTrainingPixels(exclude="is.water") # Not excluding is.water leads to very strange issues
# Sort pixels to match our dataframe
pixels = pixels[match(alldata@data$cell.no, pixels@grid.index),]

set.seed(0xc0ffeed)
folds = createFolds(alldata$cropland, 4)

# There are two ways: either use the built-in method of using a multinomial logistic regression
# with endmembers, or use weighted averages with all pixels.

# Start with builtin

terms = names(pixels)
FullFormula = formula(paste0("dominant~", paste(terms, collapse="+")))

cmeans.mnlr = spfkm(FullFormula, alldata[alldata$pure,], pixels)

# Hard total classification accuracy: 53%, pretty good
sum(cmeans.mnlr@predicted@data[[1]] == alldata@data[["dominant"]]) / length(alldata)
# RMSE of 23.61
AccuracyStats(cmeans.mnlr@mu@data*100, alldata@data[, names(cmeans.mnlr@mu@data)])
# Compared to pure uncertainty: 11% of each class is worse at 27.38
AccuracyStats(100.0/9.0, alldata@data[names(cmeans.mnlr@mu@data)])
# Compared to pure water: our classifier is much better!
uncertainty = alldata@data[names(cmeans.mnlr@mu@data)]
uncertainty$water = 100
uncertainty[,names(uncertainty) != "water"] = 0
AccuracyStats(uncertainty, alldata@data[names(cmeans.mnlr@mu@data)])

# Try normalising values
logitTransform = function(p) { log((p/max(p))/(1-(p/max(p)))) }
asinTransform = function(p) { asin(sqrt(p/max(p))) }
pixelsTransformed = pixels
hist(asinTransform(pixels$red)); pixelsTransformed$red = asinTransform(pixels$red)
hist(pixels$nir)
hist(asinTransform(pixels$blue)); pixelsTransformed$blue = asinTransform(pixels$blue)
hist(pixels$swir)
hist(asinTransform(pixels$osavi))
hist(pixels$lswi)
hist(pixels$height)
hist(asinTransform(pixels$slope)); pixelsTransformed$slope = asinTransform(pixels$slope)
hist(pixels$aspect)
hist(pixels$tpi)
hist(pixels$mean.ndvi)
hist(pixels$phase1)
hist(asinTransform(pixels$amplitude1)); pixelsTransformed$amplitude1 = asinTransform(pixels$amplitude1)
hist(pixels$phase2)
hist(asinTransform(pixels$amplitude2)); pixelsTransformed$amplitude2 = asinTransform(pixels$amplitude2)

transdata = alldata
transdata$red = asinTransform(transdata$red)
transdata$blue = asinTransform(transdata$blue)
transdata$slope = asinTransform(transdata$slope)
transdata$amplitude1 = asinTransform(transdata$amplitude1)
transdata$amplitude2 = asinTransform(transdata$amplitude2)

cmeans.mnlr.transf = spfkm(FullFormula, transdata[transdata$pure,], pixelsTransformed)

# Marginally better, 23.27 rather than 23.61
AccuracyStats(cmeans.mnlr.transf@mu@data*100, alldata@data[, names(cmeans.mnlr.transf@mu@data)])
# Compared to pure uncertainty: 11% of each class
AccuracyStats(100.0/9.0, alldata@data[names(cmeans.mnlr.transf@mu@data)])
# Compared to pure water
AccuracyStats(uncertainty, alldata@data[names(cmeans.mnlr@mu@data)])

# What about fuzzification?

step = data.frame(RMSE = numeric(), MAE = numeric(), ME = numeric(), fuzzy.e = numeric())
workingsteps = seq(1.1, 10, 0.1)
for (fuzz in workingsteps)
{
    cmeans = spfkm(FullFormula, alldata[alldata$pure,], pixels, fuzzy.e = fuzz)
    AS = AccuracyStats(cmeans@mu@data*100, alldata@data[, names(cmeans@mu@data)])
    step = rbind(step, data.frame(AS, fuzzy.e = fuzz))
}
View(step[order(step$RMSE),])
# Best RMSE 21.78 at 1.5, this makes a lot of difference

# Drop terms to find the best combination

StepFormula = FullFormula
CmeansStep = function(StepFormula, class.c = NULL, class.sd = NULL, subset = alldata$pure)
{
    terms = labels(terms(StepFormula))
    step = data.frame(RMSE = numeric(), MAE = numeric(), ME = numeric(), Formula = character())
    for (term in terms)
    {
        Formula = update.formula(StepFormula, paste0("~ . -", term))
        print(Formula)
        try({
            cmeans <- spfkm(Formula, alldata[subset,], pixels, class.c = class.c, class.sd = class.sd, fuzzy.e=1.5)
            AS = AccuracyStats(cmeans@mu@data*100, alldata@data[, names(cmeans@mu@data)])
            step = rbind(step, data.frame(AS, Formula = Reduce(paste0, deparse(Formula))))
        })
    }
    return(step)
}
step = CmeansStep(StepFormula)
View(step[order(step$RMSE),])
# Best RMSE (21.21) when dropping blue. Doesn't bias it either.
StepFormula = update.formula(FullFormula, "~ . -blue")
step = CmeansStep(StepFormula)
View(step[order(step$RMSE),])
# Best unbiased RMSE (21.00) when dropping aspect
StepFormula = update.formula(StepFormula, "~ . -aspect")
step = CmeansStep(StepFormula)
View(step[order(step$RMSE),])
# Nothing better than dominant ~ red + nir + swir + osavi + lswi + height + slope +
#    tpi + mean.ndvi + phase1 + amplitude1 + phase2 + amplitude2. Stop.

# So that doesn't help much at all, less than 1 RMSE.

# Now with weighted means
GetClassMeans = function(samples = 1:nrow(alldata), validation.idx = 1:9, training.idx = 13:28)
{
    combos = expand.grid(validation=validation.idx, training=training.idx)
    ClassMeans = function(x)
    {
        wtd.mean(alldata@data[samples,x["training"]], alldata@data[samples,x["validation"]])
    }
    cm = apply(combos, 1, ClassMeans)
    c.means = matrix(cm, nrow=length(validation.idx),
        dimnames=list(names(alldata)[validation.idx], names(alldata)[training.idx]))
    return(c.means)
}

GetClassSDs = function(samples = 1:nrow(alldata), validation.idx = 1:9, training.idx = 13:28)
{
    combos = expand.grid(validation=validation.idx, training=training.idx)
    ClassSDs = function(x)
    {
        sqrt(wtd.var(alldata@data[samples,x["training"]], alldata@data[samples,x["validation"]],
            normwt = TRUE))
    }
    csd = apply(combos, 1, ClassSDs)
    c.sds = matrix(csd, nrow=length(validation.idx),
        dimnames=list(names(alldata)[validation.idx], names(alldata)[training.idx]))
    return(c.sds)
}

TestFormula = formula("dominant ~ red + nir + blue + swir + osavi + lswi + height +
    slope + aspect + tpi + mean.ndvi + phase1 + amplitude1 +
    phase2 + amplitude2")
cmeans.wm = spfkm(FullFormula, alldata[fold,], pixels,
    class.c = GetClassMeans(), class.sd = GetClassSDs())

# Hard total classification accuracy: 49%, slightly worse
sum(cmeans.wm@predicted@data[[1]] == alldata@data[order(alldata@data$cell.no),"dominant"]) / length(alldata)

# RMSE of 24.37, also slightly worse
AccuracyStats(cmeans.wm@mu@data*100, alldata@data[order(alldata@data$cell.no),names(cmeans.wm@mu@data)])
AccuracyStatTable(cmeans.wm@mu@data*100, alldata@data[order(alldata@data$cell.no),names(cmeans.wm@mu@data)])
# Compared to everything 11%: RMSE of 27.4
AccuracyStats(100.0/9.0, alldata@data[names(cmeans.wm@mu@data)])

qplot(blue, swir, data=alldata@data[alldata@data$pure,], colour=dominant)
qplot(osavi, mean.ndvi, data=alldata@data[alldata@data$pure,], colour=dominant)

# Fuzz
step = data.frame(RMSE = numeric(), MAE = numeric(), ME = numeric(), fuzzy.e = numeric())
workingsteps = seq(1.1, 10, 0.1)
for (fuzz in workingsteps)
{
    cmeans = spfkm(FullFormula, alldata, pixels, class.c = GetClassMeans(), class.sd = GetClassSDs(), fuzzy.e = fuzz)
    AS = AccuracyStats(cmeans@mu@data*100, alldata@data[order(alldata@data$cell.no), names(cmeans@mu@data)])
    step = rbind(step, data.frame(AS, fuzzy.e = fuzz))
}
View(step[order(step$RMSE),])
# RMSE of 22.32, best consistently at 1.5

# Try dropping using this method
StepFormula = FullFormula
step = CmeansStep(StepFormula, class.c = GetClassMeans(), class.sd = GetClassSDs(), subset=TRUE)
View(step[order(step$RMSE),])
# Dropping amplitude1: 21.99
StepFormula = update.formula(StepFormula, "~ . -amplitude1")
step = CmeansStep(StepFormula, class.c = GetClassMeans(), class.sd = GetClassSDs(), subset=TRUE)
View(step[order(step$RMSE),])
# Dropping blue: 21.84
StepFormula = update.formula(StepFormula, "~ . -blue")
step = CmeansStep(StepFormula, class.c = GetClassMeans(), class.sd = GetClassSDs(), subset=TRUE)
View(step[order(step$RMSE),])
# Dropping amplitude2: 21.69
StepFormula = update.formula(StepFormula, "~ . -amplitude2")
step = CmeansStep(StepFormula, class.c = GetClassMeans(), class.sd = GetClassSDs(), subset=TRUE)
View(step[order(step$RMSE),])
# Dropping tpi: 21.60
StepFormula = update.formula(StepFormula, "~ . -tpi")
step = CmeansStep(StepFormula, class.c = GetClassMeans(), class.sd = GetClassSDs(), subset=TRUE)
View(step[order(step$RMSE),])
# Dropping red: 21.57
StepFormula = update.formula(StepFormula, "~ . -red")
step = CmeansStep(StepFormula, class.c = GetClassMeans(), class.sd = GetClassSDs(), subset=TRUE)
View(step[order(step$RMSE),])
# Dropping lswi: 21.54
StepFormula = update.formula(StepFormula, "~ . -lswi")
step = CmeansStep(StepFormula, class.c = GetClassMeans(), class.sd = GetClassSDs(), subset=TRUE)
View(step[order(step$RMSE),])
# Dropping aspect: 21.51
StepFormula = update.formula(StepFormula, "~ . -aspect")
step = CmeansStep(StepFormula, class.c = GetClassMeans(), class.sd = GetClassSDs(), subset=TRUE)
View(step[order(step$RMSE),])
# Dropping swir: 21.44
StepFormula = update.formula(StepFormula, "~ . -swir")
step = CmeansStep(StepFormula, class.c = GetClassMeans(), class.sd = GetClassSDs(), subset=TRUE)
View(step[order(step$RMSE),])
# No more improvements, stop. Best formula:
# dominant ~ nir + osavi + height + slope + mean.ndvi + phase1 + phase2

cmeans.wm = spfkm(StepFormula, alldata[fold,], pixels,
    class.c = GetClassMeans(), class.sd = GetClassSDs())
AccuracyStatTable(cmeans.wm@mu@data*100, alldata@data[names(cmeans.wm@mu@data)])

qplot(aspect, tpi, data=alldata@data[alldata@data$pure,], colour=dominant)

# Repeat with 4-fold cross-validation
CMCV = function(StepFormula, filename="stat-cmeans.csv", outdir=OutputDir, weighted=FALSE, ...)
{
    RoundPrediction = data.frame()
    for (i in 1:length(folds))
    {
        if (weighted)
            cmeans = spfkm(StepFormula, alldata[-folds[[i]],], pixels,
                class.c = GetClassMeans(-folds[[i]]), class.sd = GetClassSDs(-folds[[i]]), ...)
        else
            cmeans = spfkm(StepFormula, alldata[-folds[[i]],], pixels, ...)
        if (nrow(RoundPrediction) == 0)
            RoundPrediction = cmeans@mu@data[folds[[i]],]*100
        else
            RoundPrediction = rbind(RoundPrediction, cmeans@mu@data[folds[[i]],]*100)
    }
    Validator = alldata@data[unlist(folds), names(cmeans@mu@data)]
    AST = AccuracyStatTable(RoundPrediction, Validator)
    print(AST)
    plot(unlist(RoundPrediction), unlist(Validator))
    write.csv(AST, paste0(outdir, filename))
    write.csv(CalcErrors(RoundPrediction, Validator), paste0(outdir, "errors-", filename))
}

# Unoptimised
CMCV(FullFormula, filename = "stat-cmeans-unoptimised.csv")#, class.c = GetClassMeans(), class.sd = GetClassSDs())
# Optimised
OptimalFormula1 = formula("dominant ~ red + nir + swir + osavi + lswi + height + slope + tpi + mean.ndvi + phase1 + amplitude1 + phase2 + amplitude2")
OptimalFormula2 = formula("dominant ~ nir + osavi + height + slope + mean.ndvi + phase1 + phase2")
CMCV(OptimalFormula2, fuzzy.e=1.5, weighted=TRUE)

# Train on pure, predict fuzzy
folds=list(which(!alldata@data$pure))
CMCV(FullFormula, filename = paste0(OutputDir, "stat-cmeans-pure-unoptimised.csv"))
CMCV(OptimalFormula2, fuzzy.e=1.5, weighted=TRUE,  filename = paste0(OutputDir, "stat-cmeans-pure.csv"))


#
# Example R program
#

# example from http://www.inside-r.org/packages/cran/geor/docs/sample.geodata

require(geoR)

par(mfrow=c(1,2))
S1 <- grf(2500,  grid="reg", cov.pars=c(1, .23))
image(S1, col=gray(seq(0.9,0.1,l=100)))
y1 <- sample.geodata(S1, 80)
points(y1$coords, pch=19)
## Now a preferential sampling
y2 <- sample.geodata(S1, 80, coef=1.3)
## which is equivalent topps
## y2 <- sample.geodata(S1, 80, prob=exp(1.3*S1$data))
points(y2$coords, pch=19, col=2)
## and now a clustered (but not preferential)
S2 <- grf(2500,  grid="reg", cov.pars=c(1, .23))
y3 <- sample.geodata(S1, 80, prob=exp(1.3*S2$data))
## which is equivalent to
## points(y3$coords, pch=19, col=4)
image(S2, col=gray(seq(0.9,0.1,l=100)))
points(y3$coords, pch=19, col=4)


#Objetivo:  dibujar la "curva ROC de una variable"

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

library("data.table")

setwd("E:/UBA/2019-II/DM en Finanzas/Dropbox Prof/datasets")

#cargo los datos
dataset <- fread("201902.txt")

#creo una clase que se 1 cuando es BAJA+2   , y  0 en caso contrario
#esto me simplifica las cuentas
dataset[ , clase01:= as.numeric(clase_ternaria=="BAJA+2") ]

#creo una variable azar que me va a ser util
#para ordenar al azar los registros que tienen el mismo valor para un campo
#asi el dibujo de la curva ROC de ese segmento es una recta
dataset[ , azar   := runif(nrow(dataset)) ]

#calculos basicos
universo  <-  nrow(dataset )
pos_total <-  sum(dataset$clase01 )
neg_total <-  universo -  pos_total

#Creo dos funciones de forma de poder superponer varios cortes de una misma variable

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

graficar_init  = function()
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #la diagonal
  azar_neg <- c( 0, neg_total )
  azar_pos <- c( 0, pos_total )

  #grafico
  plot( azar_neg,
        azar_pos,
        type="n",
        main=paste( "ROC Curve" ),
        xlab="neg",
        ylab="pos",
        pch=19)

  lines( azar_neg, azar_pos,   type="l" , col="black", lwd=2)
}
#----------------------

pred_graficar  = function(dataset, pcolumna, pvalor )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  pos_pred <- sum( dataset[ get(pcolumna) <= pvalor , clase01] )
  neg_pred <- sum( 1 - dataset[ get(pcolumna) <= pvalor, clase01] )

  AUC <- (pos_pred*neg_pred + (pos_pred + pos_total)*(neg_total-neg_pred) ) / (2*pos_total*neg_total)

  #creo el vector con los tres puntos
  vneg <- c( 0, neg_pred,  neg_total )
  vpos <- c( 0, pos_pred,  pos_total )

  #grafico
  lines( vneg, vpos,   type="l" , col="green", lwd=2)

  return( AUC )
}
#----------------------

graficar_init()

#ejecutar las instrucciones de a una y ver el efecto
pred_graficar( dataset, "mcuentas_saldo", -100000 )
pred_graficar( dataset, "mcuentas_saldo",  -10000 )
pred_graficar( dataset, "mcuentas_saldo",   -2000 )
pred_graficar( dataset, "mcuentas_saldo",       0 )
pred_graficar( dataset, "mcuentas_saldo",   10000 )#Mejor AUC
pred_graficar( dataset, "mcuentas_saldo",   50000 )
pred_graficar( dataset, "mcuentas_saldo",  100000 )

#----------------------
#Concepto fundamental
#se ordena el dataset por una variable
#y se lleva el conteo de positivos y negativos

columna_graficar  = function(dataset, pcolumna )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #ordeno por  <pcolumna, azar>
  #dentro de los registros que tienen el mismo valor de pcolumna, ordeno por el campo que invente llamado  azar
  #los NA de pcolumna  van al inicio del orden
  univar <- dataset[ order(get(pcolumna), na.last=FALSE, azar),   c("clase01", pcolumna), with=FALSE]

  #acumulo positivos y negativos,  operacion vectorial
  neg_acum  <- cumsum( 1- univar$clase01 )
  pos_acum  <- cumsum( univar$clase01 )

  #dibujo la curva, que esta compuesta de miles de puntos
  lines( neg_acum, pos_acum,   type="l" , col="red", lwd=2)

  #calculo el vector de cada AUC, que consiste en cortar exactamente en ese punto
  AUC_vector <-  ( pos_acum*neg_acum + (pos_acum+pos_total)*(neg_total-neg_acum) ) / (2*pos_total*neg_total)

  #voy a calcular cual es el corte que genera la mayor AUC

  return(  list( "variable"= pcolumna,
                 "valor"   = univar[ which.max( AUC_vector ),  get(pcolumna)],
                 "AUC_max" = max( AUC_vector)
               )
        )

}
#----------------------

columna_graficar(  dataset, "mcuentas_saldo"  )#AUC_mAX de  0.75
columna_graficar(  dataset, "cliente_edad"  )
columna_graficar(  dataset, "Visa_mconsumototal"  )#AUC_mAX de  0.732
columna_graficar(  dataset, "ttarjeta_visa"  )
columna_graficar(  dataset, "ttarjeta_master"  )
columna_graficar(  dataset, "Visa_cuenta_estado"  )

#ahora uso el valor optimo que encontre en la instruccion anterior
#cortar mcuentas_saldo en 1275.59

graficar_init()
pred_graficar( dataset, "mcuentas_saldo", 1275.59 )
columna_graficar(  dataset, "mcuentas_saldo"  )#AUC_mAX de  0.75

#cortar Visa_mconsumototal en 863.19
graficar_init()
pred_graficar( dataset, "Visa_mconsumototal", 863.19 )
columna_graficar(  dataset, "Visa_mconsumototal"  )#AUC_mAX de  0.732

#cortar cliente_edad en 36
graficar_init()
pred_graficar( dataset, "cliente_edad", 36 )
columna_graficar(  dataset, "cliente_edad"  )#AUC_mAX de  0.527

#como da la tabla de contingencia de mcuentas_saldo
ftable(dataset[ mcuentas_saldo <= 1275.59, clase_ternaria])
ftable(dataset[ mcuentas_saldo >  1275.59, clase_ternaria])

#como da la tabla de contingencia de Visa_mconsumototal
ftable(dataset[ Visa_mconsumototal <= 863.19, clase_ternaria])
ftable(dataset[ Visa_mconsumototal >  863.19, clase_ternaria])

#-----------------------
#Desvio,  calcular la ganancia acumulada

columna_graficar_ganancia  = function(dataset, pcolumna )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #ordeno por  <pcolumna, azar>
  #dentro de los registros que tienen el mismo valor de pcolumna, ordeno por el campo que invente llamado  azar
  #los NA de pcolumna  van al inicio del orden
  univar <- dataset[ order(get(pcolumna), na.last=FALSE, azar),   c("clase01", pcolumna), with=FALSE]

  #acumulo positivos y negativos,  operacion vectorial
  neg_acum  <- cumsum( 1- univar$clase01 )
  pos_acum  <- cumsum( univar$clase01 )

  gan_acum  <- 19500*pos_acum - 500*neg_acum

  #grafico
  plot( seq(universo),
        gan_acum,
        type="n",
        main=paste( "Ganancia ordenado por", pcolumna  ),
        xlab="registros",
        ylab="Ganancia",
        pch=19)

  lines( seq(universo), gan_acum,   type="l" , col="blue", lwd=2)

  return(  list( "variable"= pcolumna,
                 "valor"   = univar[ which.max( gan_acum ),  get(pcolumna)],
                 "gan_max" = max( gan_acum),
                 "regis"   = which.max( gan_acum )
               )
         )
}
#---------------------

columna_graficar_ganancia( dataset, "mcuentas_saldo"  )#AUC_mAX de  0.75
columna_graficar_ganancia( dataset, "cliente_edad"  )
columna_graficar_ganancia( dataset, "Visa_mconsumototal"  )#AUC_mAX de  0.732
columna_graficar_ganancia( dataset, "ttarjeta_visa"  )
columna_graficar_ganancia( dataset, "ttarjeta_master"  )
columna_graficar_ganancia( dataset, "Visa_cuenta_estado"  )

# Y ahora graficando los primeros  n registros

columna_graficar_ganancia_n  = function(dataset, pcolumna, pcantidad )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #ordeno por  <pcolumna, azar>
  univar <- dataset[ order(get(pcolumna), na.last=FALSE, azar),   c("clase01", pcolumna), with=FALSE]

  #acumulo positivos y negativos,  operacion vectorial
  neg_acum  <- cumsum( 1- univar$clase01 )
  pos_acum  <- cumsum( univar$clase01 )

  gan_acum  <- 19500*pos_acum - 500*neg_acum

  #grafico
  plot( seq(pcantidad),
        gan_acum[1:pcantidad],
        type="n",
        main=paste( "Ganancia ordenado por", pcolumna  ),
        xlab="registros",
        ylab="Ganancia",
        pch=19)

  lines( seq(pcantidad), gan_acum[1:pcantidad],   type="l" , col="blue", lwd=2)

  return(  list( "variable"= pcolumna,
                 "valor"   = univar[ which.max( gan_acum ),  get(pcolumna)],
                 "gan_max" = max( gan_acum),
                 "regis"   = which.max( gan_acum )
               )
         )
}
#---------------------

columna_graficar_ganancia_n( dataset, "mcuentas_saldo", 20000  )
columna_graficar_ganancia_n( dataset, "Visa_mconsumototal", 40000  )


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

#####
scenario <- "B"
source(paste("data_logistic_regression_scenario_", scenario, ".r", sep = ""))

summary(glm(y_0 ~ X_0, family = "binomial"))
summary(glm(y ~ X, family = "binomial"))
summary(glm(c(y_0, y) ~ rbind(X_0, X), family = "binomial"))

############
### Unnormalised posterior

compiled.model.unnorm.posterior <- stan_model("stan/simple_logistic_regression_posterior_unnormalised.stan")

lgr.data.forposterior <- list(
  N0 = N_0,
  X0 = X_0,
  P = P,
  y0 = y_0,
  eta = eta,
  nu = nu,
  X = X,
  N = N,
  y = y
)

unnorm.posterior.lgr <- sampling(compiled.model.unnorm.posterior, data = lgr.data.forposterior)
unnorm.posterior.lgr
pairs(unnorm.posterior.lgr, pars = c("a_0", "beta"))

### The approximately normalised prior

J <- 20
constant_data <- read.csv(paste("../../data/constant_data/RegressionLogistic_logCA0_J=", J, "_scenario_", scenario, ".csv", sep = ""))

library(mgcv)
fit.gam <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = constant_data)

approx.normalised.model <- stan_model("stan/simple_logistic_regression_posterior_approximate.stan")

Ks <- c(100, 1000, 10000, 20000)

get_posterior_K <- function(K){
  pred_a0s <- seq(0, max(constant_data$a0), length.out = K)
  a0_grid <- data.frame(a0 = pred_a0s,
                        lc_pred = predict(fit.gam, newdata = data.frame(a0 = pred_a0s)))
  lgr.data.forposterior$pred_grid_x <- a0_grid$a0
  lgr.data.forposterior$pred_grid_y <- a0_grid$lc_pred
  approx.norm.posterior.lgr <- sampling(approx.normalised.model,
                                        data = lgr.data.forposterior, refresh = 0)
  return(approx.norm.posterior.lgr)
}

system.time(
  all.approximates <- lapply(Ks, get_posterior_K)
)

##### Analysis of p(a_0 | data)
a0.unnorm <- extract(unnorm.posterior.lgr, 'a_0')$a_0

a0.approx.list <- lapply(Ks, function(k){
  i <- match(k, Ks)
  a0 <- extract(all.approximates[[i]], 'a_0')$a_0
  return(data.frame(a0 = a0, normalisation = paste("K=", k, sep = "")))
} )

a0.dt <-
  rbind(
    data.frame(a0 = a0.unnorm,
               normalisation = rep("none", length(a0.unnorm))
    ),
    do.call(rbind, a0.approx.list)
  )

library(ggplot2)

a0.dt$normalisation <- factor(a0.dt$normalisation,
                                     levels = c("none", paste("K=", Ks, sep = "")) )

a0_dist <- ggplot(a0.dt, aes(x = a0, fill = normalisation, colour = normalisation)) +
  geom_density() +
  stat_function(fun = function(x) dbeta(x, eta, nu),
                geom = "line", colour = "black", linetype = "longdash") +
  ggtitle("Logistic regression") +
  facet_grid(normalisation~., scales = "free") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  scale_x_continuous(expression(a[0]), expand = c(0, 0)) +
  theme_bw(base_size = 20) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))

a0_dist

ggsave(paste("../../figures/a0_posterior_RegressionLogistic_J=", J, "_scenario_", scenario, ".pdf", sep = ""), a0_dist)

a0_dist_norm <- ggplot(subset(a0.dt, normalisation != "none"),
                       aes(x = normalisation, y = a0,
                           fill = normalisation, colour = normalisation)) +
  geom_boxplot(alpha = .4) +
  ggtitle("Logistic regression") +
  scale_y_continuous(expression(a[0]), expand = c(0, 0)) +
  theme_bw(base_size = 20)

a0_dist_norm

ggsave(paste("../../figures/a0_posterior_RegressionLogistic_normalisation_comparison_J=", J, "_scenario_", scenario, ".pdf", sep = ""), a0_dist_norm)

###
unnorm.pars <- as.data.frame(
  cbind(extract(unnorm.posterior.lgr, 'alpha')$alpha,
        extract(unnorm.posterior.lgr, 'beta')$beta)
)
names(unnorm.pars) <- c("alpha", paste("beta[", 1:4, "]", sep = ""))

##

app.norm.pars.list <- lapply(all.approximates, function(x) {
  pars <- as.data.frame(
    cbind(extract(x, 'alpha')$alpha,
          extract(x, 'beta')$beta
    )
  )
  names(pars) <- c("alpha", paste("beta[", 1:4, "]", sep = ""))
  return(pars)
})

library(reshape2)
app.norm.pars.df.list <- lapply(seq_along(app.norm.pars.list), function(i) {
  y <- app.norm.pars.list[[i]]
  dt <- melt(y, variable.name = "parameter", value.name = "sample")
  dt$normalisation <- paste("K=", Ks[i] ,sep = "")
  return(dt)
} )

##

unnorm.dt <- melt(unnorm.pars, variable.name = "parameter", value.name = "sample")
unnorm.dt$normalisation <- "none"

posterior.dt <- rbind(unnorm.dt, do.call(rbind, app.norm.pars.df.list))
posterior.dt$normalisation <- factor(posterior.dt$normalisation,
                                     levels = c("none", paste("K=", Ks, sep = "")) )

###

true.pars <- data.frame(parameter = names(unnorm.pars), value = c(true.alpha, true.betas))

parameter_posteriors <- ggplot(data = posterior.dt, aes(x = sample, colour = normalisation, fill = normalisation)) +
  geom_density(alpha = .4) +
  scale_x_continuous("") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  facet_wrap(.~parameter,  scales = "free", labeller = label_parsed) +
  geom_vline(data = true.pars, aes(xintercept = value), linetype = "dashed") +
  theme_bw(base_size = 20) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))

parameter_posteriors

ggsave(paste("../../figures/parameter_posterior_LogisticRegression_J=", J,
             "_scenario_", scenario, ".pdf", sep = ""), plot = parameter_posteriors, dpi = 400)


fac <- function(f) {
  function(n) {
    if (n<2)
      1
    else
      n*f(n-1)
  }
}

fib <- function(f) {
  function(n) {
    if (n <= 1)
      n
    else
      f(n-1) + f(n-2)
  }
}


R version 3.3.0 (2016-05-03) -- "Supposedly Educational"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

 install.packages("quantmod")
 library(quantmod)
 install.packages("e1071")
 library(e1071)
 install.packages("ggplot2")
 install.packages("Hmisc")
 library(ggplot2)

 library(Hmisc)

 PoundDollar <- read.csv("d:/PoundDollar.csv")

 head(PoundDollar)

 str(PoundDollar)

 relativeStrengthIndex3 <- RSI(Op(PoundDollar), n= 3)

 summary(relativeStrengthIndex3)

 SeriesMeanAvg50 <- SMA(Op(PoundDollar),n=50)

 summary(SeriesMeanAvg50)

 describe(SeriesMeanAvg50)

 Trend <- Op(PoundDollar) - SeriesMeanAvg50

 summary(Trend)

 PriceDiff <- Cl(PoundDollar) - Op(PoundDollar)

 summary(PriceDiff)

 binaryClassification <- ifelse(PriceDiff>0,"UP","DOWN")

 summary(binaryClassification)

 DataSet <- data.frame(relativeStrengthIndex3, Trend, binaryClassification)

 str(DataSet)

 DataSet<-DataSet[-c(1:49),]

 dim(DataSet)

 TrainingDataSet <- DataSet[1:4528,]

 dim(TrainingDataSet)

 summary(TrainingDataSet)

 TestDataSet <- DataSet[4529:6038,]

 dim(TestDataSet)

 summary(TestDataSet)

 SVM <- svm(binaryClassification~relativeStrengthIndex3+Trend, data=TrainingDataSet, kernel="radial",cost=1,gamma=1/2)

 summary(SVM)

 TrainingPredictions <- predict(SVM,TrainingDataSet, type="class")

 summary(TrainingPredictions)

 describe(TrainingPredictions)

 TrainingData <- data.frame(TrainingDataSet, TrainingPredictions)

 summary(TrainingData)

 ggplot(TrainingData,aes(x=Trend,y=relativeStrengthIndex3))+stat_density2d(geom="contour",aes(color=TrainingPredictions))+labs(title="SVM Relative Strength Index & Trend Predictions",x="Open - SMA50",y="RSI3",color="Training Predictions")

Chapter 06/6Support Vector Machine - Currency Trading Strategy.r


 DSTERF Example Program Results

 Eigenvalues
    -7.0037 -0.4059  2.0028  8.9968


#' Function that identifies peaks in a dataset
#'
#' Developed by William A. Huber
#' @param x Vector of \code{x} values of input data
#' @param y Vector of \code{y} values of input data
#' @param w Window size for smoothing data
#' @param ... Additional arguments to be passed into LOESS function
#' @return A vector listing the standard deviations of propagated errors
#' propagated on all \code{X} values.
#' @seealso https://rpubs.com/mengxu/peak_detection
#' @references package dependencies: zoo 1.8.7
#'
#' Huber, W.A., Data Smoothing and Peak Detection, Rpubs,
#' Last accessed: December 8th, 2020.
#'    \url{https://rpubs.com/mengxu/peak_detection}
#' @examples
#' # Create dummy periodic data
#' x <- seq(1, 100, 1)
#' y <- sin((2 * pi * (seq(1, 100, 1) - 8 + 20 / 4)) / 20)
#' # Run peakid function
#' result <- peakid(x, y, w = 20)

#' @export
peakid <- function(x, y, w=1, ...) { # Algorhythm for peak identification by William A. Huber (https://rpubs.com/mengxu/peak_detection)
  n <- length(y)
  y.smooth <- loess(y ~ x, ...)$fitted
  y.max <- zoo::rollapply(zoo::zoo(y.smooth), 2*w+1, max, align="center")
  delta <- y.max - y.smooth[-c(1:w, n+1-1:w)]
  i.max <- which(delta <= 0) + w
  list(x=x[i.max], i=i.max, y.hat=y.smooth)
}


 ZGGESX Example Program Results

 Number of eigenvalues for which SELCTG is true =    2
 (dimension of deflating subspaces)

 Selected generalized eigenvalues
  1 (  2.00, -5.00)
  2 (  3.00, -1.00)


library(ggplot2)
library(plyr)
ggplotRegression <- function (data,formula) {
  show(formula)
  fit = lm(formula,data=data)
  show(summary(fit))
  require(ggplot2)

  ggplot(data, aes_string(x = names(fit$model)[2], y = names(fit$model)[1])) +
    geom_point() +
    geom_line() +
    stat_smooth(method = "lm", formula=formula, col = "red") +
    labs(title = paste("Adj R2 = ",signif(summary(fit)$adj.r.squared, 5),
                       "; Intercept =",signif(fit$coef[[1]],5 ),
                       "; Slope =",signif(fit$coef[[2]], 5),
                       "; P =",signif(summary(fit)$coef[2,4], 5)))
}

intensities <- rename(read.table("~/workspace/RinSim/problem/files/test/times/intensity-analysis.txt", quote="\""), c("V1"="x", "V2"="y"))

#intensities <- subset(intensities, x < 1 & x > -.99)

show(intensities)
p <- ggplotRegression(intensities, y ~ x  )
#p <- ggplot(intensities, aes(x=V1,y=V2)) + geom_line()
show(p)


### use outputs of regression estimating water temperature in a stream using
### equilibrium temperature and river mile to generate time series of
### temperatures for each affected stream

# load needed libraries
library(tidyverse)
library(lubridate)
library(purrr)

# Add year 2000 to data
# Need to create an eq_temp.csv that includes 2000
eq_temp <- read_excel("data-raw/mike_wright_temperature_regression/source/GerberEQTEMP-61to17.xlsx") %>%
  select("date" = `Months...12`, "monthly_mean_temp_f_air" = `EQTEMP...13`) %>% drop_na()

# inputs: regression parameters and reach lengths (/2 for river mile, assuming
# reach begins at confluence) for each river, monthly equilibrium air temps.

# air temperatures to be converted to water temperatures using
# the parameters in regression_parameters.csv, as assigned in
# regression_assignments.csv eq_temp was generated in GerberEQTEMP-61to17.xlsx
# from a 6-hourly time series in F to a monthly (average) time series, still in
# F since regression was calibrated using F

# Replaced with eq_temps containing 20000
#  eq_temp <- read_csv('data-raw/mike_wright_temperature_regression/eq_temp.csv')

# regression assignments will allow us to identify which parameters each river
# should use. these assignments were taken from an email dated 04/26/19, which
# was sent to Mike Urkov among others

# regression parameters were generated by Kirk Nelson;
# Final_21streamResults.xlsx contains the parameters and analysis of
# stream-by-stream comparisons

watershed_parameters <- left_join(read_csv('data-raw/mike_wright_temperature_regression/regression_assignments.csv'),
                                  read_csv('data-raw/mike_wright_temperature_regression/regression_parameters.csv'))

# add river mile information  to watershed_parameters, automatically using
# watershed as the key; this puts river miles (which must be divided by two) in
# the same tbl_df as parameters
# rearing lengths will be used and the miles for the creek will be divided by
# two to obtain the river mile used in the calculations
watershed_parameters_river_miles <- watershed_parameters %>%
  left_join(DSMhabitat::watershed_lengths) %>%
  filter(lifestage == 'rearing', species == 'fr') %>%
  mutate(miles = miles / 2)

# function for creating a juv_temp formatted long df of monthly temperatures
# from study period (Oct79-Dec99) for a given watershed

water_temps <- function(watershed_) {

	# filter watershed_parameters_river_miles to keep only the single row which has this watershed's information
	params <- filter(watershed_parameters_river_miles, watershed == watershed_)

	# for each date in eq_temp, generate a water temperature estimate in C using the monthly_mean_temp_f_air values in F from eq_temp and mm, bm, mb, bb, and miles from params
		#### NOTE that currently, the method takes input equilibrium temperatures in F and outputs water temperature estimates in C!
	water_temp_estimates <- eq_temp %>%
	  mutate(monthly_mean_temp_c = (params$mm * monthly_mean_temp_f_air + params$bm) * params$miles +
	           (params$mb * monthly_mean_temp_f_air + params$bb),
	         watershed = watershed_) %>%
	  select(date, watershed, monthly_mean_temp_c)

	return(water_temp_estimates)

}

# map function across all of the watersheds in watershed_parameters_river_miles and combine in tbl_df
watersheds <- unique(watershed_parameters_river_miles$watershed)

juv_temp_regression <- map_df(watersheds, water_temps)

# save regression temp estimates
write_rds(juv_temp_regression, 'data-raw/mike_wright_temperature_regression/juv_temp_regression.rds')

# ------------------------------------------------------------------------------
# comparison plots with old surrogate method

# antelope creek----
# previously cow creek was used as a surrogate
antelope_new <- juv_temp_regression %>%
  filter(watershed == 'Antelope Creek') %>%
  mutate(method = 'regression')

antelope_old <- DSMtemperature::juv_temp %>%
  filter(watershed == 'Cow Creek') %>%
  mutate(method = 'cow creek surrogate')

bind_rows(antelope_new, antelope_old) %>%
  ggplot(aes(date, monthly_mean_temp_c, color = method)) +
  geom_line()

# bear creek-----
# previously cow creek was used as a surrogate
bear_new <- juv_temp_regression %>%
  filter(watershed == 'Bear Creek') %>%
  mutate(method = 'regression')

bear_old <- DSMtemperature::juv_temp %>%
  filter(watershed == 'Cow Creek') %>%
  mutate(method = 'cow creek surrogate')

bind_rows(bear_new, bear_old) %>%
  ggplot(aes(date, monthly_mean_temp_c, color = method)) +
  geom_line()

# elder creek ----
# previously thomes creek was used as a surrogate
elder_new <- juv_temp_regression %>%
  filter(watershed == 'Elder Creek') %>%
  mutate(method = 'regression')

elder_old <- DSMtemperature::juv_temp %>%
  filter(watershed == 'Thomes Creek') %>%
  mutate(method = 'thomes creek surrogate')

bind_rows(elder_new, elder_old) %>%
  ggplot(aes(date, monthly_mean_temp_c, color = method)) +
  geom_line()

# paynes creek ------
# previously cow creek was used as a surrogate
paynes_new <- juv_temp_regression %>%
  filter(watershed == 'Paynes Creek') %>%
  mutate(method = 'regression')

paynes_old <- DSMtemperature::juv_temp %>%
  filter(watershed == 'Cow Creek') %>%
  mutate(method = 'cow creek surrogate')

bind_rows(paynes_new, paynes_old) %>%
  ggplot(aes(date, monthly_mean_temp_c, color = method)) +
  geom_line()

# Bear River-----
# previously yuba river was used as a surrogate
bear_river_new <- juv_temp_regression %>%
  filter(watershed == 'Bear River') %>%
  mutate(method = 'regression')

bear_river_old <- DSMtemperature::juv_temp %>%
  filter(watershed == 'Yuba River') %>%
  mutate(method = 'yuba river surrogate')

bind_rows(bear_river_new, bear_river_old) %>%
  ggplot(aes(date, monthly_mean_temp_c, color = method)) +
  geom_line()

# Feather River-----
# previously american river was used as a surrogate
feather_river_new <- juv_temp_regression %>%
  filter(watershed == 'Feather River') %>%
  mutate(method = 'regression')

feather_river_old <- DSMtemperature::juv_temp %>%
  filter(watershed == 'American River') %>%
  mutate(method = 'american river surrogate')

bind_rows(feather_river_new, feather_river_old) %>%
  ggplot(aes(date, monthly_mean_temp_c, color = method)) +
  geom_line()

# Calaveras River-----
# previously mokelumne river was used as a surrogate
calaveras_river_new <- juv_temp_regression %>%
  filter(watershed == 'Calaveras River') %>%
  mutate(method = 'regression')

calaveras_river_old <- DSMtemperature::juv_temp %>%
  filter(watershed == 'Mokelumne River') %>%
  mutate(method = 'mokelumne river surrogate')

bind_rows(calaveras_river_new, calaveras_river_old) %>%
  ggplot(aes(date, monthly_mean_temp_c, color = method)) +
  geom_line()

# all
juv_temp_regression %>%
  filter(str_detect(watershed, 'River')) %>%
  ggplot(aes(date, monthly_mean_temp_c, color = watershed)) +
  geom_line()

juv_temp_regression %>%
  filter(str_detect(watershed, 'Creek')) %>%
  ggplot(aes(date, monthly_mean_temp_c, color = watershed)) +
  geom_line()


#Find happy numbers between 1 and 50
which(apply(rbind(1:50), 2, is.happy))