tests/testthat/test-compare-simulation-generators.R

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

.load_comparison_script <- function() {
  script_path <- testthat::test_path(
    "..", "..", "tools", "compare-simulation-generators.R"
  )
  testthat::skip_if_not(
    file.exists(script_path),
    "Development-only comparison script is excluded from source tarballs"
  )

  script_env <- new.env(parent = globalenv())
  sys.source(script_path, envir = script_env)
  script_env
}

test_that("comparison script parses reproducible quick-run controls", {
  script_env <- .load_comparison_script()
  options <- script_env$.comparison_parse_args(c(
    "--replicates", "3",
    "--output-dir", "/tmp/comparison-output",
    "--workers", "2",
    "--diagnostic-draws", "25"
  ))

  testthat::expect_identical(options$replicates, 3L)
  testthat::expect_identical(options$output_dir, "/tmp/comparison-output")
  testthat::expect_identical(options$workers, 2L)
  testthat::expect_identical(options$diagnostic_draws, 25L)
  testthat::expect_identical(options$tree_tip_count, 200L)
  testthat::expect_identical(options$num_shifts, 5L)
})

test_that("comparison script rejects incomplete and invalid controls", {
  script_env <- .load_comparison_script()

  testthat::expect_error(
    script_env$.comparison_parse_args(c("--replicates", "0")),
    "replicates"
  )
  testthat::expect_error(
    script_env$.comparison_parse_args(c("--output-dir")),
    "requires a value"
  )
  testthat::expect_error(
    script_env$.comparison_parse_args(c("--unknown", "1")),
    "Unknown option"
  )
})

test_that("comparison script formats an empty warning log as character output", {
  script_env <- .load_comparison_script()

  testthat::expect_identical(
    script_env$.comparison_warning_lines(list()),
    character(0)
  )
  testthat::expect_identical(
    script_env$.comparison_warning_lines(list(a = c("first", "second"))),
    c("[a] first", "[a] second")
  )
})

test_that("comparison script uses public simulation generator vocabulary", {
  script_env <- .load_comparison_script()

  testthat::expect_identical(
    script_env$.comparison_generators,
    c("original", "empirical")
  )
  error_row <- script_env$.comparison_per_replicate(
    structure(list(error = "expected"), class = "comparison_error"),
    "empirical",
    "null"
  )
  testthat::expect_true("simulation_generator" %in% names(error_row))
  testthat::expect_false("simulation_design" %in% names(error_row))
})

test_that("comparison script preflights its direct helper dependencies", {
  script_env <- .load_comparison_script()

  testthat::expect_true("pkgload" %in% script_env$.comparison_required_packages)
})

test_that("comparison script excludes failed searches from inferred-shift means", {
  script_env <- .load_comparison_script()

  study <- list(
    simdata = list(
      list(covariance_matrix = diag(2L)),
      list(covariance_matrix = diag(2L))
    ),
    results = list(
      list(error = "fit failed", shift_nodes_no_uncertainty = seq_len(9L)),
      list(error = NULL, shift_nodes_no_uncertainty = seq_len(2L))
    )
  )
  rows <- script_env$.comparison_per_replicate(study, "original", "null")
  summary <- script_env$.comparison_summarize(rows)

  testthat::expect_identical(rows$status, c("error", "ok"))
  testthat::expect_true(is.na(rows$n_inferred_shifts[[1L]]))
  testthat::expect_identical(rows$n_inferred_shifts[[2L]], 2L)
  testthat::expect_identical(summary$mean_inferred_shifts, 2)
})