R/preprocess.R

In sense: Automatic Stacked Ensemble for Regression Tasks

# Fitted preprocessing state is local to each training split. Prediction never
# recomputes levels, imputation distributions, scales, encodings or filters.
.sense_token <- function(levels, token) {
  while (token %in% levels) token <- paste0(token, "_")
  token
}

.sense_impute <- function(x, state) {
  bad <- !is.finite(x)
  if (!any(bad)) return(x)
  if (state$method == "hist" && !is.null(state$hist)) {
    h <- state$hist
    bins <- sample.int(length(h$counts), sum(bad), replace = TRUE, prob = h$counts)
    x[bad] <- stats::runif(sum(bad), h$breaks[bins], h$breaks[bins + 1L])
  } else {
    x[bad] <- state$observed[sample.int(length(state$observed), sum(bad), replace = TRUE)]
  }
  x
}

.sense_encode_matrix <- function(levels, method) {
  n <- length(levels)
  if (method == "one-hot") return(diag(n))
  if (n < 2L) return(matrix(0, n, 1L))
  switch(method, treatment = stats::contr.treatment(n),
    sum = stats::contr.sum(n), helmert = stats::contr.helmert(n),
    poly = stats::contr.poly(n))
}

.sense_preprocess <- function(data, truth, config) {
  states <- vector("list", ncol(data))
  names(states) <- names(data)
  output <- list()
  for (name in names(data)) {
    x <- data[[name]]
    numeric <- is.numeric(x)
    missing <- if (numeric) !is.finite(x) else is.na(x)
    if (numeric) {
      observed <- x[!missing]
      if (!length(observed)) observed <- 0
      state <- list(numeric = TRUE, observed = observed, method = config$impute_num,
        hist = if (config$impute_num == "hist" && length(unique(observed)) > 1L)
          graphics::hist(observed, plot = FALSE) else NULL)
      x <- .sense_impute(x, state)
      state$center <- switch(config$num_preproc, scale = mean(x), range = min(x), nop = 0)
      state$spread <- switch(config$num_preproc, scale = stats::sd(x),
        range = diff(range(x)), nop = 1)
      if (!is.finite(state$spread) || state$spread == 0) state$spread <- 1
      values <- matrix((x - state$center) / state$spread, ncol = 1L)
    } else {
      original <- as.character(x)
      levels <- if (is.factor(x)) levels(droplevels(x)) else sort(unique(original[!missing]))
      state <- list(numeric = FALSE, known = levels, keep = levels, other = NULL,
        missing = .sense_token(levels, ".sense_missing"), method = config$fct_preproc)
      if (is.character(x) && length(levels) > config$collapse_char_to) {
        counts <- table(factor(original, levels = levels))
        state$keep <- levels[order(-counts, levels)][seq_len(config$collapse_char_to - 1L)]
        state$other <- .sense_token(c(levels, state$missing), ".sense_other")
      }
      x <- original
      if (!is.null(state$other)) x[!missing & !(x %in% state$keep)] <- state$other
      x[missing] <- state$missing
      state$levels <- c(state$keep, state$other, state$missing)
      if (config$fct_preproc == "encodeimpact") {
        sums <- tapply(truth, factor(x, levels = state$levels), sum)
        counts <- table(factor(x, levels = state$levels))
        state$encoding <- matrix((ifelse(is.na(sums), 0, sums) + 1e-4 * mean(truth)) /
          (as.numeric(counts) + 1e-4) - mean(truth), ncol = 1L)
        state$unknown <- 0
      } else if (config$fct_preproc == "encodelmer") {
        .sense_require("lme4", "fct_preproc = 'encodelmer'")
        group <- factor(x)
        if (nlevels(group) < 2L || nlevels(group) >= length(truth)) {
          state$encoding <- matrix(mean(truth), length(state$levels), 1L)
          state$unknown <- mean(truth)
        } else {
          fit <- lme4::lmer(y ~ 1 + (1 | group), data = data.frame(y = truth, group = group))
          state$unknown <- unname(lme4::fixef(fit)[1L])
          state$encoding <- matrix(as.numeric(stats::predict(fit,
            newdata = data.frame(group = factor(state$levels)), allow.new.levels = TRUE)), ncol = 1L)
        }
      } else {
        state$encoding <- .sense_encode_matrix(state$levels, config$fct_preproc)
        state$unknown <- rep(0, ncol(state$encoding))
      }
      values <- state$encoding[match(x, state$levels), , drop = FALSE]
    }
    state$output <- paste0("x", match(name, names(data)), "_", seq_len(ncol(values)))
    colnames(values) <- state$output
    output[[length(output) + 1L]] <- values
    if (config$missing_fusion) {
      state$indicator <- paste0("missing", match(name, names(data)))
      output[[length(output) + 1L]] <- matrix(as.numeric(missing), ncol = 1L,
        dimnames = list(NULL, state$indicator))
    }
    states[[name]] <- state
  }
  frame <- as.data.frame(do.call(cbind, output))
  varying <- vapply(frame, function(x) length(unique(x)) > 1L, logical(1))
  frame <- frame[, varying, drop = FALSE]
  if (!ncol(frame)) stop("No non-constant features remain after preprocessing.", call. = FALSE)
  score <- .sense_filter(frame, truth, config$selected_filter)
  selected <- names(score)[order(-score, names(score), na.last = TRUE)]
  selected <- utils::head(selected, min(config$selected_n_feats, length(selected)))
  list(data = frame[, selected, drop = FALSE], state = states,
    features = selected, score = score, input = names(data))
}

.sense_bake <- function(preprocessor, data) {
  absent <- setdiff(preprocessor$input, names(data))
  if (length(absent)) stop("Missing predictor columns: ", paste(absent, collapse = ", "), call. = FALSE)
  output <- list()
  for (name in preprocessor$input) {
    state <- preprocessor$state[[name]]
    x <- data[[name]]
    missing <- if (state$numeric) !is.finite(x) else is.na(x)
    if (state$numeric) {
      if (!is.numeric(x)) stop("Predictor '", name, "' must be numeric.", call. = FALSE)
      values <- matrix((.sense_impute(x, state) - state$center) / state$spread, ncol = 1L)
    } else {
      x <- as.character(x)
      if (!is.null(state$other)) x[!missing & x %in% setdiff(state$known, state$keep)] <- state$other
      x[missing] <- state$missing
      index <- match(x, state$levels)
      values <- state$encoding[index, , drop = FALSE]
      if (anyNA(index)) values[is.na(index), ] <- rep(state$unknown, each = sum(is.na(index)))
    }
    colnames(values) <- state$output
    output[[length(output) + 1L]] <- values
    if (!is.null(state$indicator)) output[[length(output) + 1L]] <- matrix(as.numeric(missing),
      ncol = 1L, dimnames = list(NULL, state$indicator))
  }
  as.data.frame(do.call(cbind, output))[, preprocessor$features, drop = FALSE]
}

.sense_filter <- function(data, truth, method) {
  if (method == "variance") return(vapply(data, stats::var, numeric(1)))
  if (method == "correlation") return(vapply(data, function(x)
    if (stats::sd(truth) == 0) 0 else abs(stats::cor(x, truth)), numeric(1)))
  .sense_require("mlr3filters", paste0("selected_filter = '", method, "'"))
  filter <- mlr3filters::flt(method)
  for (package in filter$packages) .sense_require(package, paste0("selected_filter = '", method, "'"))
  filter$calculate(.sense_task(data, truth))
  filter$scores
}