tests/testthat/test-addShiftToModel.R

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

# Test file for addShiftToModel function
# This file should be placed in the tests/testthat/ directory of your package

library(testthat)
library(ape)
library(phytools)

# Helper function to create a basic SIMMAP tree for testing
create_test_simmap_tree <- function(n_tips = 20) {
  set.seed(123)
  tree <- pbtree(n = n_tips, scale = 1)
  simmap_tree <- paintSubTree(tree, node = Ntip(tree) + 1,
                               state = "0", anc.state = "0")
  return(simmap_tree)
}

# Helper function to check if a tree is a valid SIMMAP tree
is_valid_simmap <- function(tree) {
  return(inherits(tree, "simmap") &&
           !is.null(tree$maps) &&
           !is.null(tree$mapped.edge))
}

# Test: addShiftToModel returns correct structure (checks return value)
test_that("addShiftToModel returns correct structure", {
  tree <- create_test_simmap_tree()
  shift_node <- Ntip(tree) + 2  # First internal node after root

  result <- addShiftToModel(tree, shift_node = shift_node, current_shift_id = 0L)

  # Check return structure
  expect_type(result, "list")
  expect_named(result, c("tree", "shift_id"))
  expect_s3_class(result$tree, "simmap")
  expect_type(result$shift_id, "double")
})

# Test: addShiftToModel increments shift ID correctly
test_that("addShiftToModel increments shift ID correctly", {
  tree <- create_test_simmap_tree()
  shift_node <- Ntip(tree) + 2

  # Test with different starting shift IDs
  test_cases <- c(0L, 1L, 5L, 10L)

  for (start_id in test_cases) {
    result <- addShiftToModel(tree, shift_node = shift_node, current_shift_id = start_id)
    expect_equal(result$shift_id, start_id + 1,
                 info = paste("Failed for start_id:", start_id))
  }
})

# Test: addShiftToModel preserves tree structure
test_that("addShiftToModel preserves tree structure", {
  tree <- create_test_simmap_tree()
  shift_node <- Ntip(tree) + 2
  original_ntip <- Ntip(tree)
  original_nnode <- Nnode(tree)

  result <- addShiftToModel(tree, shift_node = shift_node, current_shift_id = 0L)

  # Check that tree topology is preserved
  expect_equal(Ntip(result$tree), original_ntip)
  expect_equal(Nnode(result$tree), original_nnode)
  expect_equal(nrow(result$tree$edge), nrow(tree$edge))
})

# Test: addShiftToModel creates valid SIMMAP tree
test_that("addShiftToModel creates valid SIMMAP tree", {
  tree <- create_test_simmap_tree()
  shift_node <- Ntip(tree) + 2

  result <- addShiftToModel(tree, shift_node = shift_node, current_shift_id = 0L)

  expect_true(is_valid_simmap(result$tree))
  expect_true(!is.null(result$tree$maps))
  expect_true(!is.null(result$tree$mapped.edge))
})

# Test: addShiftToModel paints subtree with correct state
test_that("addShiftToModel paints subtree with correct state", {
  tree <- create_test_simmap_tree(n_tips = 8)
  shift_node <- Ntip(tree) + 3  # Second internal node after root
  current_shift_id <- 0L

  result <- addShiftToModel(tree, shift_node = shift_node, current_shift_id = current_shift_id)

  # Get descendants of the shift node
  descendants <- getDescendants(tree, shift_node)

  # Check that the new state appears in the mapped.edge matrix
  expected_state <- as.character(current_shift_id + 1)
  expect_true(expected_state %in% colnames(result$tree$mapped.edge))

  # Verify that some edges have the new state
  new_state_edges <- result$tree$mapped.edge[, expected_state] > 0
  expect_true(any(new_state_edges))
})

# Test: addShiftToModel works with different node types (smoke test with valid inputs)
test_that("addShiftToModel works with different node types", {
  tree <- create_test_simmap_tree(n_tips = 10)

  # Test with different internal nodes
  internal_nodes <- (Ntip(tree) + 2):(Ntip(tree) + Nnode(tree))

  for (node in internal_nodes[1:3]) {  # Test first 3 internal nodes
    result <- addShiftToModel(tree, shift_node = node, current_shift_id = 0L)
    expect_s3_class(result$tree, "simmap")
    expect_equal(result$shift_id, 1L)
  }
})

# Test: addShiftToModel handles sequential shifts (edge-case input)
test_that("addShiftToModel handles sequential shifts", {
  tree <- create_test_simmap_tree(n_tips = 8)

  # Apply first shift
  shift_node1 <- Ntip(tree) + 2
  result1 <- addShiftToModel(tree, shift_node = shift_node1, current_shift_id = 0L)

  # Apply second shift
  shift_node2 <- Ntip(tree) + 4
  result2 <- addShiftToModel(result1$tree, shift_node = shift_node2,
                             current_shift_id = result1$shift_id)

  expect_equal(result1$shift_id, 1L)
  expect_equal(result2$shift_id, 2L)
  expect_s3_class(result2$tree, "simmap")

  # Check that both states exist in the final tree
  expect_true("1" %in% colnames(result2$tree$mapped.edge))
  expect_true("2" %in% colnames(result2$tree$mapped.edge))
})

# Test: addShiftToModel input validation
test_that("addShiftToModel input validation", {
  tree <- create_test_simmap_tree()

  # Test with invalid node numbers
  expect_error(addShiftToModel(tree, shift_node = 0, current_shift_id = 0L))
  expect_error(addShiftToModel(tree, shift_node = Ntip(tree) + Nnode(tree) + 1,
                               current_shift_id = 0L))

  # Test with tip nodes (should work but might behave differently)
  expect_error(result <- addShiftToModel(tree, shift_node = 1, current_shift_id = 0L))
})

# Test: addShiftToModel preserves edge lengths
test_that("addShiftToModel preserves edge lengths", {
  tree <- create_test_simmap_tree()
  original_edge_lengths <- tree$edge.length
  shift_node <- Ntip(tree) + 2

  result <- addShiftToModel(tree, shift_node = shift_node, current_shift_id = 0L)

  # Edge lengths should be preserved (approximately, due to floating point)
  expect_equal(sum(result$tree$edge.length), sum(original_edge_lengths),
               tolerance = 1e-10)
})

# Test: addShiftToModel works with different shift_id types (smoke test with valid inputs)
test_that("addShiftToModel works with different shift_id types", {
  tree <- create_test_simmap_tree()
  shift_node <- Ntip(tree) + 2

  # Test with integer
  result_int <- addShiftToModel(tree, shift_node = shift_node, current_shift_id = 0L)
  expect_equal(result_int$shift_id, 1)

  # Test with numeric
  result_num <- addShiftToModel(tree, shift_node = shift_node, current_shift_id = 0)
  expect_equal(result_num$shift_id, 1)
})

# Test: addShiftToModel maintains tree attributes
test_that("addShiftToModel maintains tree attributes", {
  tree <- create_test_simmap_tree()
  tree$custom_attribute <- "test_value"  # Add custom attribute
  shift_node <- Ntip(tree) + 2

  result <- addShiftToModel(tree, shift_node = shift_node, current_shift_id = 0L)

  # Check that basic tree attributes are maintained
  expect_equal(result$tree$tip.label, tree$tip.label)
  expect_equal(result$tree$Nnode, tree$Nnode)
})

# Test: addShiftToModel error handling for missing paintSubTree_mod (expects error)
test_that("addShiftToModel error handling for missing paintSubTree_mod", {
  # This test assumes paintSubTree_mod might not be available
  # Skip if the function is available, otherwise expect an error

  tree <- create_test_simmap_tree()
  shift_node <- Ntip(tree) + 2

  # If paintSubTree_mod doesn't exist, this should fail
  if (!exists("paintSubTree_mod")) {
    expect_error(addShiftToModel(tree, shift_node = shift_node, current_shift_id = 0L))
  } else {
    # If it exists, the function should work
    result <- addShiftToModel(tree, shift_node = shift_node, current_shift_id = 0L)
    expect_s3_class(result$tree, "simmap")
  }
})

# Test: addShiftToModel handles root node error correctly (expects error)
test_that("addShiftToModel handles root node error correctly", {
  tree <- create_test_simmap_tree()
  root_node <- Ntip(tree) + 1

  # Root node should cause an error in paintSubTree_mod due to the indexing issue
  expect_error(addShiftToModel(tree, shift_node = root_node, current_shift_id = 0L),
               "attempt to select less than one element")
})

# Test: addShiftToModel works with all valid internal nodes (smoke test with valid inputs)
test_that("addShiftToModel works with all valid internal nodes", {
  tree <- create_test_simmap_tree(n_tips = 6)
  valid_nodes <- (Ntip(tree) + 2):(Ntip(tree) + Nnode(tree))

  # Should have at least one valid internal node
  expect_true(length(valid_nodes) >= 1)

  # Test that all valid nodes work
  for (node in valid_nodes) {
    result <- addShiftToModel(tree, shift_node = node, current_shift_id = 0L)
    expect_s3_class(result$tree, "simmap")
    expect_equal(result$shift_id, 1L)
  }
})