tests/testthat/test-leafy-and-loss.R

In partDSA: Partitioning Using Deletion, Substitution, and Addition Moves

# Regression tests for Phase 2 correctness fixes.

make_num_data <- function(n = 150, p = 3, seed = 42) {
  set.seed(seed)
  x <- data.frame(matrix(rnorm(n * p), n, p))
  names(x) <- paste0("X", seq_len(p))
  y <- x[[1]] * 2 - 0.3 * x[[2]] + rnorm(n)
  list(x = x, y = y)
}

test_that("bagged (leafy) partDSA runs when mtry >= number of predictors", {
  d <- make_num_data(p = 3)  # fewer predictors than the default mtry (4)
  ctrl <- DSA.control(leafy = 1, leafy.num.trees = 5, cut.off.growth = 3,
                      leafy.random.num.variables.per.split = 4, missing = "no")
  expect_no_error(fit <- partDSA(d$x, d$y, control = ctrl))
  expect_s3_class(fit, "LeafyDSA")
})

test_that("leafy mtry is honored when smaller than the number of predictors", {
  d <- make_num_data(p = 6)
  ctrl <- DSA.control(leafy = 1, leafy.num.trees = 5, cut.off.growth = 3,
                      leafy.random.num.variables.per.split = 2, missing = "no")
  expect_no_error(partDSA(d$x, d$y, control = ctrl))
})

test_that("leafy classification runs with default mtry", {
  d <- make_num_data(p = 3)
  yf <- factor(ifelse(d$y > median(d$y), "hi", "lo"))
  ctrl <- DSA.control(leafy = 1, leafy.num.trees = 5, cut.off.growth = 3,
                      missing = "no")
  expect_no_error(partDSA(d$x, yf, control = ctrl))
})

test_that("unimplemented DR survival loss errors with a clear message", {
  set.seed(1); n <- 120
  x <- data.frame(a = rnorm(n), b = runif(n))
  y <- survival::Surv(rexp(n), rbinom(n, 1, 0.7))
  ctrl <- DSA.control(vfold = 1, minsplit = 30, minbuck = 10,
                      cut.off.growth = 3, loss.function = "DR", missing = "no")
  expect_error(partDSA(x, y, control = ctrl), "not implemented")
})