R/deepnet.R

In abnormally-distributed/cvreg: Cross Validation and Robust Estimation Utilities

#' Cross Validate Tuning Parameters of Deep Neural Network
#'
#' @param formula a model formula
#' @param data a training data set
#' @param cv.method preferably one of "boot632" (the default), "cv", or "repeatedcv".
#' @param nfolds the number of bootstrap or cross-validation folds to use. defaults to 5.
#' @param folds a vector of pre-set cross-validation or bootstrap folds from caret::createResample or
#' caret::createFolds.
#' @param nrep the number of repetitions for cv.method = "repeatedcv". defaults to 4.
#' @param max.neurons the largest number of neurons per layer to consider.
#' @param max.layers the largest number of layers to consider.
#' @param crit the criterion by which to evaluate the model performance. must be one of "MAE" (the default)
#' or "MSE".
#' @param select the selection rule to use. Should be one of "best" or "oneSE" (the default).
#'
#' @return
#' a train object
#' @export
#'
cv_dnn = function(formula, data, cv.method = "boot632", folds = NULL, nfolds = 5, max.neuron = 10,
                max.layers = 3, actfun = "sigm", outfun = "linear", nrep = 4, crit = "MAE", select = "oneSE"){

  DNN <- list(type = "Regression",
               library = "deepnet",
               loop = NULL)
  DNN$actfun <- actfun
  DNN$outfun <- outfun
  DNN$parameters <- data.frame(parameter = c("neurons", "layers", "decay"),
                                class = rep("numeric", 3),
                                label = c("neurons", "layers", "decay"))
  DNN$max.neuron <- max.neuron
  DNN$max.layers <- max.layers

  DNNGrid <- function(x, y, max.neuron = DNN$max.neuron, max.layers = DNN$max.layers, len = NULL, search = "grid") {

    ## use grid search:
    if(search == "grid"){
      search = "grid"
    } else {
      search = "grid"
    }

    grid <- expand.grid(neurons = seq(2, max.neuron, by = 1),
                        layers = seq(1, max.layers, by = 1),
                        decay = rev(seq(0.20, 1, length.out = len))
                        )
    out <- grid
    return(out)
  }

  DNN$grid <- DNNGrid

  DNNFit <- function(x, y, param, outfun = DNN$outfun, actfun = DNN$actfun, ...) {

    suppressMessages(deepnet::dbn.dnn.train(
      x = as.matrix(x),
      y = as.vector(y),
      hidden = c(rep(param$neurons, param$layers)),
      learningrate_scale = param$decay,
      output = outfun,
      activationfun = actfun
    ))
  }

  DNN$fit <- DNNFit
  DNN$prob <- DNNFit

  DNNPred <- function(modelFit, newdata, preProc = NULL, submodels = NULL){
    as.vector(deepnet::nn.predict(modelFit, newdata))
  }

  DNN$predict <- DNNPred

  postRobResamp = function(pred, obs) {

    isNA <- is.na(pred)
    pred <- pred[!isNA]
    obs <- obs[!isNA]
    if (!is.factor(obs) && is.numeric(obs)) {
      if (length(obs) + length(pred) == 0) {
        out <- rep(NA, 2)
      }
      else {
        huber.mean <-  function (y) {
          init.robmu = MASS::hubers(y, k = 3, initmu = median(y), s = sd(y))$mu
          MASS::hubers(y, k = 2.241403, initmu = init.robmu)$mu
        }
        robmse <- huber.mean((pred - obs)^2)
        robmae <- mean(abs(pred - obs))
        out <- c(robmse, robmae)
      }
      names(out) <- c("MSE", "MAE")
    }
    else {
      if (length(obs) + length(pred) == 0) {
        out <- rep(NA, 2)
      }
      else {
        pred <- factor(pred, levels = levels(obs))
        requireNamespaceQuietStop("e1071")
        out <- unlist(e1071::classAgreement(table(obs, pred)))[c("diag",
                                                                 "kappa")]
      }
      names(out) <- c("Accuracy", "Kappa")
    }
    if (any(is.nan(out)))
      out[is.nan(out)] <- NA
    out
  }

  Summary = function (data, lev = NULL, model = NULL)
  {
    if (is.character(data$obs))
      data$obs <- factor(data$obs, levels = lev)
    postRobResamp(data[, "pred"], data[, "obs"])
  }


  if (cv.method == "repeatedcv") {
    fitControl <- trainControl(method = cv.method,
                               number = nfolds,
                               repeats = nrep,
                               index = folds,
                               allowParallel = TRUE,
                               selectionFunction = select,
                               savePredictions = "all",
                               summaryFunction = Summary,
                               search = "grid")
  } else {

    fitControl <- trainControl(method = cv.method,
                               number = nfolds,
                               allowParallel = TRUE,
                               savePredictions = "all",
                               index = folds,
                               selectionFunction = select,
                               summaryFunction = Summary,
                               search = "grid")
  }


  fitted.models <- train(formula, data,
                         method = DNN,
                         metric = crit,
                         tuneLength = tunlen,
                         maximize = FALSE,
                         preProcess = "range",
                         trControl = fitControl)

  return(fitted.models)

}