#' @export

causalNullTest <- function(Y, A, W, p=2,
                           control = list(),
                           return_ic_est = FALSE) {

  call <- match.call(expand.dots = TRUE)
  control <- do.call("causalNullTest.control", control)

  .check.input(Y = Y, A = A, W = W, p = p, control = control)

  require(mvtnorm)
  n <- length(Y)
  a.vals <- sort(unique(A))

  if(control$cross.fit & is.null(control$folds)) {
    control$folds <- sample(rep(1:control$V, length.out = n), replace=FALSE)
  }

  if(is.null(control$mu.hat)) {
    library(SuperLearner)
    if(control$cross.fit) {
      if(control$verbose) cat("Estimating outcome regressions...")
      control$mu.hat <- lapply(1:control$V, function(v) {
        if(control$verbose) cat("fold", v, "...")
        if(length(setdiff(Y, c(0,1))) == 0) {
          fit <- SuperLearner(Y = Y[control$folds != v], X = cbind(A, W)[control$folds != v,],
                              SL.library = control$mu.SL.library,
                              family = 'binomial',
                              method = 'method.NNloglik')
        } else {
          fit <- SuperLearner(Y = Y[control$folds != v], X = cbind(A, W)[control$folds != v,],
                              SL.library = control$mu.SL.library,
                              family = 'gaussian', method = 'method.CC_LS')
        }
        function(a, w) c(predict(fit, newdata = cbind(A = a, w),onlySL = TRUE)$pred)
      })
      if(control$verbose) cat("\n")
    } else {
      if(control$verbose) cat("Estimating outcome regression...")
      if(length(setdiff(Y, c(0,1))) == 0) {
        mu.fit <- SuperLearner(Y = Y, X = cbind(A, W), SL.library = control$mu.SL.library,
                               family = 'binomial', method = 'method.NNloglik')
      } else {
        mu.fit <- SuperLearner(Y = Y, X = cbind(A, W), SL.library = control$mu.SL.library,
                               family = 'gaussian', method = 'method.CC_LS')
      }
      control$mu.hat <- function(a, w) c(predict(mu.fit, newdata = cbind(A = a, w),onlySL = TRUE)$pred)
      if(control$verbose) cat("\n")
    }
  }

  if(is.null(control$g.hat)) {
    if(control$cross.fit) {
      if(control$verbose) cat("Estimating propensities..")
      control$g.hat <- lapply(1:control$V, function(v) {
        if(control$verbose) cat("fold", v)
        fit <- cmdSuperLearner(A = A[control$folds != v], W = W[control$folds != v,,drop=FALSE], newA = A[control$folds == v], newW = W[control$folds == v,,drop=FALSE], control=list(SL.library = control$g.SL.library, n.bins = control$g.n.bins, verbose = control$verbose, saveFitLibrary = FALSE))
        c(fit$SL.densities)
        #function(a, w) c(predict.cmdSuperLearner(fit, newA = a, newW = w))
      })
      if(control$verbose) cat("\n")
    } else {
      if(control$verbose) cat("Estimating propensity...")
      g.fit <- cmdSuperLearner(A = A, W = W,
                               control=list(SL.library = control$g.SL.library,
                                            n.bins = control$g.n.bins,
                                            verbose = control$verbose,
                                            saveFitLibrary = FALSE))
      control$g.hat <- g.fit$SL.densities
      rm(g.fit)
      #control$g.hat <- function(a, w) c(predict.cmdSuperLearner(g.fit, newA = a, newW = w))

      if(control$verbose) cat("\n")
    }
  }

  if(control$verbose) cat("Computing Omega...")
  if(!control$cross.fit) {
    ord <- order(A)
    A <- A[ord]
    Y <- Y[ord]
    W <- W[ord,,drop=FALSE]
    if(inherits(control$g.hat, "function")) {
      g.hats <- control$g.hat(A, W)
      control$g.hat <- NULL
    }
    else g.hats <- control$g.hat
    if(any(g.hats < control$g.trunc)) {
      warning("Truncating g.hats below. Possible positivity issues.")
      g.hats[g.hats < control$g.trunc] <- control$g.trunc
    }
    a.ecdf <- ecdf(A)
    a.weights <- sapply(a.vals, function(a0) mean(A == a0))
    A.a.val <- sapply(A, function(a0) which(a.vals == a0))
    u.vals <- a.ecdf(a.vals)
    mu.hats.a.vals <- sapply(a.vals, function(a0) control$mu.hat(a0, W)) #rows index W, columns index a.vals
    control$mu.hat <- NULL
    mu.hats <- mu.hats.a.vals[,A.a.val]
    theta.a.vals <- colMeans(mu.hats.a.vals)
    theta.A <- theta.a.vals[A.a.val]
    mu.hats.data <- diag(mu.hats)
    partial.mu.means <- t(apply(mu.hats, 1, cumsum)) / n
    gamma.hat <- mean(mu.hats)
    Omega.a.vals <- sapply(a.vals, function(a0) mean(as.numeric(A <= a0) * theta.A)) - gamma.hat * u.vals

    IF.vals <- sapply(a.vals, function(a0) {
      if(any(A <= a0))  mumean.vals <- partial.mu.means[,max(which(A <= a0))]
      else mumean.vals <- 0
      (as.numeric(A <= a0) - a.ecdf(a0)) * ((Y - mu.hats.data) / g.hats + theta.A - gamma.hat) + mumean.vals - partial.mu.means[,n] * a.ecdf(a0) - 2 * Omega.a.vals[which(a.vals == a0)]
    })

    Omega.hat <- colMeans(IF.vals) + Omega.a.vals

    if(control$verbose) cat("\nComputing covariance...\n")

    if (return_ic_est){
      return(list("est" = Omega.hat, "ic" = IF.vals, "gridpnts" = a.vals))
    }else{
      Sigma.hat <- sapply(1:length(a.vals), function(s) sapply(1:length(a.vals), function(t) {
        mean(IF.vals[,s] * IF.vals[,t])
      }))
    }
  }else{
    fold.Omega.hats <- matrix(NA, nrow = control$V, ncol = length(a.vals))
    IF.vals <- vector(length=control$V, mode='list')
    for(j in 1:control$V) {
      if(control$verbose) cat("fold", j, "...")
      Nv <- sum(control$folds == j)
      A.test <- A[control$folds == j]
      Y.test <- Y[control$folds == j]
      W.test <- W[control$folds == j,, drop=FALSE]
      ord <- order(A.test)
      A.test <- A.test[ord]
      Y.test <- Y.test[ord]
      W.test <- W.test[ord,, drop=FALSE]
      if(inherits(control$g.hat[[j]], "function")) {
        g.hats.test <- control$g.hat[[j]](a = A.test, w = W.test)
      }
      else g.hats.test <- control$g.hat[[j]]

      if(any(g.hats.test < control$g.trunc)) {
        warning("Truncating g.hats below. Possible positivity issues.")
        g.hats.test[g.hats.test < control$g.trunc] <- control$g.trunc
      }
      a.ecdf <- ecdf(A.test)
      a.weights <- sapply(a.vals, function(a0) mean(A.test == a0))
      A.a.val <- sapply(A.test, function(a0) which(a.vals == a0))
      u.vals <- a.ecdf(a.vals)
      mu.hats.a.vals <- sapply(a.vals, function(a0) control$mu.hat[[j]](a=a0, w=W.test)) #rows index W, columns index a.vals
      mu.hats <- mu.hats.a.vals[,A.a.val]
      theta.a.vals <- colMeans(mu.hats.a.vals)
      theta.A <- theta.a.vals[A.a.val]
      mu.hats.data <- diag(mu.hats)
      partial.mu.means <- t(apply(mu.hats, 1, cumsum)) / Nv
      gamma.hat <- mean(mu.hats)
      Omega.a.vals <- sapply(a.vals, function(a0) mean(as.numeric(A.test <= a0) * theta.A)) - gamma.hat * u.vals

      IF.vals[[j]] <- sapply(a.vals, function(a0) {
        if(any(A.test <= a0)) mumean.vals <- partial.mu.means[,max(which(A.test <= a0))]
        else mumean.vals <- 0
        (as.numeric(A.test <= a0) - a.ecdf(a0)) * ((Y.test - mu.hats.data) / g.hats.test + theta.A - gamma.hat) + mumean.vals - partial.mu.means[,ncol(partial.mu.means)] * a.ecdf(a0) - 2 * Omega.a.vals[which(a.vals == a0)]
      })
      fold.Omega.hats[j,] <- colMeans(IF.vals[[j]]) + Omega.a.vals
    }
    Omega.hat <- colMeans(fold.Omega.hats)
    if(control$verbose) cat("\nComputing covariance...\n")
    if (return_ic_est) {
      IF.vals <- do.call(rbind, IF.vals)
      return(list("est" = Omega.hat, "ic" = IF.vals))
    }else{
      Sigma.hat <- sapply(1:length(a.vals),
                          function(s) sapply(1:length(a.vals), function(t) {
                            mean(unlist(lapply(IF.vals, function(IF) mean(IF[,s] * IF[,t]))))
                          }))
    }
  }

  if(control$verbose) cat("Simulating paths...\n")

  paths <- rmvnorm(control$n.sim, sigma=Sigma.hat)

  if(control$verbose) cat("Computing statistics...\n")

  a.weights <- sapply(a.vals, function(a) mean(A == a))
  ret <- t(sapply(p, function(pp) {
    stat <- ifelse(pp < Inf, (sum(abs(Omega.hat )^pp * a.weights))^{1/pp}, max(abs(Omega.hat)))

    if(pp < Inf) {
      stats <- (apply(abs(paths)^pp, 1, function(row) sum(row * a.weights)))^{1/pp}
    } else {
      stats <- apply(abs(paths), 1, max)
    }

    p.val <- mean(stats / sqrt(n) > stat)

    q <- quantile(stats, (1 - (1-control$conf.level) / 2))
    ci.ll <- max(stat - q / sqrt(n), 0)
    ci.ul <- stat + q / sqrt(n)

    res <- c(stat, p.val, ci.ll, ci.ul)

    res

  }))
  ret.df <- data.frame(p = p, obs.stat = ret[,1], p.val = ret[,2], ci.ll = ret[,3], ci.ul = ret[,4])
  ret.list <- list(test = ret.df)
  if (control$return.Omega) {
    ret.list <- c(ret.list, list(Omega.hat = data.frame(a = a.vals, Omega.hat),
                                 IF.vals = IF.vals, paths = paths))
  }
  if (control$save.nuis.fits) {
    ret.list <- c(ret.list, mu.hat = control$mu.hat, g.hat = control$g.hat)
    if (control$cross.fit) ret.list <- c(ret.list, folds = control$folds)
  }

  return(ret.list)
}

#' Initialize control parameters for causalNullTest
#'
#' This function initializes the control parameters for use in \code{causalNullTest}. The outcome regression function mu is by default estimated using \code{\link[SuperLearner]{SuperLearner}}, and the propensity is estimated using the conditional mixed density method implemented in \code{\link{cmdSuperLearner}}. Alternatively, the estimation process can be overriden by providing predictions from pre-fit nuisance estimators.
#'
#' @param mu.SL.library Library of candidate learners for the outcome regression to be passed on to \code{\link[SuperLearner]{SuperLearner}}. Ignored if \code{mu.hats} is provided.
#' @param g.SL.library Library of candidate learners for the outcome regression to be passed on to \code{\link{cmdSuperLearner}}.
#' @param g.n.bins Numeric vector of number of bins to use for estimation of the propensity. Passed on to \code{\link{cmdSuperLearner}}.
#' @param cross.fit Logical indicating whether to cross-fit nuisance parameters. Defaults to \code{TRUE}.
#' @param V Positive integer number of folds for cross-fitting. Defaults to 10.
#' @param folds Optional \code{n x 1} numeric vector indicating which fold each observation is in.
#' @param save.nuis.fits Logical indicating whether to save the fitted nuisance objects.
#' @param mu.hat Optional pre-fit outcome regression. If \code{cross.fit} is \code{FALSE}, then a function that takes arguments \code{a} (a vector) and \code{w} (a data.frame) and returns predictions of the outcome regression function. If \code{cross.fit} is \code{TRUE}, then a list of functions of length \code{V} with the fitted outcome regression functions on each of the \code{V} training sets. If provided as a list of functions, then \code{folds} must be provided. If \code{mu.SL.library = NULL}, then \code{mu.hats} must be specified.
#' @param g.hat Optional pre-fit treatment propensities. If \code{cross.fit} is \code{FALSE}, then a function that takes arguments \code{a} (a vector) and \code{w} (a data.frame) and returns predictions of the standardized propensity function. If \code{cross.fit} is \code{TRUE}, then a list of functions of length \code{V} with the fitted standardized propensity functions on each of the \code{V} training sets. If provided as a list of functions, then \code{folds} must be provided. If \code{g.SL.library = NULL}, then \code{g.hats} must be specified.
#' @param g.trunc Value at which to truncate predicted propensities from below. Any propensity values less than \code{g.trunc} will be set to \code{g.trunc}.
#' @param n.sim Number of simulations to use for the limiting Gaussian process in computing approximate quantiles.
#' @param return.Omega Logical indicating whether to return the estimated primitive function Omega.
#' @param conf.level Optional confidence level to use for computing confidence bands for Omega.
#' @param verbose Logical indicating whether to print progress to the command line.
#' @return Named list containing the control options.

causalNullTest.control <- function(mu.SL.library = c("SL.mean", "SL.glm", "SL.gam", "SL.earth"),
                                   g.SL.library = c("SL.mean", "SL.glm", "SL.gam", "SL.earth"),
                                   g.n.bins = 2:(length(unique(A))/50),
                                   cross.fit = TRUE,
                                   V = 10,
                                   folds = NULL,
                                   save.nuis.fits = FALSE,
                                   mu.hat = NULL,
                                   g.hat = NULL,
                                   g.trunc = .001, n.sim = 1e4,
                                   return.Omega = FALSE,
                                   conf.level = .95,
                                   verbose = FALSE) {
  list(mu.SL.library = mu.SL.library, g.SL.library = g.SL.library, g.n.bins = g.n.bins, cross.fit = cross.fit, V = V,
       folds = folds, mu.hat = mu.hat,  g.hat = g.hat, g.trunc = g.trunc, n.sim = n.sim, return.Omega = return.Omega,
       save.nuis.fits = save.nuis.fits, conf.level = conf.level, verbose = verbose)
}

.check.input <- function(Y, A, W, p, control) {
  if(length(Y) != length(A)) stop("Y and A must have the same length")
  if(!is.null(control$mu.hat)) {
    if(control$cross.fit) {
      if(is.null(control$folds)) {
        stop("mu.hat provided and cross.fit=TRUE, but folds not provided.")
      }
      if(length(control$mu.hat) < length(unique(control$folds))) {
        stop("mu.hat provided and cross.fit=TRUE, but mu.hats is not a list with the same length as the number of folds.")
      }
    } else {
      if(!is.null(control$folds)) {
        stop("mu.hat provided and cross.fit=FALSE, but folds were provided.")
      }
    }
  }
  if(!is.null(control$g.hat)) {
    if(control$cross.fit) {
      if(is.null(control$folds)) {
        stop("g.hat provided and cross.fit=TRUE, but folds not provided.")
      }
      if(length(control$g.hat) < length(unique(control$folds))) {
        stop("g.hat provided and cross.fit=TRUE, but g.hats is not a list with the same length as the number of folds.")
      }
    } else {
      if(!is.null(control$folds)) {
        stop("g.hat provided and cross.fit=FALSE, but folds were provided.")
      }
    }
  }
  if(is.null(control$mu.SL.library)) {
    if(is.null(control$mu.hats)) {
      stop("mu.hats must be provided if mu.SL.library is not specified.")
    }
  } else {
    if(is.null(control$mu.hats)) {
      if(control$cross.fit & is.null(control$folds) & is.null(control$V)) {
        stop("cross.fit = TRUE, but number of folds not specified.")
      }
    }
  }
  if(is.null(control$g.SL.library)) {
    if(is.null(control$g.hats)) {
      stop("g.hats must be provided if g.SL.library is not specified.")
    }
  } else {
    if(is.null(control$g.hats)) {
      if(control$cross.fit & is.null(control$folds) & is.null(control$V)) {
        stop("cross.fit = TRUE, but number of folds not specified.")
      }
    }
  }
  if(any(is.na(Y) | is.na(A) | is.na(W))) {
    stop("Missing outcome, treatment, or confounders detected; missing data not allowed.")
  }
}

#' SuperLearner-based estimation of (c)onditional (m)ixed continuous-discrete (d)ensity function
#'
#' This function estimates a standardized conditional density function that may have both continuous and discrete components. Let \code{A} be a univariate exposure and \code{W} be a p-dimensional vector of covariates. Then this function estimates p(a | w) / p(a) at points  of absolute continuity of the marginal distribution of \code{A}, where p(a | w) = (d/da)P(A <= a | W = w) is the conditional density of \code{A} given \code{W = w} evaluated at a and p(a) = (d/da) P(A <= a) is the marginal density of \code{A}, and at discrete points of the marginal distribution of \code{A}, this function estimates P(A = a | W = w)/P(A = a).
#'
#' The basic idea is to first transform A by its empirical CDF to obtain U = F_n(A), because the conditional density or  mass function of F(A) equals the standardized conditional density/mass of A for F(a) = P(A <= a). Then, the support [0,1] of U is discretized into \code{b} sets (which may be singleton sets) using the marginal distribution of U. Within each of these sets, the conditional probability that U falls in the set given \code{W} is estimated using the specified wrapper algorithms from the \code{\link[SuperLearner]{SuperLearner}} package. This procedure is repeated over a set of possible number of bins \code{b}, and optimal weights for all algorithms are found using negative log likelihood loss.
#'
#' @param A \code{n x 1} numeric vector of exposure values.
#' @param W \code{n x p} data.frame of covariate values to condition upon.
#' @param newA \code{m x 1} numeric vector of new exposure values at which to obtain predictions. Defaults to \code{A}.
#' @param newW \code{m x p} data.frame of new covariate values at which to obtain predictions. Defaults to \code{W}.
#' @param control Optional list of control parameters. See \code{\link{cmdSuperLearner.control}} for details.
#' @param cvControl Optional list of control parameters for cross-validation. See \code{\link{cmdSuperLearner.cvControl}} for details.
#' @return \code{cmdSuperLearner} returns a named list with the following elements:
#' \item{fits}{A list of fits for each of the number of bins specified in control$n.bins, as output by \link{cmdSuperLearner.onebin.}}
#' \item{cv.library.densities}{Cross-validated densities from every element of the library.}
#' \item{library.densities}{Densities predicted using the new data.}
#' \item{SL.densities}{Super learner densities predicted on the new data.}
#' \item{coef}{The coefficient of the meta-learner.}
#' \item{library.names}{Names of library algortihms.}
#' \item{a.ecdf}{Empirical CDF of the exposure.}
#' \item{control}{Control elements used in fitting.}
#' \item{cvControl}{Cross-validation controls used in fitting.}
#'
#' @examples
#' # Sample data
#' #n <- 1000
#' #W <- data.frame(W1 = runif(n))
#' #Z <- rbinom(n, size = 1, prob = 1/(1 + exp(2-W$W1)))
#' #A <- (1-Z) * rnorm(n, mean = W$W1, sd = abs(1 + W$W1))
#' #fit <- cmdSuperLearner(A, W, control=list(SL.library = c("SL.mean", "SL.glm", "SL.gam", "SL.earth"), verbose=TRUE, n.bins = c(2:10)))

cmdSuperLearner <- function(A, W, newA = A, newW = W, control = list(), cvControl = list()) {
  n <- nrow(W)

  call <- match.call(expand.dots = TRUE)
  control <- do.call("cmdSuperLearner.control", control)
  cvControl <- do.call("cmdSuperLearner.CV.control", cvControl)

  validRows <- cmdCVFolds(n = n, cvControl = cvControl)

  library(Rsolnp)

  fits <- NULL
  for(b in control$n.bins) {
    if(control$verbose) cat("\nEstimating models with", b, "bins... ")
    fits[[paste0('dens.fit.', b, 'bins')]] <- cmdSuperLearner.onebin(A, W, newA=newA, newW = newW, b=b, SL.library = control$SL.library, verbose = control$verbose, validRows = validRows, saveFitLibrary = control$saveFitLibrary)
  }

  algs.per.bin <- ncol(fits[[1]]$cv.library.densities)
  n.algs <- length(control$n.bins) * algs.per.bin
  cv.library.densities <- matrix(NA, nrow=n, ncol=n.algs)
  library.densities <- matrix(NA, nrow=length(newA), ncol=n.algs)
  library.names <- NULL
  start.col <- 1
  for(b in control$n.bins) {
    end.col <- start.col + algs.per.bin - 1
    cv.library.densities[,start.col:end.col] <- fits[[paste0('dens.fit.', b, 'bins')]]$cv.library.densities
    library.densities[,start.col:end.col] <- fits[[paste0('dens.fit.', b, 'bins')]]$library.densities
    library.names <- c(library.names, fits[[paste0('dens.fit.', b, 'bins')]]$alg.names)
    start.col <- end.col + 1
  }

  if(control$verbose) cat("\nOptimizing model weights...\n")

  # Remove algs with errors in cv predictions
  errors.in.library <- apply(cv.library.densities, 2, function(col) any(is.na(col)))
  if(any(errors.in.library)) warning(paste0("Errors in the following candidate algorithms: ", library.names[which(errors.in.library)]))
  n.include <- sum(!errors.in.library)

  # Do SL log-likelihood optimization
  cv_risk <- function(beta) -mean(log(cv.library.densities[,!errors.in.library] %*% beta))
  capture.output(solnp_solution <- solnp(rep(1/n.include, n.include), cv_risk, eqfun=sum, eqB=1, ineqfun=function(beta) beta, ineqLB=rep(0,n.include), ineqUB=rep(1, n.include)))
  coef <- rep(0, n.algs)
  coef[!errors.in.library] <- solnp_solution$pars
  if(control$verbose) {
    cat("Top five learners by weight: \n")
    for(j in 1:5) {
      cat(library.names[order(coef, decreasing = TRUE)[j]], " (weight ", sort(coef, decreasing = TRUE)[j], ")\n", sep='')
    }
  }
  SL.density <- c(library.densities[,!errors.in.library,drop=FALSE] %*% solnp_solution$pars)

  return(list(fits = fits, cv.library.densities = cv.library.densities, library.densities = library.densities, SL.densities = SL.density, coef = coef, library.names = library.names, a.ecdf = ecdf(A), control=control, cvControl = cvControl))

}

#' Control parameters for the conditional mixed density Super Learner
#'
#' This function initiates control parameters for the \code{\link{cmdSuperLearner}} function.
#'
#' @param n.bins Vector of integers >= 2 indicating the number of bins to use for discretization. Defaults to \code{2:floor(n/100)}.
#' @param SL.library Library to use for bin-specific SuperLearners. Defaults to \code{c("SL.mean", "SL.glm", "SL.gam", "SL.earth")}.
#' @param saveFitLibrary Logical indicating whether to save the fit library on the full data. Defaults to \code{TRUE}. If \code{FALSE}, cannot obtain predicted values on new data later.
#' @param verbose Logical indicating whether to report progress of the estimation process.
#' @return Returns a named list with control parameters.

cmdSuperLearner.control <- function (n.bins = 2:floor(length(unique(A))/50), SL.library = c("SL.mean", "SL.glm", "SL.gam", "SL.earth"), saveFitLibrary = TRUE, verbose = FALSE) {
  list(n.bins = n.bins, SL.library = SL.library, saveFitLibrary = saveFitLibrary, verbose = verbose)
}

#' Control parameters for the cross validation steps in conditional mixed density Super Learner
#'
#' This function initiates control parameters for the cross-validation in \code{\link{cmdSuperLearner}} function.
#'
#' @param V Number of cross-validation folds. Defaults to 10.
#' @param shuffle Logical indicating whether to shuffle the indices, or to simply assign sequentially. Defaults to \code{TRUE}. Should almost always be set to \code{TRUE} unless it is explicitly desired to assign sequentially.
#' @param validRows Optional custom list of indices for validation folds.
#' @return Returns a list of length \code{V} with validation indices for each of the folds.

cmdSuperLearner.CV.control <- function (V = 10L, shuffle = TRUE, validRows = NULL) {
  V <- as.integer(V)
  if (!is.null(validRows)) {
    if (!is.list(validRows)) {
      stop("validRows must be a list of length V containing the row numbers for the corresponding validation set")
    }
    if (!identical(V, length(validRows))) {
      stop("V and length(validRows) must be identical")
    }
  }
  list(V = V, shuffle = shuffle, validRows = validRows)
}

#' Create cross-validation folds
#'
#' This function generates cross-validation folds.
#'
#' @param n Number of observations.
#' @param cvControl Named list generated by \link{cmdSuperLearner.CV.control}.

cmdCVFolds <- function (n, cvControl) {
  if (!is.null(cvControl$validRows)) return(cvControl$validRows)
  stratifyCV <- cvControl$stratifyCV
  shuffle <- cvControl$shuffle
  V <- cvControl$V
  if (shuffle) {
    validRows <- split(sample(1:n), rep(1:V, length = n))
  }
  else {
    validRows <- split(1:n, rep(1:V, length = n))
  }

  return(validRows)
}

.find.bin <- function(x, bins) {
  mat <- t(sapply(x-1e-10, function(x0) {
    unlist(lapply(bins, function(bin) {
      interval_contains_element(bin, x0)
    }))
  }))
  if(any(rowSums(mat) > 1)) stop("Overlapping bins")
  if(any(rowSums(mat) == 0)) stop("Element outside all bins")

  apply(mat, 1, function(row) which(row))
}

#' cmdSuperLearner for a specific number of bins
#'
#' This function estimates the conditional mixed density using a given number of bins \code{b}.
#'
#' @param A \code{n x 1} numeric vector of exposure values.
#' @param W \code{n x p} data.frame of covariate values to condition upon.
#' @param newA \code{m x 1} numeric vector of new exposure values at which to obtain predictions. Defaults to \code{A}.
#' @param newW \code{m x p} data.frame of new covariate values at which to obtain predictions. Defaults to \code{W}.
#' @param b Integer number of bins >= 2.
#' @param SL.library Library to use for bin-specific probabilities.
#' @param verbose Logical indicating whether to print progress reports to the command line.
#' @param validRows List of rows in each CV fold.
#' @return Returns a named list with the following elements:
#' \item{bins}{List of length \code{b} containing the sets used for each bin.}
#' \item{bin.fits}{List of length \code{b} containing the estimated SuperLearner objects for each bin.}
#' \item{a.ecdf}{Empirical CDF of the exposure.}
#' \item{SL.bin.probs}{SuperLearner conditional probabilities of being in each bin for the new data.}
#' \item{SL.densities}{SuperLearner conditional standardized mixed density correspondint to each bin for the new data.}
#' \item{cv.library.densities}{Cross-validated library conditional standardized mixed density corresponding to each bin.}
#' \item{library.densities}{Library conditional standardized mixed density corresponding to each bin fit on the new data.}
#' \item{alg.names}{Algorithm names.}
#' @examples
#' # Define parameters
#' #n <- 300
#' #W <- data.frame(matrix(rnorm(3 * n), ncol = 3))
#' #Z <- rbinom(n, size = 1, prob = 1/(1 + exp(2-W[,1] + W[,2])))
#' #A <- (1-Z) * rnorm(n, mean = W[,2] - W[,3], sd = abs(1 + W[,1]))
#' #validRows <- cmdCVFolds(n = n, cvControl = list(V = 10, shuffle=TRUE, validRows = NULL))
#' #bin.fit <- cmdSuperLearner.onebin(A, W, b = 2, SL.library = c("SL.mean", "SL.glm", "SL.gam", "SL.earth"), verbose=TRUE, validRows = validRows)

cmdSuperLearner.onebin <- function(A, W, newA=A, newW=W, b, SL.library, verbose, validRows, saveFitLibrary) {
  n.folds <- length(validRows)
  a.ecdf <- ecdf(A)
  U <- a.ecdf(A)
  n <- nrow(W)
  m <- nrow(newW)
  W <- as.data.frame(W)
  newW <- as.data.frame(newW)
  U <- as.numeric(U)
  library(Rsolnp)
  library(SuperLearner)
  library(sets)
  tab <- table(U)
  un.U <- as.numeric(names(tab))
  un.U.frac <- as.numeric(tab) / length(U)
  if(b <= 1) stop("Number of bins must be > 1")
  if(length(un.U) < b) stop("Number of bins must not be larger than number of unique values of U.")
  if(length(un.U) == b) {
    mass.pts <- un.U
    bins <- data.frame(bin = 1:b, lower = un.U, upper = un.U, bin.length = 0, mass.pt = TRUE)
  }
  if(length(un.U) > b) {
    if(any(un.U.frac >= 1/b)) {
      mass.pts <- un.U[un.U.frac >= 1/b]
      n.mass.pts <- length(mass.pts)
      mass.pt.lowers <- round(sapply(mass.pts, function(x) max(c(U[x - U > 1/(10*n)], 0))), 7)
      mass.intervals <- lapply(1:n.mass.pts, function(j) {
        interval(mass.pt.lowers[j], mass.pts[j], bounds="(]")
      })
      cont.intervals <- data.frame(lower=c(0,mass.pts), upper=c(mass.pt.lowers, 1))
      cont.intervals$length <- cont.intervals$upper - cont.intervals$lower
      cont.intervals <- subset(cont.intervals, length > 0)
    }
    else {
      mass.pts <- NULL
      n.mass.pts <- 0
      mass.intervals <- NULL
      cont.intervals <- data.frame(lower=0, upper=1, length=1)
    }

    n.cont.bins <- b - n.mass.pts
    if(n.cont.bins > 0) {
      delta <- sum(cont.intervals$length) / n.cont.bins
      delta <- round(delta, digits=ceiling(log10(n)) + 2)
      cont.bin.endpts <- matrix(NA, nrow=n.cont.bins, ncol=2)

      for(j in 1:n.cont.bins) {
        if(j == 1) start <- cont.intervals$lower[1]
        else start <- end
        start.interval <- max(which(cont.intervals$lower <= start + 1e-6 & start <= cont.intervals$upper + 1e-6))
        if(start == cont.intervals$upper[start.interval]) {
          start.interval <- start.interval + 1
          start <- cont.intervals$lower[start.interval]
        }
        end <- start + delta
        end.interval <- start.interval
        if(!(all.equal(end, cont.intervals$upper[end.interval]) == TRUE) && end > cont.intervals$upper[end.interval]) {
          length.used <- cont.intervals$upper[end.interval] - start
          length.left <- delta - length.used
          end.interval <- end.interval + 1
          end <- cont.intervals$lower[end.interval] + length.left
        }
        while(!(all.equal(end, cont.intervals$upper[end.interval]) == TRUE) && end > cont.intervals$upper[end.interval]) {
          length.used <- length.used + cont.intervals$upper[end.interval] - cont.intervals$lower[end.interval]
          length.left <- delta - length.used
          end.interval <- end.interval + 1
          end <- cont.intervals$lower[end.interval] + length.left
        }
        end <- round(end, digits=ceiling(log10(n)) + 3)
        if(j == n.cont.bins) end <- cont.intervals$upper[nrow(cont.intervals)]
        cont.bin.endpts[j,] <- c(start, end)
      }

      cont.intervals <- lapply(1:n.cont.bins, function(j) {
        if(j == 1) int <- interval(cont.bin.endpts[j, 1], cont.bin.endpts[j, 2], bounds="[]")
        else int <- interval(cont.bin.endpts[j, 1], cont.bin.endpts[j, 2], bounds="(]")
        if(n.mass.pts > 0) {
          for(k in 1:n.mass.pts) {
            int <- interval_complement(mass.intervals[[k]], int)
          }
        }
        return(int)
      })
    } else {
      cont.intervals <- list()
    }

    bins <- c(mass.intervals, cont.intervals)
  }

  bin.sizes <- unlist(lapply(bins, interval_measure))

  disc.U <- .find.bin(U, bins)

  U.new <- a.ecdf(newA)
  disc.U.new <- .find.bin(U.new, bins)

  bin.fracs <- sapply(1:b, function(j) mean(disc.U == j))

  bin.fits <- NULL
  bin.probs <- matrix(NA, nrow=n, ncol=b)
  for(bin in 1:b) {
    if(verbose) cat("bin", bin, "... ")
    capture.output(bin.fit <- try(SuperLearner(Y=as.numeric(disc.U==bin), X=W, newX=newW, family='binomial', SL.library = SL.library, method='method.NNloglik', control = list(saveFitLibrary=saveFitLibrary), cvControl = list(V=n.folds, validRows=validRows)), silent=TRUE))
    if(class(bin.fit) == "try-error") {
      capture.output(bin.fit <- try(SuperLearner(Y=as.numeric(disc.U==bin), X=W, newX=newW, family='binomial', SL.library = SL.library, method='method.NNLS',
                                                 #potentially replace with
                                                 control = list(saveFitLibrary=saveFitLibrary), cvControl = list(V=n.folds, validRows=validRows)), silent=TRUE))
    }
    if(class(bin.fit) == "try-error") {
      capture.output(bin.fit <- try(SuperLearner(Y=as.numeric(disc.U==bin), X=W, newX=newW, family='binomial', SL.library = SL.library, method='method.NNLS2', control = list(saveFitLibrary=saveFitLibrary), cvControl = list(V=n.folds, validRows=validRows)), silent=TRUE))
    }
    if(class(bin.fit) != "try-error") {
      bin.fits[[paste0("bin", bin, ".SL")]] <- bin.fit
      bin.probs[,bin] <- bin.fit$SL.predict
    } else {
      bin.mean <- mean(as.numeric(disc.U==bin))
      if(class(SL.library) == "character") n.algs <- length(SL.library)
      else n.algs <- sum(unlist(lapply(SL.library, function(sl) length(sl) - 1)))
      bin.fits[[paste0("bin", bin, ".SL")]] <- list(Z = matrix(bin.mean, nrow=n,ncol=n.algs), library.predict = matrix(bin.mean, nrow=m,ncol=n.algs))
      bin.probs[,bin] <- bin.mean
    }
  }

  #SL.bin.probs <- .make.doubly.stochastic(bin.probs, row.sums = rep(1, m), col.sums = bin.fracs * m)
  SL.bin.probs <- bin.probs / rowSums(bin.probs)

  SL.densities <- SL.bin.probs[cbind(1:m, disc.U.new)] / bin.sizes[disc.U.new]

  n.alg <- ncol(bin.fits[["bin1.SL"]]$Z)
  cv.library.densities <-  matrix(NA, nrow=n, ncol=n.alg)
  library.densities <- matrix(NA, nrow=m, ncol=n.alg)
  for (j in 1:n.alg) {
    cv.bin.probs <- library.bin.probs <- matrix(NA, nrow=n, ncol=b)
    for (bin in 1:b) {
      cv.bin.probs[, bin] <- bin.fits[[paste0("bin", bin, ".SL")]]$Z[,j]
      library.bin.probs[, bin] <- bin.fits[[paste0("bin", bin, ".SL")]]$library.predict[,j]
    }
    if(any(is.na(cv.bin.probs)) | any(colSums(cv.bin.probs) == 0) | any(rowSums(cv.bin.probs) == 0)) {
      cv.library.densities[,j] <- rep(NA, n)
    } else {
      #cv.bin.probs <- .make.doubly.stochastic(cv.bin.probs, row.sums = rep(1, n), col.sums = bin.fracs * n)
      cv.bin.probs <- cv.bin.probs / rowSums(cv.bin.probs)
      cv.library.densities[,j] <- cv.bin.probs[cbind(1:n, disc.U)] / bin.sizes[disc.U]
    }

    if(any(is.na(library.bin.probs)) | any(colSums(library.bin.probs) == 0) | any(rowSums(library.bin.probs) == 0)) {
      library.densities[,j] <- rep(NA, m)
    } else {
      #library.bin.probs <- .make.doubly.stochastic(library.bin.probs, row.sums = rep(1, n), col.sums = bin.fracs * n)
      library.bin.probs <- library.bin.probs / rowSums(library.bin.probs)
      library.densities[,j] <- library.bin.probs[cbind(1:m, disc.U.new)] / bin.sizes[disc.U.new]
    }

  }

  alg.names <- paste0(bin.fits[["bin1.SL"]]$libraryNames, "_", b, "bins")

  ret <- list(bins = bins,  a.ecdf = a.ecdf, SL.bin.probs = SL.bin.probs, SL.densities = SL.densities, cv.library.densities = cv.library.densities, library.densities = library.densities, alg.names = alg.names)
  if(saveFitLibrary) ret$bin.fits <- bin.fits
  return(ret)

}

.make.doubly.stochastic <- function(mat, row.sums, col.sums, tol = .001) {
  ret <- mat
  while(sum(abs(rowSums(ret) - row.sums)) > tol | sum(abs(colSums(ret) - col.sums)) > tol) {
    ret <- ret / (rowSums(ret) / row.sums)
    ret <- t( t(ret) / (colSums(ret) / col.sums))
  }
  return(ret)
}

#' Prediction method for cmdSuperLearner
#'
#' This function predicts standardized conditional density function values given a fitted model and new data,
#'
#' @param fit Fitted \code{\link{cmdSuperLearner}} object. Must have been run with \code{control$saveFitLibrary = TRUE}.
#' @param newA \code{m x 1} numeric vector of new exposure values.
#' @param newW \code{m x p} data.frame of new covariate values.
#' @param threshold Minimum coefficient value for which library algorithms should be included in the prediction.
#' @return \code{cmdSuperLearner} returns a named list with the following elements:
#' \item{fit.times}{The time points at which the counterfactual survival curves (and contrasts) were fit.}
#'
#' @examples
#' # Sample data
#' set.seed(220)
#' # n <- 1000
#' # W <- data.frame(W1 = runif(n))
#' # Z <- rbinom(n, size = 1, prob = 1/(1 + exp(2-W$W1)))
#' # A <- (1-Z) * rnorm(n, mean = W$W1, sd = abs(1 + W$W1))
#' # fit <- cmdSuperLearner(A, W, control=list(SL.library = c("SL.mean", "SL.glm", "SL.gam", "SL.earth"), verbose=TRUE, n.bins = c(2:10)))
#' # Get predicted standardized "density" (really mass) at 0
#' # pred <- predict.cmdSuperLearner(fit = fit, newA = rep(0, n), newW = W)
#' # true.g <- 1 /(integrate(function(x) 1/(1 + exp(2-x)), 0, 1)$value * (1 + exp(2-W$W1)))
#' # plot(true.g, pred)
#' # abline(0,1, col='red')

predict.cmdSuperLearner <- function(fit, newA, newW, threshold = .001) {
  library(SuperLearner)
  newW <- as.data.frame(newW)
  new.U <- fit$a.ecdf(newA)
  trunc.coef <- fit$coef
  trunc.coef[trunc.coef < threshold] <- 0
  trunc.coef <- trunc.coef / sum(trunc.coef)
  nonzero <- which(trunc.coef > 0)
  lib.name.splits <- strsplit(fit$library.names, "_")
  lib.name.nbins <- unlist(lapply(lib.name.splits, function(l) as.numeric(strsplit(l[3], "bins")[[1]])))
  lib.name.alg <- unlist(lapply(lib.name.splits, function(l) paste0(l[1:2], collapse="_")))
  bins.to.fit <- unique(lib.name.nbins[nonzero])
  pred.densities <- matrix(NA, nrow=length(newA), ncol=length(fit$library.names))
  for(bin in bins.to.fit) {
    ind <- which(fit$control$n.bins == bin)
    new.bins <- .find.bin(new.U, bins = fit$fits[[ind]]$bins)
    bin.sizes <- unlist(lapply(fit$fits[[ind]]$bins, interval_measure))
    pred.probs <- matrix(NA, nrow = length(new.U), ncol = length(unique(lib.name.alg)))
    for(k in 1:length(fit$fits[[ind]]$bin.fits)) {
      if(any(new.bins == k)) {
        pred.probs[new.bins == k,] <- predict.SuperLearner(fit$fits[[ind]]$bin.fits[[k]], newdata = newW[new.bins == k,, drop=FALSE], onlySL = TRUE)$library.predict
      }
    }
    pred.probs <- pred.probs / rowSums(pred.probs)
    pred.densities[,which(lib.name.nbins == bin)] <- pred.probs / bin.sizes[new.bins]
  }
  c(pred.densities[,nonzero,drop=FALSE] %*% trunc.coef[nonzero])
}

#' Functions for converting from an IC and estimate of a function to the
#' corresponding basis function and IC.
#' @param est estimate of function
#' @param ic IC estimate
#'
#' @importFrom fda create.fourier.basis eval.basis
#' @export

convert_to_basis <- function(est, ic, gridvals, num_basis = 10) {
  uncor_est <- est - colMeans(ic)
  newfun <- stepfun(x = gridvals, y = c(0, uncor_est))
  fbasis_obj <- fda::create.fourier.basis(rangeval = c(0, 1),
                                          nbasis = num_basis)
  newgrid <- seq(0, 1, length.out = 1000)
  om_grid <- newfun(newgrid)
  mat <- fda::eval.basis(newgrid, fbasis_obj)
  ic_at_newgrid <- t(apply(ic, MARGIN = 1, FUN = function(x) {
    obs_fun <- stepfun(gridvals, y = c(0, x))
    return(obs_fun(newgrid))
  }))
  numr <- ic_at_newgrid %*% mat / nrow(mat)
  denom <- colMeans(mat ** 2)
  new_ic <- sweep(x = numr, MARGIN = 2, denom, "/")
  newest <- apply(mat, 2, function(x) mean(x * om_grid)) / denom
  return(list(est = as.numeric(newest + colMeans(new_ic)), ic = new_ic))
}


plot.width = {img_width}
plot.height = {img_height}
plot.range = {date_range}
plot.typeid = {itemid}
plot.locationid = {locationid}
plot.title = '{plot_title}'
plot.path = '{plot_path}'

date.min <- Sys.Date() - plot.range

## Event List ##
event.query <- paste0(
    'SELECT datetime, eventName ',
    'FROM event_list ',
    'WHERE eventGroup in (\'patch\') ',
    'AND datetime > \'', date.min, '\' '
)
event <- sqlQuery(emd, event.query)
event$datetime <- as.POSIXlt(event$datetime, tz='GMT')
do_lines <- TRUE
if(nrow(event)==0){{
    do_lines <- FALSE
}}

## Get Data ##
ec.query <- paste0(
    'SELECT price_date AS `date`, price_time AS `hour`, locationid, typeid, ',
    'SUM(IF(buy_sell=1, price_best, NULL)) AS `SellOrder`, ',
    'SUM(IF(buy_sell=1, order_volume, NULL)) AS `SellVolume`, ',
    'SUM(IF(buy_sell=0, price_best, NULL)) AS `BuyOrder`, ',
    'SUM(IF(buy_sell=0, order_volume, NULL)) AS `BuyVolume`',
    'FROM snapshot_evecentral ',
    'WHERE typeid=', plot.typeid, ' ',
    'AND price_date > \'', date.min, '\' ',
    'AND locationid=', plot.locationid, ' ',
    'GROUP BY price_date, price_time, typeid, locationid'
)
ec <- sqlQuery(emd, ec.query)
odbcClose(emd)
ec$date <- as.Date(ec$date)
ec$typeid <- as.factor(ec$typeid)
ec <- subset(ec, SellOrder > 0)
ec$datetime <- paste(ec$date, ec$hour, sep=' ')
ec$datetime <- as.POSIXlt(ec$datetime, tz='GMT')

## CREST lookups ##
CREST_BASE = 'https://crest-tq.eveonline.com/'
solarsystem.addr <- paste0(CREST_BASE, 'solarsystems/', plot.locationid, '/')
solarsystem.json <- fromJSON(readLines(solarsystem.addr))
solarsystem.name <- solarsystem.json$name

type.addr <- paste0(CREST_BASE, 'inventory/types/', plot.typeid, '/')
type.json <- fromJSON(readLines(type.addr))
type.name <- type.json$name

ec$locationName <- solarsystem.name
ec$typeName <- type.name

## Plot Theme ##
theme_dark <- function( ... ) {{
  theme(
    text = element_text(color="gray90"),
    title = element_text(size=rel(2.5),hjust=0.05,vjust=3.5),
    axis.title.x = element_text(size=rel(0.75),hjust=0.5, vjust=0),
    axis.title.y = element_text(size=rel(0.75),hjust=0.5, vjust=1.5),
    plot.margin = unit(c(2,1,1,1), "cm"),
    plot.background=element_rect(fill="gray8",color="gray8"),
    panel.background=element_rect(fill="gray10",color="gray10"),
    panel.grid.major = element_line(colour="gray17"),
    panel.grid.minor = element_line(colour="gray12"),
    axis.line = element_line(color = "gray50"),
    plot.title = element_text(color="gray80"),
    axis.title = element_text(color="gray70"),
    axis.text = element_text(color="gray50",size=rel(1.1)),
    legend.key = element_rect(fill="gray8",color="gray8"),
    legend.background = element_rect(fill="gray8"),
    legend.title = element_text(size=rel(0.6)),
    legend.text = element_text(size=rel(1.1)),
    strip.background = element_rect(fill="#252525"),
    strip.text = element_text(size=rel(1.2))
  ) + theme(...)
}}

## Mung Data ##
plot.data <- subset(ec, typeid==plot.typeid & locationid==plot.locationid) #FIXME: extra?
plot.data$SellOrder[plot.data$SellOrder <= 0] <- NA
plot.data <- melt.data.frame(
    plot.data,
    id.vars=c(
        'datetime',
        'typeName',
        'typeid'),
    measure.vars=c(
        'SellOrder',
        'BuyOrder',
        'BuyVolume',
        'SellVolume')
)
plot.data$facet[plot.data$variable %in% c('SellOrder', 'BuyOrder')] <- 'price'
plot.data$facet[plot.data$variable %in% c('BuyVolume', 'SellVolume')] <- 'volume'
plot.data.price <- subset(plot.data, facet=='price')
plot.data.volume <- subset(plot.data, facet=='volume')

price.max_scale = max(plot.data.price$value, na.rm=TRUE)
price.min_scale = min(plot.data.price$value, na.rm=TRUE)
volume.max_scale = max(plot.data.volume$value, na.rm=TRUE)
volume.min_scale = min(plot.data.volume$value, na.rm=TRUE)

## Build Plot ##
plot.data.price[order(plot.data.price$datetime),]
plot.price <- ggplot(
    plot.data.price,
    aes(
        x=datetime,
        y=value,
        color=variable)
)
plot.price <- plot.price + geom_line(size=rel(1.2))
plot.price <- plot.price + labs(
    title=plot.title,
    x='date',
    y='price',
    color='key'
)
if(do_lines){{
    plot.price <- plot.price + geom_vline(
        xintercept=as.numeric(event$datetime),
        linetype=2,
        color='white'
    )
    plot.price <- plot.price + geom_text(
        aes(
            x=datetime,
            y=Inf,
            label=eventName),
        color='white',
        angle=-90,
        vjust=1.2,
        hjust=0,
        data=event
    )
}}
if(price.max_scale > 1e9){{
    plot.price <- plot.price + scale_y_continuous(
        limit=c(price.min_scale, NA),
        labels=function(x)sprintf('%.2fB', x/1e9),
        position='right'
    )
}}else if(price.max_scale > 1e6){{
    plot.price <- plot.price + scale_y_continuous(
        limit=c(price.min_scale, NA),
        labels=function(x)sprintf('%.2fM', x/1e6),
        position='right'
    )
}}else if(price.max_scale > 1e3){{
    plot.price <- plot.price + scale_y_continuous(
        limit=c(price.min_scale, NA),
        labels=function(x)sprintf('%.2fK', x/1e3),
        position='right'
    )
}}else{{
    plot.price <- plot.price + scale_y_continuous(
        position='right'
    )
}}
plot.price <- plot.price + theme_dark()
plot.price <- plot.price + scale_color_manual(
    values=c(
        'BuyOrder'='#B7090D',
        'SellOrder'='#2169E0')
)

plot.data.volume[order(plot.data.volume$datetime),]
plot.volume <- ggplot(
    plot.data.volume,
    aes(
        x=datetime,
        y=value,
        color=variable)
)
plot.volume <- plot.volume + geom_line(size=rel(1.2))
plot.volume <- plot.volume + labs(
    x='date',
    y='volume',
    color='key'
)
if(do_lines){{
    plot.volume <- plot.volume + geom_vline(
        xintercept=as.numeric(event$datetime),
        linetype=2,
        color='white'
    )
}}
if(volume.max_scale > 1e9){{
    plot.volume <- plot.volume + scale_y_continuous(
        limit=c(volume.min_scale, NA),
        labels=function(x)sprintf('%.2fB', x/1e9),
        position='right'
    )
}}else if(volume.max_scale > 1e6){{
    plot.volume <- plot.volume + scale_y_continuous(
        limit=c(volume.min_scale, NA),
        labels=function(x)sprintf('%.2fM', x/1e6),
        position='right'
    )
}}else if(volume.max_scale > 1e3){{
    plot.volume <- plot.volume + scale_y_continuous(
        limit=c(volume.min_scale, NA),
        labels=function(x)sprintf('%.2fK', x/1e3),
        position='right'
    )
}}else{{
    plot.volume <- plot.price + scale_y_continuous(
        position='right'
    )
}}
plot.volume <- plot.volume + theme_dark()
plot.volume <- plot.volume + scale_color_manual(
    values=c(
        'BuyVolume'='#B7090D',
        'SellVolume'='#2169E0')
)

plot.combined <- plot_grid(
    plot.price, plot.volume,
    ncol=1,
    align='v'
)

## Print Plot To File ##
png(
    plot.path,
    width=plot.width,
    height=plot.height
)
print(plot.combined)
dev.off()


library(lmerTest)
library(MuMIn)

#optional set working directory
#setwd("")

#Note: the data is stored in 11 files due to the github file size limit

study1DataPart1 = read.csv(file="study_1_data_part_01.csv")
study1DataPart2 = read.csv(file="study_1_data_part_02.csv")
study1DataPart3 = read.csv(file="study_1_data_part_03.csv")
study1DataPart4 = read.csv(file="study_1_data_part_04.csv")
study1DataPart5 = read.csv(file="study_1_data_part_05.csv")
study1DataPart6 = read.csv(file="study_1_data_part_06.csv")
study1DataPart7 = read.csv(file="study_1_data_part_07.csv")
study1DataPart8 = read.csv(file="study_1_data_part_08.csv")
study1DataPart9 = read.csv(file="study_1_data_part_09.csv")
study1DataPart10 = read.csv(file="study_1_data_part_10.csv")
study1DataPart11 = read.csv(file="study_1_data_part_11.csv")

study1Data = rbind(study1DataPart1, study1DataPart2)
study1Data = rbind(study1Data, study1DataPart3)
study1Data = rbind(study1Data, study1DataPart4)
study1Data = rbind(study1Data, study1DataPart5)
study1Data = rbind(study1Data, study1DataPart6)
study1Data = rbind(study1Data, study1DataPart7)
study1Data = rbind(study1Data, study1DataPart8)
study1Data = rbind(study1Data, study1DataPart9)
study1Data = rbind(study1Data, study1DataPart10)
study1Data = rbind(study1Data, study1DataPart11)

# calculate forwardSteps and sessionTotalForwadStepsInViz from other fields
study1Data <- transform(study1Data,
                 UUID = as.factor(UUID),
                 forwardSteps = stepsInViz - vizBackwardsSteps
)

#add session forward steps
forwardSums <-aggregate(study1Data[c("forwardSteps")], study1Data["SessionId"], sum)
forwardSums <- transform(forwardSums,
     sessionTotalForwadStepsInViz = forwardSteps
)
study1Data = merge(study1Data, forwardSums[c("SessionId", "sessionTotalForwadStepsInViz")], by="SessionId")

###############################################
# optional save together as one large csv file

#write.csv(study1Data, file="study_1_data_all.csv")

###############################################

#count final UUIDS
study1DataWithPDI = study1Data[!is.na(study1Data["pdi"]), ]
length(study1DataWithPDI[, 'UUID'])
length(unique(study1DataWithPDI[, 'UUID']))
length(unique(study1DataWithPDI[, 'Country']))

summary(study1DataWithPDI[, 'pdi'])
sd(study1DataWithPDI[, 'pdi'])

scaledstudy1Data = study1Data

scaledstudy1Data <- transform(scaledstudy1Data,
                       pdi =  scale(pdi),
                       idv =  scale(idv),
                       mas =  scale(mas),
                       ltowvs =  scale(ltowvs),
                       ivr =  scale(ivr),
                       Student.teacher.ratio =  scale(Student.teacher.ratio),
                       GDP.per.capita =  scale(GDP.per.capita),
                       vizTime =  scale(vizTime),
                       vizTotalSteps =  scale(vizTotalSteps),
                       forwardSteps = scale(forwardSteps),
                       sessionTotalStepsInViz =  scale(sessionTotalStepsInViz),
                       sessionTotalForwadStepsInViz =  scale(sessionTotalForwadStepsInViz),
                       sessionSumCodeEditDistance =  scale(sessionSumCodeEditDistance),
                       sessionNumVizSessions =  scale(sessionNumVizSessions),
                       vizCodeCharLength =  scale(vizCodeCharLength),
                       vizCodeEditDistance =  scale(vizCodeEditDistance),
                       vizSessionNum =  scale(vizSessionNum),
                       vizSteps.Call =  scale(vizSteps.Call),
                       vizSteps.Exception =  scale(vizSteps.Exception)
)

#use linear model due to magnitude of N

backStepModel<-lmer(formula =vizBackwardsSteps ~
                 pdi # + Student.teacher.ratio + GDP.per.capita
               + vizTime +vizTotalSteps + forwardSteps + sessionTotalForwadStepsInViz +  sessionSumCodeEditDistance
               + sessionAnyEdits + sessionNumVizSessions + vizCodeCharLength + vizCodeEditDistance  +vizCodeWasEdited
               + vizSessionNum + vizSteps.Call  + vizSteps.Exception+ sessionAnyDupCode
                #     + (1 | Country)
                     + (1 | UUID)
                   , data = scaledstudy1Data
)

backStepModel
summary(backStepModel)
anova(backStepModel)
r.squaredGLMM(backStepModel)

#compare 2 countries
Israel = study1Data[study1Data["Country"] == "Israel", ]
sd(Israel[, c("vizBackwardsSteps")])
India = study1Data[study1Data["Country"] == "India", ]
sd(India[, c("vizBackwardsSteps")])

IndIsrael <- study1Data[study1Data["Country"] == "Israel" | study1Data["Country"] == "India", ]
t.test(vizBackwardsSteps ~ Country, IndIsrael)


# author: Heidi Ye, Gurdeepak Sidhu
# date: 2020-11-27

"This script reads the model scores from three different classification algorithms(Decision Tree, Logistic Regression, Naive Bayes model)
and creates a plot for the train score and test score for the hyperparameter optimization for each model.

Usage: report_figures.py --model=<model> --save_figures=<save_figures>

Options:
--model=<model>                 - Path to the model scores
--save_figures=<save_figures>   - Path to saving the figures
" -> doc

library(tidyverse)
library(docopt)
library(ggthemes)
library(ggridges)
theme_set(theme_minimal())

opt <- docopt(doc)

main <- function(model, out_dir) {

    #Checking if the file path exists or not
    if (file.exists(paste0(model, "/gaussiannb_hyperparameters.csv")) ==TRUE){
      # Reading the train data
      gaussian <- read.csv(paste0(model, "/gaussiannb_hyperparameters.csv"))
    } else {
      print("No such directory exist, please check whether correct directory path is entered")
    }
    #Plotting the hyperparameters for the Gausssian Distribution
    gaussian_plot <- gaussian %>% select(mean_train_score,mean_test_score, param_gaussiannb__var_smoothing) %>%
    gather(key = split, value = score, -param_gaussiannb__var_smoothing) %>%
    mutate( split = str_to_title(split),
              split = str_replace_all(split, "_", " ")) %>%
    ggplot(aes(x= param_gaussiannb__var_smoothing, y = score, color = split  ))+
    geom_point()+
    geom_line(alpha = 0.5)+
    scale_x_continuous(trans='log10')+
    labs(y="Score" , x = "Variable Smoothing", color="", title ="f1 score, Naive Bayes")+
    theme_grey()
    ggsave(paste0(out_dir, "/gaussian_hyperparameter.png"),
           gaussian_plot,
           width = 8,
           height = 10)

    #Checking if the file path exists or not
    if (file.exists(paste0(model, "/decisiontreeclassifier_hyperparameters.csv")) ==TRUE){
      # Reading the train data
      decision <- read.csv(paste0(model, "/decisiontreeclassifier_hyperparameters.csv"))
    } else {
      print("No such directory exist, please check whether correct directory path is entered")
    }

    #Plotting the hyperparameters for Decisiton tree classifier
    decision_plot <-decision %>%
    select(mean_train_score,mean_test_score,
           param_decisiontreeclassifier__min_samples_leaf,
           param_decisiontreeclassifier__max_depth ) %>%
    gather(key = split, value = score,
           -c(param_decisiontreeclassifier__min_samples_leaf,
              param_decisiontreeclassifier__max_depth) ) %>%
    mutate( split = str_to_title(split),
              split = str_replace_all(split, "_", " ")) %>%
    ggplot(aes(x= param_decisiontreeclassifier__max_depth, y = score, color = split  ))+
    geom_point()+
    geom_line(alpha = 0.5) +
    facet_wrap(. ~param_decisiontreeclassifier__min_samples_leaf , scale = "free", ncol = 2)+
    labs(y="Score" , x = "Max Depth", color="", title ="f1 score, sample leaves = 1,2,3,4")+ theme_grey()
    ggsave(paste0(out_dir, "/decision_tree.png"),
           decision_plot,
           width = 8,
           height = 10)

   #Check if file for logistic regression exists
    if (file.exists(paste0(model, "/logisticregression_hyperparameters.csv")) ==TRUE){
      # Reading the train data
      logistic <- read.csv(paste0(model, "/logisticregression_hyperparameters.csv"))
    } else {
      print("No such directory exist, please check whether correct directory path is entered")
    }

    #Plotting the hyperparameter distribution for logistic regression
    logistic_plot <- logistic %>%
      select(mean_train_score,mean_test_score,
             param_logisticregression__solver, param_logisticregression__C) %>%
      gather(key = split, value = score,
             -c(param_logisticregression__solver, param_logisticregression__C) ) %>%
      mutate( split = str_to_title(split),
              split = str_replace_all(split, "_", " ")) %>%
      ggplot(aes(x= param_logisticregression__C, y = score, color = split  ))+
      geom_point()+
      geom_line(alpha = 0.5) +
      facet_wrap(. ~param_logisticregression__solver , scale = "free", ncol = 2)+
      scale_x_continuous(trans='log10')+
      labs(y="Score" , x = "Hyperparameter C", color="", title ="f1 score, Linear Solver")+
      theme_grey()
    ggsave(paste0(out_dir, "/logistic_reg.png"),
           logistic_plot,
           width = 8,
           height = 10)
}

main(opt[["--model"]], opt[["--save_figures"]])


library(Romp)

c_hello()
f77_hello()
f90_hello()
rcpp_hello()


library(dplyr)
library(lubridate)
library(grid)
library(gtable)
source("Italy/code/plotting/format-data-plotting.r")

make_scenario_comparison_plots_compliance <- function(JOBID, StanModel, len_forecast, last_date_data,
                                                    baseline=FALSE, compliance_decrease = 20,top=7){
  print(paste0("Making scenario comparision plots for ", compliance_decrease , "%"))
  load(paste0('Italy/results/sim-constant-com-', StanModel, '-', len_forecast, '-0-', JOBID, '-stanfit.Rdata'))

  countries <- states

  out <- rstan::extract(fit)

  com_data <- NULL
  for (i in 1:length(countries)){
    data_state_plot <- format_data(i = i, dates = dates, countries = countries,
                                   estimated_cases_raw = estimated_cases_raw,
                                   estimated_deaths_raw = estimated_deaths_raw,
                                   reported_cases = reported_cases,
                                   reported_deaths = reported_deaths,
                                   out = out, forecast = 0, SIM = TRUE)
    # Cuts data on last_data_date
    data_state_plot <- data_state_plot[which(data_state_plot$date <= last_date_data),]

    subset_data <- select(data_state_plot, country, date, reported_deaths, estimated_deaths,
                          deaths_min, deaths_max)
    subset_data$key <- rep("Constant compliance", length(subset_data$country))
    com_data <- rbind(com_data, subset_data)
  }

  if (baseline == TRUE){
    load(paste0('Italy/results/sim-decrease-com-baseline-', StanModel, '-', len_forecast, '-', compliance_decrease, '-', JOBID,
                '-stanfit.Rdata'))
    out <- rstan::extract(fit)
  } else {
    load(paste0('Italy/results/sim-decrease-com-current-', StanModel, '-', len_forecast, '-', compliance_decrease, '-',
                JOBID, '-stanfit.Rdata'))
    out <- rstan::extract(fit)
  }
  for (i in 1:length(countries)){
    data_state_plot <- format_data(i = i, dates = dates, countries = countries,
                                   estimated_cases_raw = estimated_cases_raw,
                                   estimated_deaths_raw = estimated_deaths_raw,
                                   reported_cases = reported_cases,
                                   reported_deaths = reported_deaths,
                                   out = out, forecast = 0, SIM = TRUE)
    # Cuts data on last_data_date
    data_state_plot <- data_state_plot[which(data_state_plot$date <= last_date_data),]
    subset_data <- select(data_state_plot, country, date, reported_deaths, estimated_deaths,
                          deaths_min, deaths_max)
    subset_data$key <- rep("decreased compliance", length(subset_data$country))
    com_data <- rbind(com_data, subset_data)
  }

  data_half <- com_data[which(com_data$key == "decreased compliance"),]
  com_data$key <- factor(com_data$key)
  data_half$key <- factor(data_half$key)

  #nametrans <- read.csv("Subnational_Analysis/Italy/province_name_translation.csv")

  # To do top 7:
  if(top==7){
   com_data <- com_data %>% filter(country %in% c("Lombardy","Marche","Veneto","Tuscany","Piedmont","Emilia-Romagna","Liguria")) %>%
                              droplevels()

    data_half <- data_half %>% filter(country %in% c("Lombardy","Marche","Veneto","Tuscany","Piedmont","Emilia-Romagna","Liguria")) %>%
        droplevels()
  }
  if(top==8){
  # # To do all others"
   com_data <- com_data %>% filter((country %in% c("Abruzzo","Basilicata","Calabria","Campania","Friuli-Venezia_Giulia","Lazio","Molise"))) %>%
                             droplevels()
  data_half <- data_half %>% filter((country %in% c("Abruzzo","Basilicata","Calabria","Campania","Friuli-Venezia_Giulia","Lazio","Molise"))) %>%
      droplevels()
  }
  if(top==9){
    # # To do all others"
    com_data <- com_data %>% filter((country %in% c("Bolzano","Trento","Apulia","Sardinia","Sicily","Umbria","Aosta"))) %>%
      droplevels()
    data_half <- data_half %>% filter((country %in%  c("Bolzano","Trento","Apulia","Sardinia","Sicily","Umbria","Aosta"))) %>%
      droplevels()
  }

  last_date_data<-com_data$date[nrow(com_data)]

  #com_data$label <- com_data$key %>% str_replace_all(" ", "_") %>% recode( Constant_compliance= "compliance held constant", decreased_compliance = "decreased compliance: ",compliance_decrease,"% return to pre-lockdown level")

  levels(com_data$key)=c("compliance held constant",paste0("decreased compliance: ",compliance_decrease,"% return to pre-lockdown level"))

  p <- ggplot(com_data) +
    geom_bar(data = com_data, aes(x = date, y = reported_deaths), stat='identity') +
    geom_ribbon(aes(x = date, ymin = deaths_min, ymax = deaths_max, group = key, fill = key), alpha = 0.5) +
    #geom_line(aes(date,deaths_max),color="black",size=0.2)+
    #geom_line(aes(date,deaths_min),color="black",size=0.2)+
    #geom_line(aes(date,estimated_deaths),group = key,size=0.5)+
    geom_line(aes(date,estimated_deaths, group = key, color = key),size = 1)  +scale_colour_manual(values= c("skyblue","red"))+
    #geom_ribbon(aes(x = date, ymin = deaths_min, ymax = deaths_max, fill = "ICL"), alpha = 0.5) +
    scale_fill_manual(name = "", labels = c("compliance held constant", paste0("decreased compliance: ",compliance_decrease,"% return to pre-lockdown level")), values = c("skyblue","red")) +
    scale_x_date(date_breaks = "2 weeks", labels = date_format("%e %b"), limits = c(as.Date("2020-03-02"), last_date_data)) +
    #facet_wrap(~country, scales = "free",nrow=7) +
    facet_grid(country ~key, scales = "free_y")+
    xlab("") + ylab("Daily number of deaths") +
    theme_minimal() +
    theme(axis.text.x = element_text(angle = 45, hjust = 1,size = 26), axis.title = element_text( size = 26 ),axis.text = element_text( size = 26),
          legend.position = "none",strip.text = element_text(size = 26),legend.text=element_text(size=26))
  ggsave(paste0("Italy/figures/scenarios_decrease_baseline-", len_forecast, '-', compliance_decrease, '-', JOBID, "top_",top,".png"), p, height = 30, width = 20)

}


#####################################################
##                                                 ##
## electiogeddon                                   ##
## Benjamin J. Radford                             ##
## November 24, 2016                               ##
## http://www.benradford.com                       ##
## https://www.github.com/benradford/electiogeddon ##
##                                                 ##
## Data and code to evaluate vote discrepencies in ##
## the 2016 U.S. presidential election.            ##
##                                                 ##
#####################################################

## Load necessary libraries
library(rgdal)
library(lme4)
library(sjPlot)
library(MASS)
library(RColorBrewer)

predictions <- function(model,n=500000)
{
  ## Function to draw random coefficients for lm predictions.
  ## args
  ##  model: a model object from lm.
  ## returns
  ##  A matrix of size 500,000 x D where D is the number of coefficients.
  se <- summary(model)$coefficients[,2]
  beta <- summary(model)$coefficients[,1]
  draws <- mvrnorm(n,beta,diag(se^2))
  draws
}

## Vectors for converting state name to state abbreviation
state_list <- c('Alabama','Alaska','Arizona','Arkansas','California','Colorado','Connecticut','Delaware','Florida','Georgia','Hawaii','Idaho','Illinois','Indiana','Iowa','Kansas','Kentucky','Louisiana','Maine','Maryland','Massachusetts','Michigan','Minnesota','Mississippi','Missouri','Montana','Nebraska','Nevada','New Hampshire','New Jersey','New Mexico','New York','North Carolina','North Dakota','Ohio','Oklahoma','Oregon','Pennsylvania','Rhode Island','South Carolina','South Dakota','Tennessee','Texas','Utah','Vermont','Virginia','Washington','West Virginia','Wisconsin','Wyoming','District of Columbia')
abbr_list <- c('AL','AK','AZ','AR','CA','CO','CT','DE','FL','GA','HI','ID','IL','IN','IA','KS','KY','LA','ME','MD','MA','MI','MN','MS','MO','MT','NE','NV','NH','NJ','NM','NY','NC','ND','OH','OK','OR','PA','RI','SC','SD','TN','TX','UT','VT','VA','WA','WV','WI','WY','DC')

## Read the datasets
pop <- read.csv("data/PopulationEstimates.csv",stringsAsFactors=F)
results <- read.csv("data/election_results.csv",stringsAsFactors=F)
machine <- read.csv("data/verifier-search.csv",stringsAsFactors=F)
unemployment <- read.csv("data/unemployment.csv",stringsAsFactors=F)
education <- read.csv("data/Education.csv",stringsAsFactors=F)
# census <- read.csv("data/census.csv",stringsAsFactors=F)
census <- read.csv("data/census_cleaned.csv",stringsAsFactors=F)

## Clean up the census data
# census <- census[census$AGEGRP==0 & census$YEAR==8,]
# census$percent_white <- (census$WA_MALE + census$WA_FEMALE) / census$TOT_POP
# census$abbr <- abbr_list[match(census$STNAME,state_list)]
# census$state_county <- paste(census$abbr, census$CTYNAME)

## Clean up the election results data
results$dem <- results$votes_dem > results$votes_gop
results$gop_ratio <- results$votes_gop / (results$votes_gop + results$votes_dem)
results$state_county <- paste(results$state_abbr, results$county_name)
results$percent_white <- census$percent_white[match(results$state_county, census$state_county)]

## Clean up the Verified Voter data
machine$FIPS <- as.numeric(unlist(lapply(machine$FIPS.code, FUN=function(x)ifelse(nchar(x)==9,substr(x,1,4),substr(x,1,5)))))
machine$Make <- toupper(machine$Make)
electric <- machine[grepl("DRE",machine$Equipment.Type),]

## Read in the US map and merge it with the other data by state and county
us <- readOGR(dsn="cb_2015_us_county_500k", layer="cb_2015_us_county_500k")
us$FIPS <- as.numeric(as.character(paste0(us$STATEFP,us$COUNTYFP)))
us$state_abbr <- results$state_abbr[match(us$FIPS,results$combined_fips)]
us$dem <- results$dem[match(us$FIPS,results$combined_fips)]
us$gop_ratio <- results$gop_ratio[match(us$FIPS,results$combined_fips)]
us$pop <- log(as.numeric(gsub(",","",pop$POP_ESTIMATE_2015[match(us$FIPS,pop$FIPS)])))
us$std_pop <- (us$pop - min(us$pop,na.rm=T))/(max(us$pop,na.rm=T)-min(us$pop,na.rm=T))
us$dre <- us$FIPS %in% electric$FIPS
us$unemployment <- unemployment$Unemployment_rate_2015[match(us$FIPS, unemployment$FIPS_Code)]
us$college <- education$Percent.of.adults.with.a.bachelor.s.degree.or.higher..2010.2014[match(us$FIPS,education$FIPS.Code)]
us$percent_white <- results$percent_white[match(us$FIPS,results$combined_fips)]
test <- us$state_abbr
us <- us[!us$state_abbr %in% c("AK","HI"),]
us <- us[!is.na(us$state_abbr),]

## Output election map
png("election_map.png",width=1024,height=612)
myPal <- colorRampPalette(rev(brewer.pal(7,"RdBu")[c(1,2,4,6,7)]))
par(bg="#444444")
plot(us, col=myPal(100)[us$gop_ratio * 99 + 1], border=NA)
rect(grconvertX(seq(0,0.25,length.out=10), from="npc", to="user"),
     grconvertY(0,from = "npc", to = "user"),
     grconvertX(seq(0,0.25,length.out=10)+(0.25/10),from = "npc", to = "user"),
     grconvertY(0.05,from = "npc", to = "user"),col=myPal(10)[1:10],border=NA)
text(grconvertX(seq(0,0.25,length.out=3) + .25/20, from = "npc", to = "user"), grconvertY(0.075,from = "npc", to = "user"), c("Dem","Split","Rep"), col="white")
mtext("2016 Election Results by County",side=3, line=1, cex=2, col="white")
mtext("Benjamin J. Radford", side=3, line=-1, cex=1, col="white")
dev.off()

## Output header image
png("header_map.png",width=1200,height=600)
myPal <- colorRampPalette(rev(brewer.pal(7,"RdBu")[c(1,1,2,4,6,7,7)]))
par(bg="#444444")
plot(us, col=myPal(100)[us$gop_ratio * 99 + 1], border=NA) #ifelse(us$dre,"white",NA))
plot(us[us$dre==1,], border="white",add=T)
dev.off()

## Output population map
png("population_map.png",width=1024,height=612)
myPal <- colorRampPalette(brewer.pal(7,"YlGnBu"))
par(bg="#444444")
plot(us, col=myPal(100)[us$std_pop * 99 + 1], border=NA)
mtext("Population per County (logged)",side=3, line=1, cex=2, col="white")
mtext("Benjamin J. Radford", side=3, line=-1, cex=1, col="white")
dev.off()

## Output unemployment map
png("unemployment_map.png",width=1024,height=612)
myPal <- colorRampPalette(brewer.pal(7,"YlGnBu"))
par(bg="#444444")
plot(us, col=myPal(100)[(us$unemployment-min(us$unemployment,na.rm=T))/(max(us$unemployment,na.rm=T)-min(us$unemployment,na.rm=T)) * 99 + 1], border=NA)
mtext("Unemployment by County",side=3, line=1, cex=2, col="white")
mtext("Benjamin J. Radford", side=3, line=-1, cex=1, col="white")
dev.off()

## Output electronic voting map
png("electronic_voting.png",width=1024,height=612)
par(bg="#444444")
plot(us, col=ifelse(us$dre, "#b2182b", "#e0e0e0"), border=NA)
mtext("Electronic Voting Machines",side=3, line=1, cex=2, col="white")
mtext("Benjamin J. Radford", side=3, line=-1, cex=1, col="white")
dev.off()

## Run models
us_data <- data.frame("gop_vote"=us$gop_ratio, "electronic"=as.numeric(us$dre), "state"=as.factor(us$state_abbr), "population"=us$pop, "unemployment"=us$unemployment, "college"=us$college, "percent_white"=us$percent_white)
wi_data <- us_data[us_data$state=="WI",]
pa_data <- us_data[us_data$state=="PA",]
model_a <- lmer(gop_vote ~ electronic + (1|state), data=us_data)
model_b <- lmer(gop_vote ~ electronic + population + unemployment + college + percent_white + (1|state), data=us_data)
model_wi_a <- lm(gop_vote ~ electronic, data=wi_data)
model_wi_b <- lm(gop_vote ~ electronic + population + unemployment + college + percent_white, data=wi_data)
model_pa_a <- lm(gop_vote ~ electronic, data=pa_data)
model_pa_b <- lm(gop_vote ~ electronic + population + unemployment + college + percent_white, data=pa_data)

## Output model tables
sjt.lmer(model_a,model_b,file="national_table.html")
sjt.lm(model_wi_a,model_wi_b,model_pa_a,model_pa_b,file="wi_pa_table.html")

## Out-of-sample prediction
sample <- sample(1:nrow(us_data),1000,replace=F)
in_sample <- us_data[sample,]
out_sample <- us_data[!1:nrow(us_data) %in% sample,]
model_c <- lmer(gop_vote ~ electronic + population + unemployment + college + percent_white + (1|state), data=in_sample)
preds <- predict(model_c,us_data)
us$pred <- preds
us$pred_density <- -1
us$pred_density[sample] <- 20

## Out-of-sample prediction map
png("predicted_map.png",width=1024,height=612)
myPal <- colorRampPalette(rev(brewer.pal(7,"RdBu")[c(1,2,4,6,7)]))
par(bg="#444444")
plot(us, col=myPal(100)[us$pred * 99 + 1], border=NA, density=us$pred_density)
rect(grconvertX(seq(0,0.25,length.out=10), from="npc", to="user"),
     grconvertY(0,from = "npc", to = "user"),
     grconvertX(seq(0,0.25,length.out=10)+(0.25/10),from = "npc", to = "user"),
     grconvertY(0.05,from = "npc", to = "user"),col=myPal(10)[1:10],border=NA)
text(grconvertX(seq(0,0.25,length.out=3) + .25/20, from = "npc", to = "user"), grconvertY(0.075,from = "npc", to = "user"), c("Dem","Split","Rep"), col="white")
mtext("2016 Out-of-Sample Predicted Results",side=3, line=1, cex=2, col="white")
mtext("Benjamin J. Radford", side=3, line=-1, cex=1, col="white")
dev.off()

## Subset to states that have both electronic (DRE) and non-electronic voting
states_with_dre <- sort(unique(us$state_abbr[us$dre!=0]))
states_without_dre <- sort(unique(us$state_abbr[us$dre==0]))
states_with_dre <- intersect(states_with_dre, states_without_dre)

## Run models for states with both electronic and non-electronic voting
model_list <- list()
for(ss in states_with_dre)
{
  state_data <- us_data[us_data$state==ss,]
  state_data[complete.cases(state_data),]
  model_list <- c(model_list,list(lm(gop_vote ~ electronic + population + unemployment + college + percent_white, data=state_data)))
}
names(model_list) <- states_with_dre

demo_dre <- demo_nodre <- as.data.frame(t(colMeans(us_data[,!names(us_data) %in% c("state","gop_vote")],na.rm=T)))
demo_dre$electronic <- 1
demo_nodre$electronic <- 0

## Output state-wise maps
png("dre_states.png",width=1024,height=1024)
myPal <- colorRampPalette(rev(brewer.pal(7,"RdBu")[c(1,2,4,6,7)]))
par(mfrow=c(ceiling(sqrt(length(states_with_dre))), ceiling(sqrt(length(states_with_dre)))), mar=c(3.1,1.1,3.1,1.1), bg="#444444")
for(ss in states_with_dre)
{
  plot(us[us$state_abbr==ss,],col=ifelse(us$dre[us$state_abbr==ss],"#b2182b", "#999999"), border=NA)
  mtext(ss,3,line=0,cex=2,col="white")

  if(sum(is.na(coef(model_list[[ss]]))) == 0)
  {
    draws <- predictions(model_list[[ss]])
    sims_dre <- draws %*% as.matrix(unlist(c(1,demo_dre)))
    sims_nodre <- draws %*% as.matrix(unlist(c(1,demo_nodre)))
    # sims_dre <- sort(sims_dre[round(.025*500000):round(0.975*500000)])
    # sims_nodre <- sort(sims_nodre[round(.025*500000):round(0.975*500000)])

    dens_dre <- density(sims_dre)
    dens_dre <- data.frame(x=dens_dre$x, y=dens_dre$y)
    dens_nodre <- density(sims_nodre)
    dens_nodre <- data.frame(x=dens_nodre$x, y=dens_nodre$y)

    standardY <- max(c(dens_dre$y,dens_nodre$y))

    dens_dre <- dens_dre[dens_dre$x >= 0 & dens_dre$x <= 1,]
    dens_dre <- rbind(c(0,0),dens_dre,c(1,0))
    dens_nodre <- dens_nodre[dens_nodre$x >= 0 & dens_nodre$x <= 1,]
    dens_nodre <- rbind(c(0,0),dens_nodre,c(1,0))

    dens_dre$y <- dens_dre$y/standardY/4
    dens_nodre$y <- dens_nodre$y/standardY/4

    polygon(grconvertX(dens_nodre$x, from="npc", to="user"),grconvertY(dens_nodre$y, from="npc", to="user"), col="#e0e0e099", border="white")
    polygon(grconvertX(dens_dre$x, from="npc", to="user"),grconvertY(dens_dre$y, from="npc", to="user"), col="#b2182b99", border="white")

    mtext(sprintf("beta: %.2f  |  s.e.: %.2f  |  t: %.2f", coef(model_list[[ss]])["electronic"], summary(model_list[[ss]])$coefficients[,2]['electronic'], summary(model_list[[ss]])$coefficients[,3]['electronic']),1,line=0.25,col="white")
  }
}
plot(0,0,type="n",frame=F,xaxt="n",yaxt="n",xlim=c(0,1),ylim=c(0,1))
rect(0,0,0.25,0.25,col="#e0e0e0",border="white")
rect(0,0.5,0.25,0.75,col="#b2182b",border="white")
text(0.3,0.25/2,"No E-Voting",cex=2,pos=4,col="white")
text(0.3,0.25/2+0.5,"E-Voting",cex=2,pos=4,col="white")
dev.off()

##
## Quasibinomial regression models
##

predictionsPart2 <- function(preds, model, newdata)
{
  predicted_value <- list()
  for(ii in 1:nrow(preds))
  {
    model$coefficients <- preds[ii,]
    predicted_value <- c(predicted_value,list(predict(model, newdata, type="response")))
  }
  predicted_value <- do.call(c,predicted_value)
  predicted_value
}

## Run models
## Using glm instead of glmer because of availability of quasipoisson and convergence issues with glmer binomial modesl.
us_data <- data.frame("gop_vote"=us$gop_ratio, "electronic"=as.numeric(us$dre), "state"=as.factor(us$state_abbr), "population"=us$pop, "unemployment"=us$unemployment, "college"=us$college, "percent_white"=us$percent_white*100)
model_a <- glm(gop_vote ~ electronic + as.factor(state), data=us_data, family=quasibinomial)
model_b <- glm(gop_vote ~ electronic + population + unemployment + college + percent_white + as.factor(state), data=us_data, family=quasibinomial)
summary(model_a)
summary(model_b)

## Subset to states that have both electronic (DRE) and non-electronic voting
states_with_dre <- sort(unique(us$state_abbr[us$dre!=0]))
states_without_dre <- sort(unique(us$state_abbr[us$dre==0]))
states_with_dre <- intersect(states_with_dre, states_without_dre)

## Run models for states with both electronic and non-electronic voting
model_list <- list()
for(ss in states_with_dre)
{
  state_data <- us_data[us_data$state==ss,]
  state_data[complete.cases(state_data),]
  model_list <- c(model_list,list(glm(gop_vote ~ electronic + population + unemployment + college + percent_white, family=quasibinomial, data=state_data)))
}
names(model_list) <- states_with_dre

demo_dre <- demo_nodre <- as.data.frame(t(colMeans(us_data[,!names(us_data) %in% c("state","gop_vote")],na.rm=T)))
demo_dre$electronic <- 1
demo_nodre$electronic <- 0

## Output state-wise maps
png("dre_states_quasibinomial.png",width=1024,height=1024)
myPal <- colorRampPalette(rev(brewer.pal(7,"RdBu")[c(1,2,4,6,7)]))
par(mfrow=c(ceiling(sqrt(length(states_with_dre))), ceiling(sqrt(length(states_with_dre)))), mar=c(3.1,1.1,3.1,1.1), bg="#444444")
for(ss in states_with_dre)
{
  plot(us[us$state_abbr==ss,],col=ifelse(us$dre[us$state_abbr==ss],"#b2182b", "#999999"), border=NA)
  mtext(ss,3,line=0,cex=2,col="white")

  if(sum(is.na(coef(model_list[[ss]]))) == 0)
  {
    draws <- predictions(model_list[[ss]],n=5000)
    sims_dre <- predictionsPart2(draws, model_list[[ss]], demo_dre)
    sims_nodre <- predictionsPart2(draws, model_list[[ss]], demo_nodre)

    sims_dre <- c(round(sims_dre * 20),0:20)/20
    sims_nodre <- c(round(sims_nodre * 20),0:20)/20
    dens_dre <- table(sims_dre)-1
    dens_nodre <- table(sims_nodre)-1

    scaling <- max(c(dens_dre,dens_nodre))
    dens_dre <- dens_dre/scaling/4
    dens_nodre <- dens_nodre/scaling/4

    rect(grconvertX((0:20)/21,"npc","user"),grconvertY(dens_nodre,"npc","user"),grconvertX((1:21)/21,"npc","user"),grconvertY(0,"npc","user"),col="#e0e0e099",border=NA)
    rect(grconvertX((0:20)/21,"npc","user"),grconvertY(dens_dre,"npc","user"),grconvertX((1:21)/21,"npc","user"),grconvertY(0,"npc","user"),col="#b2182b99",border=NA)

    mtext(sprintf("beta: %.2f  |  s.e.: %.2f  |  t: %.2f", coef(model_list[[ss]])["electronic"], summary(model_list[[ss]])$coefficients[,2]['electronic'], summary(model_list[[ss]])$coefficients[,3]['electronic']),1,line=0.25,col="white")
  }
}
plot(0,0,type="n",frame=F,xaxt="n",yaxt="n",xlim=c(0,1),ylim=c(0,1))
rect(0,0,0.25,0.25,col="#e0e0e0",border="white")
rect(0,0.5,0.25,0.75,col="#b2182b",border="white")
text(0.3,0.25/2,"No E-Voting",cex=2,pos=4,col="white")
text(0.3,0.25/2+0.5,"E-Voting",cex=2,pos=4,col="white")
dev.off()


;; This buffer is for notes you don't want to save, and for Lisp evaluation.
;; If you want to create a file, visit that file with C-x C-f,
;; then enter the text in that file's own buffer.

wd <- "/home/eric/Desktop/MXelsCalendGovt/elecReturns/data/casillas"
setwd(wd)

########
# 2006 #
########
pr <- read.csv(file = "pre2006.csv", sep = ",", stringsAsFactors = FALSE)
pr[1,]
# adds voto efectivo
sel <- which(colnames(pr) %in% c("pan","pri.pvem", "prd.pt.c","panal","asdc"))
tmp <- pr[,sel]
pr$efec <- rowSums(tmp)
pr$fch <- pr$pan
pr$rmp <- pr$pri.pvem
pr$amlo <- pr$prd.pt.c
pr$pna <- pr$panal
pr <- pr[, c("edon", "disn","seccion","casilla","munn","fch","rmp", "amlo","pna","asdc","efec","lisnom")]
# drop casillas especiales votos extranjero
sel <- which(pr$seccion==0)
pr <- pr[-sel,]
# cambia NAs por ceros
pr[is.na(pr)==TRUE] <- 0
# drop unreported casillas
sel <- which(pr$efec==0)
pr[sel,]
pr <- pr[-sel,]

# consolida secciones
pr$fch <- ave(pr$fch, as.factor(pr$edon*10000+pr$seccion), FUN=sum, na.rm=TRUE)
pr$amlo <- ave(pr$amlo, as.factor(pr$edon*10000+pr$seccion), FUN=sum, na.rm=TRUE)
pr$rmp <- ave(pr$rmp, as.factor(pr$edon*10000+pr$seccion), FUN=sum, na.rm=TRUE)
pr$pna <- ave(pr$pna, as.factor(pr$edon*10000+pr$seccion), FUN=sum, na.rm=TRUE)
pr$asdc <- ave(pr$asdc, as.factor(pr$edon*10000+pr$seccion), FUN=sum, na.rm=TRUE)
pr$efec <- ave(pr$efec, as.factor(pr$edon*10000+pr$seccion), FUN=sum, na.rm=TRUE)
pr <- pr[duplicated(pr$edon*10000+pr$seccion)==FALSE, ]

# version secciones
pr.se <- pr
# shares
pr.se$fch  <- pr.se$fch/pr.se$efec
pr.se$rmp <- pr.se$rmp/pr.se$efec
pr.se$amlo06 <- pr.se$amlo/pr.se$efec
pr.se$pna  <- pr.se$pna/pr.se$efec
pr.se$asdc  <- pr.se$asdc/pr.se$efec
pr.se$amlo <- NULL
pr.se$casilla <- NULL

# consolida municipios
pr$fch <- ave(pr$fch, as.factor(pr$edon*1000+pr$munn), FUN=sum, na.rm=TRUE)
pr$rmp <- ave(pr$rmp, as.factor(pr$edon*1000+pr$munn), FUN=sum, na.rm=TRUE)
pr$amlo <- ave(pr$amlo, as.factor(pr$edon*1000+pr$munn), FUN=sum, na.rm=TRUE)
pr$pna <- ave(pr$pna, as.factor(pr$edon*1000+pr$munn), FUN=sum, na.rm=TRUE)
pr$asdc <- ave(pr$asdc, as.factor(pr$edon*1000+pr$munn), FUN=sum, na.rm=TRUE)
pr$efec <- ave(pr$efec, as.factor(pr$edon*1000+pr$munn), FUN=sum, na.rm=TRUE)
pr <- pr[duplicated(pr$edon*1000+pr$munn)==FALSE, ]
pr$seccion <- NULL
pr$disn <- pr$casilla <- NULL
# export munic aggregates
write.csv(pr, file = "../municipios/pre2006.csv", row.names = FALSE)

# shares
pr$fch  <- pr$fch/pr$efec
pr$rmp <- pr$rmp/pr$efec
pr$amlo06 <- pr$amlo/pr$efec
pr$pna <- pr$pna/pr$efec
pr$asdc <- pr$asdc/pr$efec
pr$amlo <- NULL
pr <- pr[,c("edon","munn","fch","rmp","amlo06","pna","asdc","efec","lisnom")]

# version municipios
pr.mu <- pr
rm(pr)


## Rewrite Meta-analysis as function

require(reshape2)
require(metafor)
require(tidyverse)

### Function to determine the number of pairwise comparisons available for the studies
compare.eval <- function(meta.data, comparison, site){
  site <- enquo(site)
  comparison <- enquo(comparison)
  ex1 <- meta.data %>% group_by(!!site) %>% summarize(compare.true=length(unique(!!comparison))) %>% filter(compare.true==2) %>% data.frame(.)
  return(nrow(ex1))
}

## Function to extract and join datasets that are both raw and statistics to be joined for meta analysis
meta.eval <- function(meta.data, compare, ids , stats){

  ## Identify the closures to prepare for programming
  comparison <- enquo(compare)
  site <- enquo(ids)
  stat <- enquo(stats)

  ## Load in other function for multiDcast
  dcastMult <- function(data, formula, value.var = "value",
                        funs = list("min" = min, "max" = max)) {
    require(reshape2)
    if (is.null(names(funs)) | any(names(funs) == "")) stop("funs must be named")
    Form <- formula(formula)
    LHS <- as.character(Form[[2]])
    if (length(LHS) > 1) LHS <- LHS[-1]
    temp <- lapply(seq_along(funs), function(Z) {
      T1 <- dcast(data, Form, value.var = value.var,
                  fun.aggregate=match.fun(funs[[Z]]), fill = 0)
      Names <- !names(T1) %in% LHS
      names(T1)[Names] <- paste(names(T1)[Names], names(funs)[[Z]], sep = "_")
      T1
    })
    Reduce(function(x, y) merge(x, y), temp)
  }

  #### Begin Function for comparing datasets

  ## function for se
  se <- function(x) { sd(x)/sqrt(length(x))}

  ## Identify studies where the comparison is possible
  ex1 <- meta.data %>% group_by(!!site) %>% summarize(compare.true=length(unique(!!comparison))) %>% filter(compare.true==2) %>% data.frame(.)

  ## Specify forumla for the comparisons
  #f1 <- reformulate(termlabels = x, response = y)
  f1 <- as.formula(paste(substitute(ids), "~", substitute(compare)))

  ## Get summary statistics for raw datasets
  meta.temp1 <- meta.data %>%  filter(!!site %in% ex1[,1]) %>% filter(!!stat =="count") %>%
    dcastMult(f1, funs=list("mean"=mean,"se"=se, "n"=length), value.var = "Value")  ## calculate mean, se, and length (N)
  meta.temp1[is.na(meta.temp1)] <- 1 ## replace NA values with 1

  ## Get replicate value (N) when one is reported
  raw.replicate <- meta.data %>%  filter(!!site %in% ex1[,1]) %>% filter(!!stat =="count") %>%
    dcastMult(f1, funs=list("mean"=mean), value.var = "replicate")
  names(raw.replicate) <- gsub("mean", "n", names(raw.replicate)) ## replace mean lable with N
  missing.n <- na.omit(raw.replicate)## remove instances when no replicate is reported

  ## Add replicates to calculated data, unless replicate was not recorded - Then use the calculated replicate value
  meta.temp1[meta.temp1[,"UniqueSite"] %in% missing.n[,"UniqueSite"],6:7] <-
    raw.replicate[meta.temp1[,"UniqueSite"] %in% missing.n[,"UniqueSite"],2:3]

  ## Get statistic data from manuscripts in format to join
  #f2 <- reformulate(termlabels = c(x,z), response = y)
  f2 <- as.formula(paste(substitute(ids), "~", substitute(compare),"*",substitute(stats)))

  meta.temp2 <- meta.data %>%  filter(!!site %in% ex1[,1]) %>% filter(!!stat =="mean" | !!stat =="se") %>%
    dcastMult(f2, funs=list("mean"=mean), value.var = "Value") ## extracted mean and SE

  ## Get replicate value (N)
  meta.temp3 <- meta.data %>%  filter(!!site %in% ex1[,1]) %>% filter(!!stat =="mean") %>% dcastMult(f1, funs=list("mean"=mean), value.var = "replicate")
  names(meta.temp3) <- gsub("mean", "n", names(meta.temp3)) ## replace mean lable with N
  meta.temp2 <- merge(meta.temp2,meta.temp3, by=c("UniqueSite"))

  ## Output the two datasets for raw and stat values
  return(list(meta.temp1, meta.temp2))

}


#!/usr/bin/env Rscript
# Function: Use the model (spectrum kernel, k=5) trained on the first species seqs, apply to the second species.
#           Output the model feature weights, the performance of first species model on second species. Default class size ratio is 10.
# Usage: ./generalization.r <species1_name> <species1_seqfile>  <pos_num> <species2_name> <species2_seqfile> <pos_num>

#parse arguments
args <- commandArgs(trailingOnly = TRUE)
s1 <- args[1]
s1_fh <- args[2]
s1_posN <- as.integer(args[3])
s2 <-args[4]
s2_fh <- args[5]
s2_posN <- as.integer(args[6])

library(kebabs)

species1 <- readDNAStringSet(s1_fh) #include all species1 enhancers and 10 random negative regions
labels_all <- c(rep.int(1, times=s1_posN), rep.int(-1, times=length(species1)-s1_posN) )
numSamples <- length(species1)

trainingFraction <- 1
train <- sample(1:numSamples, trainingFraction*numSamples)
test <- c(1:numSamples)[-train]
specK5 <- spectrumKernel(k=5, revComplement=FALSE) #spectrum kernel k=5

#class weights, 1:10
wts <- 10/c(1, 10)
names(wts) <- c(1,-1)

#train a model based on species1 sequences
model <- kbsvm(x=species1[train], y=labels_all[train], kernel=specK5, pkg="LibLineaR", svm="C-svc", cost=15, perfParameters="ALL", classWeights=wts)
#extract feature weights of the model
fw <- t(sort(as.data.frame(featureWeights(model))))
out_name <- sprintf("../results/SVM_output/%s_model_highweightkmers_%s.tsv",s1,Sys.Date())
cat("Writing the feature weights to ", out_name)
write.table(fw, file=out_name,sep="\t")

#apply the model to species2
species2 <- readDNAStringSet(s2_fh )
species2_labels <- c(rep.int(1, times=s2_posN ), rep.int(-1, times=length(species2)-s2_posN))
species2_test_fraction <- 1
species2_test1 <- sample(1:length(species2), species2_test_fraction*length(species2))

pred1 <- predict(model, species2[species2_test1])
preddec1 <- predict(model, species2[species2_test1], predictionType="decision")
evaluatePrediction(pred1,species2_labels[species2_test1], allLabels=unique(species2_labels[species2_test1]),decValues=preddec1)
names <- names(species2[species2_test1])
true_labels <- species2_labels[species2_test1]
response <- predict(model, species2[species2_test1], raw=True, predictionType="response")
decision <- predict(model, species2[species2_test1], raw=True, predictionType="decision")
out_df <- data.frame("names"= names, "labels"=true_labels, "response"=response, "decision"=decision)
out_name <- sprintf("../results/SVM_output/%s_applyto_%s_%s.tsv", s1,s2,Sys.Date())
cat("Writing the prediction file of species1 trained model on species2 to ", out_name)
write.table(out_df, file=out_name, sep="\t", row.names=FALSE)