tests/testthat/test-tabmachine.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

test_that("tabmachine binary logistic returns scientific performance with CI", {
  set.seed(1001)
  n <- 220
  d <- data.frame(
    age = rnorm(n, 45, 12),
    bmi = rnorm(n, 23, 3),
    sex = factor(sample(c("Female", "Male"), n, TRUE))
  )
  pr <- plogis(-4 + .045*d$age + .09*d$bmi + .35*(d$sex == "Male"))
  d$y <- factor(rbinom(n, 1, pr), 0:1, c("No", "Yes"))

  z <- tabmachine(
    y, x = c("age", "bmi", "sex"), data = d, event = "Yes",
    method = "logistic", tune = FALSE, folds = 3,
    boot = 60, importance_repeats = 2,
    simplify = FALSE, show = FALSE, plot = FALSE
  )

  expect_s3_class(z, "r4vn_machine")
  expect_equal(z$settings$task, "binary")
  expect_true(all(c("estimate", "lower", "upper", "ci_method") %in% names(z$performance)))
  expect_true(all(c("auc", "sensitivity", "specificity", "ppv", "npv", "f1", "brier") %in% z$performance$metric))
  expect_true(is.list(z$threshold))
  expect_true(all(c("threshold", "lower", "upper", "ci_method") %in% names(z$threshold)))
  expect_true(nrow(z$coefficients) >= 2L)
  expect_true(all(c("OR", "Lower", "Upper", "p") %in% names(z$coefficients)))
})

test_that("tabmachine preprocessing is learned from training data and reused", {
  tr <- data.frame(x = c(1, 2, 3, NA), g = factor(c("A", "B", "A", "B")))
  te <- data.frame(x = c(1000, NA), g = factor(c("C", "A")))
  rec <- R4VN:::.r4vn_machine_recipe_fit(
    tr, c("x", "g"), preprocess = "auto", missing = "auto",
    missing_max = .9, encode = "auto", transform = "none",
    outlier = "none", corr = FALSE
  )
  expect_equal(as.numeric(rec$impute$x), 2)
  ap <- R4VN:::.r4vn_machine_recipe_apply(rec, te)
  expect_equal(nrow(ap$x), 2L)
  expect_true(length(ap$unseen) >= 1L)
})

test_that("tabmachine supports regression with bootstrap CI", {
  set.seed(1002)
  n <- 180
  d <- data.frame(x1 = rnorm(n), x2 = rnorm(n))
  d$y <- 4 + 2*d$x1 - 1.2*d$x2 + rnorm(n, sd = .8)

  z <- tabmachine(
    y, x = c("x1", "x2"), data = d,
    method = "linear", tune = FALSE, folds = 3,
    boot = 60, importance_repeats = 2,
    simplify = FALSE, show = FALSE, plot = FALSE
  )

  expect_equal(z$settings$task, "regression")
  expect_true(all(c("rmse", "mae", "r2", "mape") %in% z$performance$metric))
  expect_true(all(z$performance$ci_method == "Bootstrap"))
  expect_true(all(c("Beta", "Lower", "Upper", "p") %in% names(z$coefficients)))
})

test_that("tabmachine accepts bare predictor and dot syntax", {
  set.seed(1003)
  d <- data.frame(a = rnorm(120), b = rnorm(120))
  d$y <- factor(rbinom(120, 1, plogis(d$a)), 0:1, c("No", "Yes"))

  z1 <- tabmachine(y, x = a, data = d, event = "Yes",
                   method = "logistic", tune = FALSE, folds = 3,
                   boot = 50, importance = FALSE, simplify = FALSE,
                   calibration = FALSE, decision = FALSE,
                   show = FALSE, plot = FALSE)
  expect_equal(z1$settings$predictors, "a")

  z2 <- tabmachine(y, x = ., exclude = b, data = d, event = "Yes",
                   method = "logistic", tune = FALSE, folds = 3,
                   boot = 50, importance = FALSE, simplify = FALSE,
                   calibration = FALSE, decision = FALSE,
                   show = FALSE, plot = FALSE)
  expect_equal(z2$settings$predictors, "a")
})

test_that("SMOTE is confined to fitting and evaluation retains original prevalence", {
  set.seed(1004)
  x <- cbind(x1 = rnorm(100), x2 = rnorm(100))
  y <- c(rep(0L, 90), rep(1L, 10))
  b <- R4VN:::.r4vn_machine_balance_apply(x, y, "smote", .5, 3, 1)
  expect_gt(nrow(b$x), nrow(x))
  expect_equal(length(b$y), nrow(b$x))
  expect_equal(mean(y), .10)
})

test_that("predict.r4vn_machine returns probabilities and classes", {
  set.seed(1005)
  d <- data.frame(x = rnorm(140))
  d$y <- factor(rbinom(140, 1, plogis(.8*d$x)), 0:1, c("No", "Yes"))
  z <- tabmachine(y, x = x, data = d, event = "Yes",
                  method = "logistic", tune = FALSE, folds = 3,
                  boot = 50, importance = FALSE, simplify = FALSE,
                  calibration = FALSE, decision = FALSE,
                  show = FALSE, plot = FALSE)
  p <- predict(z, d[1:5, , drop = FALSE], type = "prob")
  cl <- predict(z, d[1:5, , drop = FALSE], type = "class")
  expect_length(p, 5L)
  expect_true(all(p >= 0 & p <= 1))
  expect_s3_class(cl, "factor")
})

test_that("optional engines fail clearly only when explicitly requested and unavailable", {
  set.seed(1006)
  d <- data.frame(x = rnorm(100))
  d$y <- factor(rbinom(100, 1, plogis(d$x)), 0:1, c("No", "Yes"))
  if (!requireNamespace("xgboost", quietly = TRUE)) {
    expect_error(
      tabmachine(y, x = x, data = d, event = "Yes", method = "xgb",
                 tune = FALSE, folds = 3, boot = 50,
                 importance = FALSE, simplify = FALSE,
                 calibration = FALSE, decision = FALSE,
                 show = FALSE, plot = FALSE),
      "No requested machine-learning engine is available"
    )
  }
})

test_that("feature engineering and PCA use a reusable training blueprint", {
  set.seed(1007)
  tr <- data.frame(x1 = rnorm(80), x2 = rnorm(80), g = factor(sample(c("A","B"),80,TRUE)))
  te <- data.frame(x1 = rnorm(12), x2 = rnorm(12), g = factor(sample(c("A","B"),12,TRUE)))
  rec <- R4VN:::.r4vn_machine_recipe_fit(
    tr, c("x1","x2","g"), preprocess="auto", missing="auto",
    missing_max=.9, encode="auto", transform="none", outlier="none",
    corr=FALSE, feature="all", degree=2, reduce="pca", variance=.90
  )
  ap1 <- R4VN:::.r4vn_machine_recipe_apply(rec, tr)
  ap2 <- R4VN:::.r4vn_machine_recipe_apply(rec, te)
  expect_equal(colnames(ap1$x), colnames(ap2$x))
  expect_true(all(grepl("^PC", colnames(ap1$x))))
  expect_lte(ncol(ap1$x), length(rec$feature_cols))
})

test_that("multiclass analysis reports aggregate and class-specific CI", {
  skip_if_not_installed("rpart")
  set.seed(1008)
  n <- 210
  d <- data.frame(x1=rnorm(n),x2=rnorm(n))
  score <- cbind(A=.8*d$x1, B=-.5*d$x1+.5*d$x2, C=-.4*d$x2)
  ex <- exp(score); prob <- ex/rowSums(ex)
  d$y <- factor(vapply(seq_len(n),function(i)sample(c("A","B","C"),1,prob=prob[i,]),character(1)))
  z <- tabmachine(y,x=c("x1","x2"),data=d,method="tree",tune=FALSE,
                  folds=3,boot=50,importance=FALSE,simplify=FALSE,
                  show=FALSE,plot=FALSE)
  expect_equal(z$settings$task,"multiclass")
  expect_true(all(c("macro_auc","macro_pr_auc","macro_f1") %in% z$performance$metric))
  expect_true(nrow(z$class_performance) > 0L)
  expect_true(all(c("auc","pr_auc","sensitivity","specificity","ppv","npv","accuracy","f1") %in% z$class_performance$metric))
  expect_true(all(c("lower","upper","ci_method") %in% names(z$class_performance)))
})


test_that("repeated CV threshold data average repeated OOF predictions per subject", {
  cv <- data.frame(
    truth = c(0, 1, 0, 1, 0, 1),
    prob = c(.10, .80, .20, .70, .30, .90),
    row_id = c(1, 2, 1, 2, 1, 2),
    rep_id = rep(1:3, each = 2),
    fold = 1L
  )
  z <- R4VN:::.r4vn_machine_oof_unique_binary(cv)
  expect_equal(nrow(z), 2L)
  expect_equal(z$truth, c(0, 1))
  expect_equal(z$prob, c(.20, .80))
})

test_that("tabmachine auto uses the low-dependency core engine set", {
  expect_equal(R4VN:::.r4vn_machine_methods("auto", "binary"),
               intersect(c("logistic", "tree"), R4VN:::.r4vn_machine_methods(c("logistic", "tree"), "binary")))
  expect_equal(R4VN:::.r4vn_machine_methods("auto", "regression"),
               intersect(c("linear", "tree"), R4VN:::.r4vn_machine_methods(c("linear", "tree"), "regression")))
  mm <- R4VN:::.r4vn_machine_methods("auto", "multiclass")
  expect_true(all(mm %in% c("multinom", "tree", "knn")))
  expect_false(any(mm %in% c("lasso", "ridge", "elastic", "rf", "xgb", "svm", "naive")))
})

test_that("engine table makes optional package use transparent", {
  used <- R4VN:::.r4vn_machine_methods("auto", "binary")
  tab <- R4VN:::.r4vn_machine_engine_table("auto", "binary", used)
  expect_true(all(c("Method", "Role", "Package", "Requested", "Available", "Used") %in% names(tab)))
  expect_true(all(tab$Role[tab$Method %in% c("logistic", "tree")] == "R4VN core"))
  expect_equal(tab$Requested[tab$Method == "logistic"], "Yes")
  expect_true(all(tab$Used[tab$Used == "Yes"] %in% "Yes"))
})

test_that("plot specifications are validated without extra packages", {
  expect_invisible(R4VN:::.r4vn_machine_validate_plot_options(
    TRUE, c("roc", "calibration"), list(all = list(font_family = "sans")), FALSE
  ))
  expect_error(
    R4VN:::.r4vn_machine_validate_plot_options(TRUE, "made_up_plot", list(), FALSE),
    "Unsupported `plot_display`"
  )
  expect_error(
    R4VN:::.r4vn_machine_validate_plot_options(TRUE, "auto", list(all = 2), FALSE),
    "must be lists"
  )
})

test_that("requested Plot-pane figures are retained in Viewer figure list", {
  dummy <- list(
    settings = list(task = "binary"),
    plots = list(
      roc = list(logistic = data.frame(fpr = c(0, 1), tpr = c(0, 1))),
      pr = list(logistic = data.frame(recall = c(0, 1), precision = c(1, .5))),
      calibration = data.frame(predicted = c(.2, .8), observed = c(.1, .9)),
      confusion = matrix(c(10, 2, 3, 12), 2),
      importance = data.frame(variable = "x", label = "x", importance = 1, metric = "auc")
    )
  )
  class(dummy) <- c("r4vn_machine", "r4vn_tab")
  viewer <- R4VN:::.r4vn_machine_plot_types(dummy, c("roc", "confusion"))
  display <- R4VN:::.r4vn_machine_display_types(dummy, c("calibration", "importance"))
  viewer <- unique(c(viewer, display))
  expect_true(all(c("roc", "confusion", "calibration", "importance") %in% viewer))
})

test_that("multiclass confusion matrix is publication-ready", {
  z <- R4VN:::.r4vn_machine_multiclass_confusion(
    truth = c("A", "A", "B", "B", "C", "C"),
    predicted = c("A", "B", "B", "B", "C", "A"),
    levels = c("A", "B", "C")
  )
  expect_equal(z$Actual, c("A", "B", "C"))
  expect_equal(names(z), c("Actual", "Predicted: A", "Predicted: B", "Predicted: C"))
  m <- R4VN:::.r4vn_machine_confusion_matrix(z)
  expect_equal(dim(m), c(3L, 3L))
  expect_equal(sum(m), 6)
})

test_that("binary report tables include CV, engine information and confusion matrix", {
  set.seed(1010)
  n <- 150
  d <- data.frame(age = rnorm(n, 50, 10), bmi = rnorm(n, 24, 3))
  d$y <- factor(rbinom(n, 1, plogis(-3 + .04*d$age + .06*d$bmi)), 0:1, c("No", "Yes"))
  z <- tabmachine(
    y, vars(age, bmi), data = d, event = "Yes",
    method = "logistic", tune = FALSE, folds = 3,
    boot = 50, importance = FALSE, simplify = FALSE,
    calibration = FALSE, decision = FALSE,
    show = FALSE, plot = FALSE
  )
  expect_true(all(c(
    "Algorithms and package requirements", "Development cross-validation",
    "Model comparison", "Final model performance", "Confusion matrix"
  ) %in% names(z$tables)))
  expect_true(nrow(z$engines) > 0L)
  expect_equal(z$confusion$Actual, c("Yes", "No"))
})

test_that("auto feature selection is deterministic and dependency-light", {
  d <- data.frame(x1 = 1:30, x2 = 31:60)
  expect_equal(
    R4VN:::.r4vn_machine_resolve_select("auto", d, c("x1", "x2"), "binary"),
    "filter"
  )
})

test_that("unsupported method names fail instead of being silently ignored", {
  expect_error(
    R4VN:::.r4vn_machine_methods("made_up_engine", "binary"),
    "Unsupported `method` for binary"
  )
  expect_error(
    R4VN:::.r4vn_machine_methods("linear", "binary"),
    "Unsupported `method` for binary"
  )
})

test_that("multiclass class performance accepts truth already aligned to prediction rows", {
  truth <- factor(c("A", "B", "C"), levels = c("A", "B", "C"))
  pred <- list(
    rows = c(2L, 4L, 6L),
    prob = rbind(
      A = c(.8, .1, .1),
      B = c(.1, .8, .1),
      C = c(.1, .1, .8)
    )
  )
  colnames(pred$prob) <- c("A", "B", "C")
  z <- R4VN:::.r4vn_machine_multiclass_class_performance(
    truth, pred, ci = FALSE, boot = 50
  )
  expect_true(nrow(z) > 0L)
  expect_true(all(z$class %in% c("A", "B", "C")))
  expect_true(all(is.finite(z$estimate[z$metric == "accuracy"])))
})