tests/testthat/test-matrix.R

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

# Broad "runs clean and returns well-formed output" coverage across the
# outcome x loss-function x options matrix.  Guards against runtime
# breakage of any supported configuration (this is how the leafy/DR
# breakages were caught).

test_that("numeric outcome: L2 and L1 run and predict with correct shape", {
  d <- make_matrix_data()
  for (lf in c("L2", "L1")) {
    m <- partDSA(d$X, d$yN, control = ctl0(loss.function = lf))
    expect_s3_class(m, "partDSA")
    p <- predict(m, d$X)
    expect_equal(nrow(p), nrow(d$X))
    expect_false(anyNA(p))
  }
})

test_that("factor outcome: entropy/gini, binary and multi-class", {
  d <- make_matrix_data()
  for (lf in c("entropy", "gini")) {
    m <- partDSA(d$X, d$yF, control = ctl0(loss.function = lf))
    expect_s3_class(m, "partDSA")
    expect_setequal(levels(predict(m, d$X)[[2]]), c("hi", "lo"))
  }
  m3 <- partDSA(d$X, d$yF3, control = ctl0(loss.function = "entropy"))
  expect_setequal(levels(predict(m3, d$X)[[2]]), c("A", "B", "C"))
})

test_that("survival outcome: IPCW and Brier under KM and Cox weights", {
  d <- make_matrix_data()
  for (lf in c("IPCW", "Brier")) {
    for (wm in c("KM", "Cox")) {
      m <- partDSA(d$Xn, d$yS,
                   control = ctl0(loss.function = lf, wt.method = wm))
      expect_s3_class(m, "partDSA")
      r <- m$test.set.risk.DSA
      expect_true(all(is.finite(r[!is.na(r)])))
      if (lf == "Brier")                     # proper IBS stays on Brier scale
        expect_true(all(r[!is.na(r)] >= 0 & r[!is.na(r)] <= 0.25))
    }
  }
})

test_that("cross-validation (vfold > 1) produces a CV risk table", {
  d <- make_matrix_data()
  m <- partDSA(d$X, d$yN,
               control = DSA.control(vfold = 3, minsplit = 30, minbuck = 10,
                                     cut.off.growth = 3, missing = "no"))
  expect_false(is.null(m$mean.cv.risk.DSA))
  expect_length(m$sd.cv.risk, length(m$mean.cv.risk.DSA))
})

test_that("missing-data imputation runs and predicts without NAs", {
  d <- make_matrix_data()
  Xm <- d$X
  set.seed(9)
  Xm$a[sample(nrow(Xm), 20)] <- NA
  Xm$c[sample(nrow(Xm), 15)] <- NA
  ctrl <- DSA.control(vfold = 1, minsplit = 30, minbuck = 10,
                      cut.off.growth = 3, missing = "impute.at.split",
                      save.input = TRUE)   # needed to impute NA test rows on predict
  m <- partDSA(Xm, d$yN, control = ctrl)
  expect_false(anyNA(predict(m, Xm)))
})

test_that("boosting runs for a numeric outcome", {
  d <- make_matrix_data()
  ctrl <- DSA.control(vfold = 2, cut.off.growth = 3, boost = 1,
                      boost.rounds = 10, missing = "no")
  expect_no_error(partDSA(d$Xn, d$yN, control = ctrl))
})