tests/testthat/test-simulation-helpers.R

In bifrost: Branch-Level Inference Framework for Recognizing Optimal Shifts in Traits

test_that("simulation integer validators accept and reject scalar/vector controls", {
  testthat::expect_identical(.simulation_check_integer_scalar(NULL, "x", allow_null = TRUE), NULL)
  testthat::expect_identical(.simulation_check_integer_scalar(3, "x", minimum = 1, maximum = 5), 3L)
  testthat::expect_error(
    .simulation_check_integer_scalar(6, "x", maximum = 5),
    "`x` must be a single finite integer"
  )

  testthat::expect_identical(.simulation_check_integer_vector(c(1, 3), "x", minimum = 1), c(1L, 3L))
  testthat::expect_error(
    .simulation_check_integer_vector(c(1, NA), "x"),
    "`x` must be a finite integer vector"
  )
  testthat::expect_error(
    .simulation_check_integer_vector(0, "x", minimum = 1),
    "`x` must be a finite integer vector"
  )
})

test_that("simulation seed helpers restore caller RNG state", {
  old_seed <- if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
  } else {
    NULL
  }
  on.exit({
    if (is.null(old_seed)) {
      if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
        rm(".Random.seed", envir = .GlobalEnv)
      }
    } else {
      assign(".Random.seed", old_seed, envir = .GlobalEnv)
    }
  }, add = TRUE)

  if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    rm(".Random.seed", envir = .GlobalEnv)
  }
  testthat::expect_null(.simulation_restore_seed(NULL))
  testthat::expect_null(.simulation_set_seed(NULL))
  seed_state <- .simulation_set_seed(42)
  testthat::expect_false(seed_state$had_seed)
  testthat::expect_true(exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))
  .simulation_restore_seed(seed_state)
  testthat::expect_false(exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))

  set.seed(100)
  existing_seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
  seed_state <- .simulation_set_seed(101)
  .simulation_restore_seed(seed_state)
  testthat::expect_identical(get(".Random.seed", envir = .GlobalEnv, inherits = FALSE), existing_seed)

  kind_before <- RNGkind()
  seed_state <- .simulation_set_seed(102, kind = "L'Ecuyer-CMRG")
  testthat::expect_identical(RNGkind()[[1L]], "L'Ecuyer-CMRG")
  .simulation_restore_seed(seed_state)
  testthat::expect_identical(RNGkind(), kind_before)
  testthat::expect_identical(get(".Random.seed", envir = .GlobalEnv, inherits = FALSE), existing_seed)
})

test_that("simulation replicate seeds preserve unseeded execution", {
  seeds <- .simulation_replicate_seeds(3L, seeded = FALSE)

  testthat::expect_length(seeds, 3L)
  testthat::expect_true(all(vapply(seeds, is.null, logical(1))))
})

test_that("simulation seed runner restores absent and existing caller state on errors", {
  old_seed <- if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
  } else {
    NULL
  }
  on.exit({
    if (is.null(old_seed)) {
      if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
        rm(".Random.seed", envir = .GlobalEnv)
      }
    } else {
      assign(".Random.seed", old_seed, envir = .GlobalEnv)
    }
  }, add = TRUE)

  runner <- .simulation_seed_runner()
  if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    rm(".Random.seed", envir = .GlobalEnv)
  }
  testthat::expect_identical(runner(NULL, 42L), 42L)
  testthat::expect_false(exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))
  existing_kind <- RNGkind()
  testthat::expect_type(runner(102, stats::runif(1L)), "double")
  testthat::expect_identical(RNGkind(), existing_kind)
  testthat::expect_false(exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))
  testthat::expect_error(runner(103, stop("seeded failure")), "seeded failure")
  testthat::expect_identical(RNGkind(), existing_kind)
  testthat::expect_false(exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))

  set.seed(104)
  existing_seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
  testthat::expect_type(runner(105, stats::runif(1L)), "double")
  testthat::expect_identical(
    get(".Random.seed", envir = .GlobalEnv, inherits = FALSE),
    existing_seed
  )
  testthat::expect_error(runner(105, stop("seeded failure")), "seeded failure")
  testthat::expect_identical(
    get(".Random.seed", envir = .GlobalEnv, inherits = FALSE),
    existing_seed
  )
})

test_that("simulation covariance validation characterizes malformed matrices", {
  testthat::expect_error(
    .simulation_validate_covariance(matrix("x", nrow = 1L)),
    "finite numeric values"
  )
  testthat::expect_error(
    .simulation_validate_covariance(matrix(c(1, 0.1, 0.2, 1), nrow = 2L)),
    "symmetric"
  )
  testthat::expect_error(
    .simulation_validate_covariance(matrix(c(1, 2, 2, 1), nrow = 2L)),
    "positive definite"
  )
})

test_that("empirical covariance draws use template fallbacks and validate dimensions", {
  template <- list(
    n_response_traits = 2L,
    residual_covariance = NULL,
    covariance_mean = 0,
    variance_mean = 1,
    residual_df = NULL,
    n_tips = 8L
  )

  withr::local_seed(106)
  draw <- .simulation_draw_covariance(template, simulation_generator = "empirical")
  testthat::expect_equal(dim(draw$sigma), c(2L, 2L))
  testthat::expect_identical(draw$covariance_df, 7L)
  testthat::expect_true(all(eigen(draw$sigma, symmetric = TRUE, only.values = TRUE)$values > 0))

  mismatched <- template
  mismatched$n_response_traits <- 3L
  mismatched$residual_covariance <- diag(2)
  mismatched$residual_df <- 4L
  testthat::expect_error(
    .simulation_draw_covariance(mismatched, simulation_generator = "empirical"),
    "dimensions must match the number of response traits"
  )
})

test_that("integration covariance transforms validate floors and preserve marginal variances", {
  sigma <- matrix(
    c(2, 0.6, 0.6, 1),
    nrow = 2L,
    dimnames = list(c("a", "b"), c("a", "b"))
  )

  testthat::expect_error(
    .simulation_transform_integration(sigma, power = 2, eigen_floor = 1),
    "strictly between zero and one"
  )

  identity_transform <- .simulation_transform_integration(sigma, power = 1)
  stronger_transform <- .simulation_transform_integration(sigma, power = 2)
  testthat::expect_identical(identity_transform$sigma, sigma)
  testthat::expect_equal(diag(stronger_transform$sigma), diag(sigma))
  testthat::expect_identical(dimnames(stronger_transform$sigma), dimnames(sigma))
  testthat::expect_false(isTRUE(all.equal(stronger_transform$sigma, sigma)))
})

test_that("simulation unused-dot checker names offending arguments", {
  testthat::expect_true(.simulation_check_unused_dots(list()))
  testthat::expect_error(
    .simulation_check_unused_dots(list(extra = 1, 2)),
    "Unused argument\\(s\\): extra, <unnamed>"
  )
})