tests/testthat/test-model_inspect.R

In BORG: Bounded Outcome Risk Guard for Model Evaluation

# ===========================================================================
# Tests for model object inspection
# ===========================================================================

# ---------------------------------------------------------------------------
# lm inspection
# ---------------------------------------------------------------------------

test_that("borg_inspect detects lm trained on wrong data", {
  set.seed(42)
  data <- data.frame(y = rnorm(100), x = rnorm(100))
  train_idx <- 1:70
  test_idx <- 71:100

  # BAD: lm fitted on full data
  model_bad <- lm(y ~ x, data = data)

  result_bad <- borg_inspect(model_bad, train_idx, test_idx, data = data)
  expect_gt(result_bad@n_hard, 0L)
  scope_risk <- Filter(function(r) r$type == "model_scope", result_bad@risks)
  expect_gt(length(scope_risk), 0)

  # GOOD: lm fitted on train only
  model_good <- lm(y ~ x, data = data[train_idx, ])

  result_good <- borg_inspect(model_good, train_idx, test_idx, data = data)
  expect_true(result_good@is_valid)
})

test_that("borg_inspect detects lm trained on wrong rows", {
  set.seed(42)
  data <- data.frame(y = rnorm(100), x = rnorm(100))
  train_idx <- 1:70
  test_idx <- 71:100

  # BAD: lm fitted on different subset (includes test data)
  wrong_idx <- c(1:50, 71:90)  # Includes test indices!
  model_bad <- lm(y ~ x, data = data[wrong_idx, ])

  result_bad <- borg_inspect(model_bad, train_idx, test_idx, data = data)
  # Model size matches (70 obs), but rows are wrong
  # This should detect the issue via row alignment check
  expect_s4_class(result_bad, "BorgRisk")
})


# ---------------------------------------------------------------------------
# glm inspection
# ---------------------------------------------------------------------------

test_that("borg_inspect detects glm trained on wrong data", {
  set.seed(42)
  data <- data.frame(
    y = rbinom(100, 1, 0.5),
    x = rnorm(100)
  )
  train_idx <- 1:70
  test_idx <- 71:100

  # BAD: glm fitted on full data
  model_bad <- glm(y ~ x, data = data, family = binomial)

  result_bad <- borg_inspect(model_bad, train_idx, test_idx, data = data)
  expect_gt(result_bad@n_hard, 0L)

  # GOOD: glm fitted on train only
  model_good <- glm(y ~ x, data = data[train_idx, ], family = binomial)

  result_good <- borg_inspect(model_good, train_idx, test_idx, data = data)
  expect_true(result_good@is_valid)
})


# ---------------------------------------------------------------------------
# ranger inspection
# ---------------------------------------------------------------------------

test_that("borg_inspect detects ranger trained on wrong data", {
  skip_if_not_installed("ranger")

  set.seed(42)
  data <- data.frame(y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100))
  train_idx <- 1:70
  test_idx <- 71:100

  # BAD: ranger fitted on full data
  model_bad <- ranger::ranger(y ~ ., data = data)

  result_bad <- borg_inspect(model_bad, train_idx, test_idx, data = data)
  expect_gt(result_bad@n_hard, 0L)
  scope_risk <- Filter(function(r) r$type == "model_scope", result_bad@risks)
  expect_gt(length(scope_risk), 0)

  # GOOD: ranger fitted on train only
  model_good <- ranger::ranger(y ~ ., data = data[train_idx, ])

  result_good <- borg_inspect(model_good, train_idx, test_idx, data = data)
  expect_true(result_good@is_valid)
})


# ---------------------------------------------------------------------------
# parsnip inspection
# ---------------------------------------------------------------------------

test_that("borg_inspect handles parsnip model_fit objects", {
  skip_if_not_installed("parsnip")

  set.seed(42)
  data <- data.frame(y = rnorm(100), x = rnorm(100))
  train_idx <- 1:70
  test_idx <- 71:100

  # BAD: parsnip model fitted on full data
  spec <- parsnip::linear_reg() |>
    parsnip::set_engine("lm")
  model_bad <- parsnip::fit(spec, y ~ x, data = data)

  result_bad <- borg_inspect(model_bad, train_idx, test_idx, data = data)
  expect_gt(result_bad@n_hard, 0L)

  # GOOD: parsnip model fitted on train only
  model_good <- parsnip::fit(spec, y ~ x, data = data[train_idx, ])

  result_good <- borg_inspect(model_good, train_idx, test_idx, data = data)
  expect_true(result_good@is_valid)
})


# ---------------------------------------------------------------------------
# workflow inspection
# ---------------------------------------------------------------------------

test_that("borg_inspect handles tidymodels workflow objects", {
  skip_if_not_installed("workflows")
  skip_if_not_installed("recipes")
  skip_if_not_installed("parsnip")

  set.seed(42)
  data <- data.frame(
    y = rnorm(100),
    x1 = rnorm(100, mean = 10),
    x2 = rnorm(100, mean = 50)
  )
  train_idx <- 1:70
  test_idx <- 71:100

  # Create a workflow
  rec <- recipes::recipe(y ~ ., data = data[train_idx, ]) |>
    recipes::step_normalize(recipes::all_numeric_predictors())

  spec <- parsnip::linear_reg() |>
    parsnip::set_engine("lm")

  wf <- workflows::workflow() |>
    workflows::add_recipe(rec) |>
    workflows::add_model(spec)

  # GOOD: workflow fitted on train only
  wf_good <- parsnip::fit(wf, data = data[train_idx, ])

  result_good <- borg_inspect(wf_good, train_idx, test_idx, data = data)
  expect_s4_class(result_good, "BorgRisk")
  # Should be valid if fitted correctly
  expect_true(result_good@is_valid)
})


# ---------------------------------------------------------------------------
# Edge cases
# ---------------------------------------------------------------------------

test_that("model inspection handles NULL train_idx", {
  set.seed(42)
  data <- data.frame(y = rnorm(100), x = rnorm(100))
  model <- lm(y ~ x, data = data)

  # Should not error with NULL indices
  result <- borg_inspect(model, train_idx = NULL, test_idx = NULL, data = data)
  expect_s4_class(result, "BorgRisk")
  expect_true(result@is_valid)
})

test_that("model inspection handles missing data argument", {
  set.seed(42)
  data <- data.frame(y = rnorm(100), x = rnorm(100))
  train_idx <- 1:70
  test_idx <- 71:100

  model <- lm(y ~ x, data = data)

  # Should work without data argument (limited checks)
  result <- borg_inspect(model, train_idx, test_idx)
  expect_s4_class(result, "BorgRisk")
})