tests/regression.R

In sense: Automatic Stacked Ensemble for Regression Tasks

library(sense)

internal <- function(name) getFromNamespace(paste0(".sense_", name), "sense")
expect_error <- function(expr, pattern) {
  error <- tryCatch({ force(expr); NULL }, error = identity)
  stopifnot(inherits(error, "error"), grepl(pattern, conditionMessage(error)))
}
config <- list(impute_num = "sample", num_preproc = "scale", fct_preproc = "one-hot",
  collapse_char_to = 3L, missing_fusion = TRUE, selected_filter = "variance", selected_n_feats = 100L)
set.seed(17)
d <- data.frame(num = c(NA, 2:12), single = c(7, rep(NA, 11)),
  empty = rep(NA_real_, 12), constant = 1, flag = rep(c(TRUE, FALSE, NA), 4),
  text = c("a", "a", "a", "a", "b", "b", "b", "c", "d", "e", NA, ".sense_missing"),
  factor = factor(rep(c("x", "y", NA), 4)), ordered = ordered(rep(c("l", "m", "h"), 4)))
y <- seq_len(nrow(d))
pp <- internal("preprocess")(d, y, config)
stopifnot(all(is.finite(as.matrix(pp$data))), !any(c("x2_1", "x3_1", "x4_1") %in% pp$features),
  length(pp$state$text$levels) == 4L, pp$state$num$center < 13)
new <- d[1:2, ]
new$num <- c(1000, NA)
new$text <- c("new", "d")
new$factor <- factor(c("unseen", "x"))
baked <- internal("bake")(pp, new)
stopifnot(identical(names(baked), names(pp$data)), nrow(baked) == 2L,
  all(is.finite(as.matrix(baked))), baked$x1_1[1L] > 100)
expect_error(internal("bake")(pp, new[, -1L]), "Missing predictor")
expect_error(internal("preprocess")(data.frame(x = rep(1, 12)), y, config), "non-constant")
for (encoding in c("one-hot", "treatment", "poly", "sum", "helmert", "encodeimpact")) {
  for (scale in c("scale", "range", "nop")) {
    settings <- config
    settings$fct_preproc <- encoding
    settings$num_preproc <- scale
    settings$impute_num <- "hist"
    p <- internal("preprocess")(d, y, settings)
    b <- internal("bake")(p, new)
    stopifnot(identical(names(b), names(p$data)), all(is.finite(as.matrix(b))))
  }
}
# Encodings have a numerical reference, and unseen levels have zero impact.
c <- config
c$missing_fusion <- FALSE
c$collapse_char_to <- 10L
c$fct_preproc <- "encodeimpact"
p <- internal("preprocess")(data.frame(g = c("a", "a", "b", "b")), c(1, 3, 5, 7), c)
stopifnot(isTRUE(all.equal(p$data$x1_1, rep(c(-4, 4) / 2.0001, each = 2))))
stopifnot(internal("bake")(p, data.frame(g = "new"))$x1_1 == 0)
for (method in c("treatment", "poly", "sum", "helmert")) {
  actual <- internal("encode_matrix")(letters[1:3], method)
  reference <- switch(method, treatment = stats::contr.treatment(3), poly = stats::contr.poly(3),
    sum = stats::contr.sum(3), helmert = stats::contr.helmert(3))
  stopifnot(identical(actual, reference))
}
metrics <- internal("metrics")(c(1, 2, 4), c(2, 2, 3))
stopifnot(isTRUE(all.equal(unname(metrics[c("mse", "rmse", "mae", "mdae", "mape", "smape")]),
  c(2/3, sqrt(2/3), 2/3, 1, 5/12, (2/3 + 2/7)/3))))
stopifnot(is.nan(internal("metrics")(c(0, 0), c(0, 0))["smape"]),
  is.infinite(internal("metrics")(c(0, 1), c(1, 1))["mape"]))
stopifnot(identical(internal("filter")(data.frame(a=1:6, b=c(1,1,2,2,1,1)), 1:6, "correlation"), c(a=1, b=0)))

# All documented resampling strategies create disjoint train/test splits.
task <- internal("task")(data.frame(x = 1:48), 1:48)
for (method in c("holdout", "cv", "repeated_cv", "subsampling")) {
  r <- internal("resampling")(method, 3, 2, 0.7)
  r$instantiate(task)
  for (i in seq_len(r$iters)) stopifnot(!length(intersect(r$train_set(i), r$test_set(i))))
}

# The main suite works without optional test frameworks or mlr3pipelines.
if (requireNamespace("rpart", quietly = TRUE) && requireNamespace("e1071", quietly = TRUE)) {
  set.seed(29)
  data <- data.frame(x = rnorm(60), z = rnorm(60), category = rep(c("a", "b", "c"), 20))
  data$y <- 2 * data$x + data$z + rnorm(60, sd = 0.1)
  original <- data
  rng <- .Random.seed
  java <- getOption("java.parameters")
  result <- sense(data, "y", algos = c("rpart", "svm"), selected_filter = "variance",
    budget = 1, n_evals = 1, ratio = 0.7)
  stopifnot(identical(.Random.seed, rng), identical(data, original), identical(getOption("java.parameters"), java),
    inherits(result$time_log, "difftime"), inherits(result$plot, "sense_pipeline"),
    identical(names(result$model_predict(data[1:3, 1:3])), "y"),
    nrow(result$model_predict(data[1:3, 1:3])) == 3L)
  again <- sense(data, "y", algos = c("rpart", "svm"), selected_filter = "variance",
    budget = 1, n_evals = 1, ratio = 0.7)
  stopifnot(identical(result$testing_frame, again$testing_frame),
    identical(result$model_predict(data), again$model_predict(data)))
  # Deployment uses all rows, and averaging exactly matches the stored bases.
  trained <- environment(result$model_predict)$trained
  m <- trained$learner$model
  stopifnot(length(m$train_row_ids) == nrow(data), all(is.finite(m$oof)),
    length(unique(m$fold)) == 3L)
  base_predictions <- vapply(m$base, internal("predict_base"), numeric(nrow(data)), data=data)
  stopifnot(identical(result$model_predict(data)$y, round(rowMeans(base_predictions), 2)))
  # A selected single base still forms a matrix; non-average super learner works.
  selected <- sense(data, "y", algos = c("rpart", "svm"), super = "svm", benchmarking = 1,
    selected_filter = "correlation", tuning = "grid_search", n_evals = 1, ratio = 0.7)
  stopifnot(nrow(selected$benchmark_error) == 1L, all(is.finite(selected$model_predict(data)$y)))
  ranked <- sense(data, "y", algos = c("rpart", "svm"), benchmarking = 1,
    selected_filter = "variance", n_evals = 1, ratio = 0.7, metric = "rsq")
  ranked_model <- environment(ranked$model_predict)$trained$learner$model
  stopifnot(names(ranked_model$base) == sub("regr.", "", ranked$benchmark_error$learner_id[
    which.max(ranked$benchmark_error$regr.rsq)], fixed = TRUE))
  saved <- tempfile(fileext = ".rds")
  saveRDS(result, saved)
  restored <- readRDS(saved)
  stopifnot(identical(restored$model_predict(data), result$model_predict(data)))
  unlink(saved)
  pdf <- tempfile(fileext = ".pdf")
  grDevices::pdf(pdf)
  plot(result$plot)
  grDevices::dev.off()
  stopifnot(file.info(pdf)$size > 0)
  unlink(pdf)
  expect_error(sense(data, "y", algos = c("rpart", "rpart")), "distinct")
  expect_error(sense(data, "y", sampling_rate = 0), "sampling_rate")
  expect_error(sense(data, "y", benchmarking = 20), "benchmarking")
  expect_error(sense(data, "y", inner = "bad"), "inner")
  expect_error(sense(data, "y", missing_fusion = "TRUE"), "missing_fusion")
  data$y[1] <- NA_real_
  expect_error(sense(data, "y"), "target must be")
}

# Optional methods retain their original algorithmic backends.
if (requireNamespace("mlr3filters", quietly = TRUE)) {
  fd <- data.frame(a = 1:20, b = rep(1:5, 4), c = c(11:20, 1:10))
  for (method in c("find_correlation", "information_gain", "relief", "carscore", "cmim")) {
    filter <- mlr3filters::flt(method)
    if (all(vapply(filter$packages, requireNamespace, logical(1), quietly = TRUE))) {
      set.seed(7)
      score <- internal("filter")(fd, 1:20, method)
      set.seed(7)
      filter$calculate(internal("task")(fd, 1:20))
      stopifnot(isTRUE(all.equal(score, filter$scores)))
    }
  }
}
if (requireNamespace("lme4", quietly = TRUE)) {
  c$fct_preproc <- "encodelmer"
  group <- rep(letters[1:4], each = 5)
  target <- rep(c(-3, 0, 3, 6), each = 5) + rep(c(-1, -.5, 0, .5, 1), 4)
  p <- internal("preprocess")(data.frame(group = group), target, c)
  ref <- lme4::lmer(y ~ 1 + (1 | group), data = data.frame(y=target, group=factor(group)))
  stopifnot(isTRUE(all.equal(p$data$x1_1, as.numeric(stats::predict(ref)), tolerance=1e-6)),
    isTRUE(all.equal(internal("bake")(p, data.frame(group = "unknown"))$x1_1,
      unname(lme4::fixef(ref)[1L]))))
}
cat("sense regression tests passed\n")