tests/testthat/test-borg_wrappers.R

In BORG: Bounded Outcome Risk Guard for Model Evaluation

# ===========================================================================
# Tests for BORG framework wrappers
# ===========================================================================

# ===========================================================================
# borg_vfold_cv tests
# ===========================================================================

test_that("borg_vfold_cv() passes through when no structure hints", {
  skip_if_not_installed("rsample")

  data <- data.frame(x = rnorm(100), y = rnorm(100))

  folds <- borg_vfold_cv(data, v = 5)

  expect_s3_class(folds, "vfold_cv")
  expect_equal(nrow(folds), 5)
})


test_that("borg_vfold_cv() blocks when spatial dependency detected", {
 skip_if_not_installed("rsample")

  set.seed(42)
  # Create clearly spatially structured data
  spatial_data <- data.frame(
    x = runif(200, 0, 100),
    y = runif(200, 0, 100)
  )
  # Add spatially autocorrelated response
  spatial_data$response <- spatial_data$x + spatial_data$y + rnorm(200, sd = 5)

  # Should block random CV
 expect_error(
    borg_vfold_cv(spatial_data, v = 5, coords = c("x", "y"), target = "response"),
    "BORG BLOCKED"
  )
})


test_that("borg_vfold_cv() allows override with warning", {
  skip_if_not_installed("rsample")

  set.seed(42)
  spatial_data <- data.frame(
    x = runif(200, 0, 100),
    y = runif(200, 0, 100)
  )
  spatial_data$response <- spatial_data$x + rnorm(200, sd = 5)

  # Should warn but proceed with allow_override
  expect_warning(
    folds <- borg_vfold_cv(spatial_data, v = 5, coords = c("x", "y"),
                           target = "response", allow_override = TRUE),
    "BORG WARNING"
  )

  expect_s3_class(folds, "vfold_cv")
})


test_that("borg_vfold_cv() auto-blocks to spatial CV", {
  skip_if_not_installed("rsample")

  set.seed(42)
  spatial_data <- data.frame(
    x = runif(200, 0, 100),
    y = runif(200, 0, 100)
  )
  spatial_data$response <- spatial_data$x + rnorm(200, sd = 5)

  # Should auto-switch to blocked CV
  folds <- borg_vfold_cv(spatial_data, v = 5, coords = c("x", "y"),
                         target = "response", auto_block = TRUE)

  # Should return rsample-compatible object
  expect_s3_class(folds, "rset")
})


test_that("borg_vfold_cv() works with grouped data", {
  skip_if_not_installed("rsample")

  set.seed(42)
  grouped_data <- data.frame(
    site = rep(1:20, each = 10),
    x = rnorm(200)
  )
  grouped_data$response <- rep(rnorm(20), each = 10) + rnorm(200, sd = 0.5)

  # Should block random CV for clustered data
  expect_error(
    borg_vfold_cv(grouped_data, v = 5, groups = "site", target = "response"),
    "BORG BLOCKED"
  )

  # Should work with auto_block
  folds <- borg_vfold_cv(grouped_data, v = 5, groups = "site",
                         target = "response", auto_block = TRUE)
  expect_s3_class(folds, "rset")
})


test_that("borg_vfold_cv() works with temporal data", {
  skip_if_not_installed("rsample")

  set.seed(42)
  n <- 200
  temporal_data <- data.frame(
    date = seq(as.Date("2020-01-01"), by = "day", length.out = n),
    x = rnorm(n)
  )
  temporal_data$response <- cumsum(rnorm(n))

  # Should block random CV for temporal data
  expect_error(
    borg_vfold_cv(temporal_data, v = 5, time = "date", target = "response"),
    "BORG BLOCKED"
  )

  # Should work with auto_block
  folds <- borg_vfold_cv(temporal_data, v = 5, time = "date",
                         target = "response", auto_block = TRUE)
  expect_s3_class(folds, "rset")
})


# ===========================================================================
# borg_group_vfold_cv tests
# ===========================================================================

test_that("borg_group_vfold_cv() works for clustered data", {
  skip_if_not_installed("rsample")

  data <- data.frame(
    site = rep(1:20, each = 5),
    x = rnorm(100),
    y = rnorm(100)
  )

  folds <- borg_group_vfold_cv(data, group = "site", v = 5)

  expect_s3_class(folds, "group_vfold_cv")
})


test_that("borg_group_vfold_cv() warns about additional dependencies", {
  skip_if_not_installed("rsample")

  set.seed(42)
  # Create data with clear spatial structure (spatially autocorrelated response)
  n <- 200
  x <- runif(n, 0, 100)
  y <- runif(n, 0, 100)
  # Response strongly depends on location (spatial dependency)
  response <- x + y + rnorm(n, sd = 5)
  site <- as.integer(cut(x, 20))  # Groups based on x bands

  data <- data.frame(
    site = site,
    x = x,
    y = y,
    response = response
  )

  # Should warn about spatial dependencies not handled by grouping
  # Note: may not always trigger depending on Moran's I threshold
  # so we make the test conditional on detecting spatial dependency
  result <- suppressWarnings(
    borg_group_vfold_cv(data, group = "site", v = 5,
                        coords = c("x", "y"), target = "response")
  )
  expect_s3_class(result, "group_vfold_cv")
})


# ===========================================================================
# borg_initial_split tests
# ===========================================================================

test_that("borg_initial_split() creates chronological split for temporal data", {
  skip_if_not_installed("rsample")

  set.seed(42)
  n <- 100
  ts_data <- data.frame(
    date = seq(as.Date("2020-01-01"), by = "day", length.out = n),
    value = cumsum(rnorm(n))
  )

  # Shuffle the data to test that temporal ordering is enforced
  ts_data <- ts_data[sample(n), ]

  split <- borg_initial_split(ts_data, prop = 0.8, time = "date")

  expect_s3_class(split, "rsplit")

  # Check that training data comes before test data temporally
  train_data <- rsample::training(split)
  test_data <- rsample::testing(split)

  expect_true(max(train_data$date) <= min(test_data$date))
})


test_that("borg_initial_split() warns about spatial dependencies", {
  skip_if_not_installed("rsample")

  set.seed(42)
  spatial_data <- data.frame(
    x = runif(100, 0, 100),
    y = runif(100, 0, 100),
    response = rnorm(100)
  )
  spatial_data$response <- spatial_data$x + rnorm(100, sd = 5)

  expect_warning(
    borg_initial_split(spatial_data, prop = 0.75,
                       coords = c("x", "y"), target = "response"),
    "BORG WARNING"
  )
})


test_that("borg_initial_split() passes through without structure hints", {
  skip_if_not_installed("rsample")

  data <- data.frame(x = rnorm(100), y = rnorm(100))

  split <- borg_initial_split(data, prop = 0.75)

  expect_s3_class(split, "rsplit")
})


# ===========================================================================
# borg_trainControl tests
# ===========================================================================

test_that("borg_trainControl() passes through without structure hints", {
  skip_if_not_installed("caret")

  data <- data.frame(x = rnorm(100), y = rnorm(100))

  ctrl <- borg_trainControl(data, method = "cv", number = 5)

  expect_type(ctrl, "list")
  expect_true("method" %in% names(ctrl))
})


test_that("borg_trainControl() blocks random CV with dependencies", {
  skip_if_not_installed("caret")

  set.seed(42)
  spatial_data <- data.frame(
    x = runif(200, 0, 100),
    y = runif(200, 0, 100)
  )
  spatial_data$response <- spatial_data$x + rnorm(200, sd = 5)

  expect_error(
    borg_trainControl(spatial_data, method = "cv", number = 5,
                      coords = c("x", "y"), target = "response"),
    "BORG BLOCKED"
  )
})


test_that("borg_trainControl() allows override with warning", {
  skip_if_not_installed("caret")

  set.seed(42)
  spatial_data <- data.frame(
    x = runif(200, 0, 100),
    y = runif(200, 0, 100)
  )
  spatial_data$response <- spatial_data$x + rnorm(200, sd = 5)

  expect_warning(
    ctrl <- borg_trainControl(spatial_data, method = "cv", number = 5,
                              coords = c("x", "y"), target = "response",
                              allow_override = TRUE),
    "BORG WARNING"
  )

  expect_type(ctrl, "list")
  expect_true("method" %in% names(ctrl))
})


# ===========================================================================
# Hook registration tests (basic)
# ===========================================================================

test_that("borg_register_hooks() and borg_unregister_hooks() don't error", {
  # Just test that they don't crash - actual hook behavior is hard to test
  expect_message(borg_unregister_hooks(), "BORG hooks removed")
})