tests/testthat/test-print-bifrost_search.R

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

# tests/testthat/test-print-bifrost_search.R

testthat::skip_on_cran()

# Ensure helper exists regardless of test file order
if (!exists("skip_if_missing_deps", mode = "function")) {
  skip_if_missing_deps <- function() {
    testthat::skip_if_not_installed("ape")
    testthat::skip_if_not_installed("phytools")
    testthat::skip_if_not_installed("mvMORPH")
    testthat::skip_if_not_installed("future")
  }
}

# Test: print.bifrost_search prints core sections on a real no-shifts run (runs searchOptimalConfiguration with high threshold; capture_output())
test_that("print.bifrost_search prints core sections on a real no-shifts run", {
  skip_if_missing_deps()

  set.seed(123)
  tr <- ape::rtree(20)
  X <- matrix(rnorm(20 * 2), ncol = 2)
  rownames(X) <- tr$tip.label

  res <- suppressWarnings(suppressMessages(searchOptimalConfiguration(
    baseline_tree              = tr,
    trait_data                 = X,
    formula                    = "trait_data ~ 1",
    min_descendant_tips        = 10,
    num_cores                  = 1,
    shift_acceptance_threshold = 1e9,
    plot                       = FALSE,
    IC                         = "GIC",
    store_model_fit_history    = FALSE,
    method                     = "LL",
    verbose                    = FALSE
  )))

  testthat::expect_s3_class(res, "bifrost_search")

  txt <- paste(testthat::capture_output(print(res)), collapse = "\n")

  testthat::expect_true(grepl("Bifrost Search Result", txt, fixed = TRUE))
  testthat::expect_true(grepl("IC (GIC)", txt, fixed = TRUE))
  testthat::expect_true(grepl("Search", txt, fixed = TRUE))
  testthat::expect_true(grepl("mvgls", txt, fixed = TRUE))
  testthat::expect_true(grepl("Shift Nodes", txt, fixed = TRUE))
  testthat::expect_true(grepl("Warnings", txt, fixed = TRUE))

  testthat::expect_false(grepl("IC History (Best IC by Iteration)", txt, fixed = TRUE))
  testthat::expect_false(grepl("Weights \\(Support\\)", txt))
})

# Test: print.bifrost_search prints history plot, penalty/target, and weights when present (prints stub object with ic_acceptance_matrix + ic_weights)
test_that("print.bifrost_search prints history plot, penalty/target, and weights when present", {
  testthat::skip_if_not_installed("ape")
  testthat::skip_if_not_installed("phytools")
  testthat::skip_if_not_installed("txtplot")

  old_width <- getOption("width")
  old_tw <- getOption("bifrost.txtplot.width")
  old_th <- getOption("bifrost.txtplot.height")

  options(width = 80, bifrost.txtplot.width = 30L, bifrost.txtplot.height = 15L)
  on.exit({
    options(width = old_width)
    if (is.null(old_tw)) options(bifrost.txtplot.width = NULL) else options(bifrost.txtplot.width = old_tw)
    if (is.null(old_th)) options(bifrost.txtplot.height = NULL) else options(bifrost.txtplot.height = old_th)
  }, add = TRUE)

  tr <- ape::rtree(10)
  tr <- phytools::paintBranches(tr, edge = unique(tr$edge[, 2]), state = "0", anc.state = "0")
  class(tr) <- c("simmap", setdiff(class(tr), "simmap"))

  model_stub <- list(
    call = list(model = "BMM", method = "LL"),
    Y = matrix(0, nrow = ape::Ntip(tr), ncol = 3),
    formula = stats::as.formula("trait_data ~ 1")
  )

  ic_mat <- cbind(
    c(-100, -105, -103, -110, -115),
    c(1,    1,    0,    1,    1)
  )

  obj <- list(
    user_input = list(
      formula = "trait_data ~ 1",
      min_descendant_tips = 3,
      num_cores = 2,
      shift_acceptance_threshold = 20,
      plot = FALSE,
      verbose = TRUE,
      store_model_fit_history = TRUE,
      method = "LL",
      error = TRUE,
      penalty = "ridge",
      target = "CV"
    ),
    tree_no_uncertainty_untransformed = tr,
    model_no_uncertainty = model_stub,
    shift_nodes_no_uncertainty = c(12L, 15L),
    IC_used = "GIC",
    baseline_ic = -100,
    optimal_ic = -115,
    num_candidates = 5L,
    model_fit_history = list(ic_acceptance_matrix = ic_mat),
    ic_weights = data.frame(
      node = c(12L, 15L),
      ic_weight_withshift = c(0.9, 0.1)
    ),
    warnings = character(0)
  )
  class(obj) <- c("bifrost_search", "list")

  txt <- paste(testthat::capture_output(print(obj)), collapse = "\n")

  testthat::expect_true(grepl("IC History (Best IC by Iteration)", txt, fixed = TRUE))
  testthat::expect_true(grepl("\\*", txt))  # txtplot points

  testthat::expect_true(grepl("Penalty", txt, fixed = TRUE))
  testthat::expect_true(grepl("Target", txt, fixed = TRUE))

  testthat::expect_true(grepl("GIC Weights (Support)", txt, fixed = TRUE))
  testthat::expect_true(grepl("\\b12\\b", txt))
  testthat::expect_true(grepl("\\b15\\b", txt))
})

# Test: print.bifrost_search covers edge-case branches (NA types, fallback fields, schema issues) (constructs multiple stub objects for NA/schema fallbacks)
test_that("print.bifrost_search covers edge-case branches (NA types, fallback fields, schema issues)", {
  testthat::skip_if_not_installed("ape")
  testthat::skip_if_not_installed("phytools")
  testthat::skip_if_not_installed("txtplot")

  old_width <- getOption("width")
  old_tw <- getOption("bifrost.txtplot.width")
  old_th <- getOption("bifrost.txtplot.height")
  options(width = 80, bifrost.txtplot.width = 40L, bifrost.txtplot.height = 12L)
  on.exit({
    options(width = old_width)
    if (is.null(old_tw)) options(bifrost.txtplot.width = NULL) else options(bifrost.txtplot.width = old_tw)
    if (is.null(old_th)) options(bifrost.txtplot.height = NULL) else options(bifrost.txtplot.height = old_th)
  }, add = TRUE)

  # Case A
  obj_a <- list(
    user_input = list(
      min_descendant_tips = NA_integer_,
      num_cores = NA_integer_,
      shift_acceptance_threshold = NA_real_,
      plot = "maybe",
      verbose = character(0),
      store_model_fit_history = FALSE
    ),
    IC_used = "GIC",
    baseline_ic = "foo",
    optimal_ic = NA_real_,
    shift_nodes_no_uncertainty = NULL,
    model_no_uncertainty = NULL,
    ic_weights = data.frame(),
    warnings = character(0)
  )
  class(obj_a) <- c("bifrost_search", "list")
  txt_a <- paste(testthat::capture_output(print(obj_a)), collapse = "\n")
  testthat::expect_true(grepl("Requested, but no shifts detected", txt_a, fixed = TRUE))

  # Case B
  tr <- ape::rtree(10)
  tr0 <- phytools::paintBranches(tr, edge = unique(tr$edge[, 2]), state = "0", anc.state = "0")
  nd <- ape::Ntip(tr0) + 2L
  tr2 <- phytools::paintSubTree(tr0, node = nd, state = "1", anc.state = "0", stem = FALSE)

  long_sym <- as.name(paste(rep("x", 120), collapse = ""))

  model_stub <- list(
    call = list(method = "H&L"),
    formula = stats::as.formula("trait_data ~ 1"),
    residuals = rnorm(ape::Ntip(tr2))
  )

  obj_b <- list(
    user_input = list(
      store_model_fit_history = FALSE,
      error = 1.23,
      penalty = long_sym,
      target = as.name("CV")
    ),
    tree_no_uncertainty_transformed = tr2,
    model_no_uncertainty = model_stub,
    shift_nodes_no_uncertainty = c(12L, 15L),
    IC_used = "GIC",
    baseline_ic = -100,
    optimal_ic = -115,
    num_candidates = 5L,
    ic_weights = data.frame(foo = 1),
    warnings = character(0)
  )
  class(obj_b) <- c("bifrost_search", "list")
  txt_b <- paste(testthat::capture_output(print(obj_b)), collapse = "\n")
  testthat::expect_true(grepl("expected columns missing", txt_b, fixed = TRUE))

  # Case C (logical accept + ylab fallback)
  ic_mat_logical <- matrix(
    c(TRUE,  TRUE,
      TRUE,  FALSE,
      FALSE, TRUE,
      TRUE,  TRUE),
    ncol = 2, byrow = TRUE
  )
  obj_c <- list(
    user_input = list(store_model_fit_history = TRUE),
    IC_used = "(best)",
    baseline_ic = 1,
    optimal_ic  = 0,
    shift_nodes_no_uncertainty = integer(0),
    model_fit_history = list(ic_acceptance_matrix = ic_mat_logical),
    warnings = character(0)
  )
  class(obj_c) <- c("bifrost_search", "list")
  txt_c <- paste(testthat::capture_output(print(obj_c)), collapse = "\n")
  testthat::expect_true(grepl("IC History (Best IC by Iteration)", txt_c, fixed = TRUE))
})

# Test: print.bifrost_search handles missing ape/phytools gracefully (uses isolated .libPaths() to simulate missing packages)
test_that("print.bifrost_search handles missing ape/phytools gracefully", {
  old_lib <- .libPaths()
  empty_lib <- tempfile("bifrost-empty-lib-")
  dir.create(empty_lib)
  .libPaths(empty_lib)
  on.exit(.libPaths(old_lib), add = TRUE)

  tree_stub <- structure(list(), class = "phylo")

  obj <- list(
    user_input = list(store_model_fit_history = FALSE),
    tree_no_uncertainty_untransformed = tree_stub,
    model_no_uncertainty = NULL,
    shift_nodes_no_uncertainty = integer(0),
    IC_used = "GIC",
    baseline_ic = -1,
    optimal_ic = -1,
    num_candidates = 0L,
    warnings = character(0)
  )
  class(obj) <- c("bifrost_search", "list")

  txt <- paste(testthat::capture_output(print(obj)), collapse = "\n")
  testthat::expect_true(grepl("Bifrost Search Result", txt, fixed = TRUE))
})

# Test: print.bifrost_search does not print Penalty/Target when absent (prints stub object without penalty/target fields)
test_that("print.bifrost_search does not print Penalty/Target when absent", {
  testthat::skip_if_not_installed("ape")
  testthat::skip_if_not_installed("phytools")

  tr <- ape::rtree(10)
  tr <- phytools::paintBranches(tr, edge = unique(tr$edge[, 2]), state = "0", anc.state = "0")
  class(tr) <- c("simmap", setdiff(class(tr), "simmap"))

  model_stub <- list(
    call = list(model = "BMM", method = "LL"),
    Y = matrix(0, nrow = ape::Ntip(tr), ncol = 2),
    formula = stats::as.formula("trait_data ~ 1")
  )

  obj <- list(
    user_input = list(
      formula = "trait_data ~ 1",
      method = "LL",
      store_model_fit_history = FALSE
      # no penalty, no target
    ),
    tree_no_uncertainty_untransformed = tr,
    model_no_uncertainty = model_stub,
    shift_nodes_no_uncertainty = integer(0),
    IC_used = "GIC",
    baseline_ic = -1,
    optimal_ic = -1,
    num_candidates = 0L,
    warnings = character(0)
  )
  class(obj) <- c("bifrost_search", "list")

  txt <- paste(testthat::capture_output(print(obj)), collapse = "\n")
  testthat::expect_false(grepl("Penalty:", txt, fixed = TRUE))
  testthat::expect_false(grepl("Target:", txt, fixed = TRUE))
})