R/ensemble.R

In sense: Automatic Stacked Ensemble for Regression Tasks

.sense_require <- function(package, purpose) {
  if (!requireNamespace(package, quietly = TRUE)) stop("Package '", package,
    "' is required for ", purpose, ". Install it with install.packages('", package, "').", call. = FALSE)
}

.sense_task <- function(data, truth) {
  target <- .sense_token(names(data), ".sense_target")
  data[[target]] <- truth
  mlr3::TaskRegr$new("sense", backend = data.table::as.data.table(data), target = target)
}

.sense_learner <- function(algo, params = list()) {
  learner <- mlr3::lrn(paste0("regr.", algo))
  prefix <- paste0("regr.", algo, ".")
  values <- params[startsWith(names(params), prefix)]
  names(values) <- substring(names(values), nchar(prefix) + 1L)
  learner$param_set$values <- utils::modifyList(learner$param_set$values, values)
  learner
}

.sense_fit_base <- function(data, truth, algo, config, params) {
  pp <- .sense_preprocess(data, truth, config)
  rows <- seq_len(nrow(data))
  if (config$sampling_rate < 1) rows <- sample.int(length(rows),
    max(2L, floor(length(rows) * config$sampling_rate)))
  learner <- .sense_learner(algo, params)
  learner$train(.sense_task(pp$data[rows, , drop = FALSE], truth[rows]))
  pp$data <- NULL
  list(preprocessor = pp, learner = learner)
}

.sense_predict_base <- function(model, data) {
  model$learner$predict_newdata(.sense_bake(model$preprocessor, data))$response
}

# Standard mlr3 learner, without a graph or any mlr3pipelines classes.
.sense_ensemble <- R6::R6Class("LearnerRegrSense", inherit = mlr3::LearnerRegr,
  public = list(
    config = NULL,
    initialize = function(config, space) {
      self$config <- config
      super$initialize(id = "regr.sense", param_set = space$clone(deep = TRUE),
        predict_types = "response", feature_types = c("logical", "integer", "numeric", "character", "factor", "ordered"),
        properties = "missings", packages = "sense", label = "Internal stacked regression")
    }
  ),
  private = list(
    .train = function(task) {
      config <- self$config
      data <- as.data.frame(task$data(cols = task$feature_names))
      truth <- task$truth()
      n <- length(truth)
      if (n < 4L) stop("Each ensemble training split needs at least four observations.", call. = FALSE)
      # Three folds match the former learner_cv default. All preprocessing,
      # including supervised encodings and filters, is fitted within each fold.
      fold <- sample(rep(seq_len(min(3L, n)), length.out = n))
      predictions <- matrix(NA_real_, n, length(config$algos),
        dimnames = list(NULL, paste0("regr.", config$algos, ".response")))
      for (k in sort(unique(fold))) {
        test <- which(fold == k)
        train <- which(fold != k)
        for (j in seq_along(config$algos)) {
          model <- .sense_fit_base(data[train, , drop = FALSE], truth[train],
            config$algos[j], config, self$param_set$values)
          predictions[test, j] <- .sense_predict_base(model, data[test, , drop = FALSE])
        }
      }
      if (any(!is.finite(predictions))) stop("Base learners produced non-finite out-of-fold predictions.", call. = FALSE)
      score <- vapply(seq_along(config$algos), function(j) config$measure$score(
        mlr3::PredictionRegr$new(row_ids = seq_len(n), truth = truth, response = predictions[, j])), numeric(1))
      names(score) <- config$algos
      selected <- seq_along(config$algos)
      if (!identical(config$benchmarking, "all")) selected <- order(score,
        decreasing = !config$measure$minimize)[seq_len(config$benchmarking)]
      predictions <- predictions[, selected, drop = FALSE]
      base <- lapply(config$algos[selected], function(algo)
        .sense_fit_base(data, truth, algo, config, self$param_set$values))
      names(base) <- config$algos[selected]
      meta <- NULL
      if (config$super != "avg") {
        meta <- .sense_learner(config$super, self$param_set$values)
        meta$train(.sense_task(as.data.frame(predictions), truth))
      }
      list(base = base, meta = meta, oof = predictions, fold = fold,
        benchmark = data.frame(learner_id = paste0("regr.", config$algos),
          score = unname(score)), train_row_ids = task$row_ids)
    },
    .predict = function(task) {
      data <- as.data.frame(task$data(cols = task$feature_names))
      predictions <- vapply(self$model$base, .sense_predict_base, numeric(nrow(data)), data = data)
      predictions <- matrix(predictions, nrow = nrow(data), ncol = length(self$model$base),
        dimnames = list(NULL, colnames(self$model$oof)))
      response <- if (is.null(self$model$meta)) rowMeans(predictions) else
        self$model$meta$predict_newdata(as.data.frame(predictions))$response
      list(response = response)
    }
  )
)

.sense_resampling <- function(method, folds, repeats, ratio) {
  switch(method, cv = mlr3::rsmp("cv", folds = folds),
    repeated_cv = mlr3::rsmp("repeated_cv", folds = folds, repeats = repeats),
    holdout = mlr3::rsmp("holdout", ratio = ratio),
    subsampling = mlr3::rsmp("subsampling", repeats = repeats, ratio = ratio))
}

.sense_metrics <- function(actual, predicted) {
  error <- actual - predicted
  mse <- mean(error^2)
  rse <- sum(error^2) / sum((actual - mean(actual))^2)
  c(mse = mse, rmse = sqrt(mse), mae = mean(abs(error)),
    mape = mean(abs(error / actual)), mdae = stats::median(abs(error)),
    rae = sum(abs(error)) / sum(abs(actual - mean(actual))), rse = rse,
    rrse = sqrt(rse), smape = mean(2 * abs(error) / (abs(actual) + abs(predicted))))
}

.sense_plot <- function(algos, super) {
  structure(list(base = algos, super = super), class = "sense_pipeline")
}

#' Plot the sense preprocessing and stacking architecture
#' @param x A pipeline returned in the `plot` element of [sense()].
#' @param ... Additional arguments passed to `graphics::plot.default()`.
#' @return The pipeline, invisibly.
#' @export
plot.sense_pipeline <- function(x, ...) {
  y <- seq(0.15, 0.85, length.out = length(x$base))
  graphics::plot(c(0, 1), c(0, 1), type = "n", axes = FALSE, xlab = "", ylab = "", ...)
  graphics::text(0.12, 0.5, "Preprocess\nwithin folds", cex = 0.8)
  for (i in seq_along(y)) {
    graphics::arrows(0.25, 0.5, 0.43, y[i], length = 0.07)
    graphics::text(0.53, y[i], x$base[i], cex = 0.8)
    graphics::arrows(0.63, y[i], 0.80, 0.5, length = 0.07)
  }
  graphics::text(0.9, 0.5, x$super, cex = 0.8)
  invisible(x)
}