tests/testthat/test-multinomial_learners.R

In tlverse/sl3: Pipelines for Machine Learning and Super Learning

context("test-multinomial_learners.R -- multinomial learners in Super Learner")
library(origami)
options(sl3.verbose = FALSE)

g0 <- function(W) {
  W1 <- W[, 1]
  W2 <- W[, 2]
  W3 <- W[, 3]
  W4 <- W[, 4]

  # rep(0.5, nrow(W))
  scale_factor <- 0.8
  A1 <- plogis(scale_factor * W1)
  A2 <- plogis(scale_factor * W2)
  A3 <- plogis(scale_factor * W3)
  A <- cbind(A1, A2, A3)

  # make sure A sums to 1
  A <- normalize_rows(A)
}

gen_data <- function(n = 1000, p = 4) {
  W <- matrix(rnorm(n * p), nrow = n)
  colnames(W) <- paste("W", seq_len(p), sep = "")
  g0W <- g0(W)
  A <- factor(apply(g0W, 1, function(pAi) which(rmultinom(1, 1, pAi) == 1)))
  A_vals <- levels(A)

  df <- data.frame(W, A)

  df$g0W <- g0(W)

  return(df)
}

set.seed(1234)
data <- gen_data(1000)


Wnodes <- grep("^W", names(data), value = TRUE)
Anode <- "A"
folds <- make_folds(nrow(data), V = 10, fold_fun = folds_vfold)
task <- sl3_Task$new(data, covariates = Wnodes, outcome = Anode)

# define learners
learners <- list(
  rf = make_learner(Lrnr_ranger),
  xgb = make_learner(Lrnr_xgboost),
  # glmnet = make_learner(Lrnr_glmnet),
  rpart = make_learner(Lrnr_rpart),
  svm = make_learner(Lrnr_svm),
  multinom_gf = make_learner(Lrnr_independent_binomial, make_learner(Lrnr_glm_fast)),
  mean = make_learner(Lrnr_mean)
)

# stack <- make_learner(Stack, learners)
# cv_stack <- make_learner(Lrnr_cv,stack)
# fit <- cv_stack$train(task)
# fit$fit_object$fold_fits[[1]]$predict()

# define Super Learner
mn_sl <- make_learner(Lrnr_sl, learners)

# test_that("Multinomial Lrnr_sl components for debugging", {
#   # debugonce(learners$xgb$.__enclos_env__$private$.train)
#   # learners$xgb$base_train(task)
#   stack <- make_learner(Stack, learners)
#   stack_fit <- stack$train(task)
#
#   fits <- stack_fit$fit_object$learner_fits
#   preds <- lapply(fits, learner_fit_predict)
#
#   stack_chained <- stack_fit$chain()
#
#   cv_stack <- make_learner(Lrnr_cv, stack)
#   cv_stack_fit <- cv_stack$train(task)
#   cv_stack_chained <- cv_stack_fit$chain()
#   meta_fit <- logit_metalearner$base_train(cv_stack_chained)
#   coef(meta_fit)
# })
test_that("Lrnr_sl multinomial integration test", {
  sl_fit <- mn_sl$train(task)
  preds <- unpack_predictions(sl_fit$base_predict())
  expect_equal(dim(preds), c(length(task$Y), length(levels(task$Y))))
})

test_that("Lrnr_sl produces predictions with retained factor levels", {
  # get predictions from Lrnr_* wrapper
  sl_fit <- mn_sl$train(task)
  preds <- sl_fit$base_predict()

  original_names <- levels(data$A)
  predicted_names <- names(preds[[1]][[1]])

  # check equality of predictions
  expect_equal(original_names, predicted_names)
})