tests/testthat/test-paintSubTree_removeShift.R

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

# Unit tests for paintSubTree_removeShift function

library(testthat)
library(phytools)

# Test paintSubTree_removeShift function
# Test: paintSubTree_removeShift handles invalid inputs correctly (edge-case input)
test_that("paintSubTree_removeShift handles invalid inputs correctly", {
  # Test non-phylo object
  expect_error(
    paintSubTree_removeShift("not_a_tree", 1),
    "tree should be an object of class 'phylo'."
  )

  # Test with matrix instead of phylo
  expect_error(
    paintSubTree_removeShift(matrix(1:4, 2, 2), 1),
    "tree should be an object of class 'phylo'."
  )
})

# Test: paintSubTree_removeShift works with basic painted tree (smoke test with valid inputs)
test_that("paintSubTree_removeShift works with basic painted tree", {
  # Create a test tree
  set.seed(123)
  tree <- phytools::pbtree(n = 10, scale = 1)
  painted <- generatePaintedTrees(tree, min_tips = 3, state = "shift")

  # Get a valid shift node (internal node with painted descendants)
  shift_nodes <- unique(painted$`Node 13`$edge[,1][painted$`Node 13`$edge[,1] > length(painted$`Node 13`$tip.label)])
  shift_node <- shift_nodes[2]

  # Apply the function
  result <- paintSubTree_removeShift(painted$`Node 13`, shift_node)

  # Check that result is a phylo object with simmap class
  expect_s3_class(result, "phylo")
  expect_s3_class(result, "simmap")

  # Check that required components exist
  expect_true("maps" %in% names(result))
  expect_true("mapped.edge" %in% names(result))

  # Check that maps list has correct length
  expect_equal(length(result$maps), nrow(result$edge))

  # Check that mapped.edge dimensions are correct
  expect_equal(nrow(result$mapped.edge), nrow(result$edge))
  expect_true(ncol(result$mapped.edge) >= 1)
})

# Test: paintSubTree_removeShift preserves tree structure
test_that("paintSubTree_removeShift preserves tree structure", {
  # Create a test tree
  set.seed(456)
  tree <- phytools::pbtree(n = 8, scale = 1)
  painted <- generatePaintedTrees(tree, min_tips = 3, state = "shift")

  # Get original tree properties
  original_ntips <- length(painted$`Node 12`$tip.label)
  original_nnodes <- painted$`Node 12`$Nnode
  original_edge_length_sum <- sum(painted$`Node 12`$edge.length)

  # Apply function
  shift_nodes <- unique(painted$`Node 12`$edge[,1][painted$`Node 12`$edge[,1] > length(painted$`Node 12`$tip.label)])
  result <- paintSubTree_removeShift(painted$`Node 12`, shift_nodes[2])

  # Check that tree structure is preserved
  expect_equal(length(result$tip.label), original_ntips)
  expect_equal(result$Nnode, original_nnodes)
  expect_equal(sum(result$edge.length), original_edge_length_sum, tolerance = 1e-10)
  expect_equal(nrow(result$edge), nrow(painted$`Node 12`$edge))
})


# Test: paintSubTree_removeShift handles stem parameter correctly (edge-case input)
test_that("paintSubTree_removeShift handles stem parameter correctly", {
  # Create a test tree
  set.seed(321)
  tree <- phytools::pbtree(n = 12, scale = 1)
  painted <- generatePaintedTrees(tree, min_tips = 4, state = "shift")

  # Get a valid internal node
  internal_nodes <- unique(painted$`Node 13`$edge[,1][painted$`Node 13`$edge[,1] > length(painted$`Node 13`$tip.label)])
  shift_node <- internal_nodes[2]

  # Test with stem = FALSE (default)
  result_no_stem <- paintSubTree_removeShift(painted$`Node 13`, shift_node, stem = FALSE)

  # Test with stem = TRUE
  result_with_stem <- paintSubTree_removeShift(painted$`Node 13`, shift_node, stem = TRUE)

  # Both should be valid simmap objects
  expect_s3_class(result_no_stem, "simmap")
  expect_s3_class(result_with_stem, "simmap")

  # Check that stem parameter affects the result
  # (The exact effect depends on the tree structure, but results should be different)
  expect_true("maps" %in% names(result_no_stem))
  expect_true("maps" %in% names(result_with_stem))
})

# Test: paintSubTree_removeShift handles tip nodes (edge-case input)
test_that("paintSubTree_removeShift handles tip nodes", {
  # Create a test tree
  set.seed(654)
  tree <- phytools::pbtree(n = 8, scale = 1)
  painted <- generatePaintedTrees(tree, min_tips = 3, state = "shift")

  # Test with a tip node
  tip_node <- 1  # First tip

  # Should work without error
  result <- paintSubTree_removeShift(painted$`Node 9`, tip_node)

  expect_s3_class(result, "simmap")
  expect_true("maps" %in% names(result))
  expect_equal(length(result$maps), nrow(result$edge))
})

# Test: paintSubTree_removeShift should error on root node (expects error)
test_that("paintSubTree_removeShift should error on root node", {
  # Create a test tree
  set.seed(987)
  tree <- phytools::pbtree(n = 10, scale = 1)
  painted <- generatePaintedTrees(tree, min_tips = 4, state = "shift")

  # Test with root node
  root_node <- length(painted$`Node 11`$tip.label) + 1

  # Should work with error
  testthat::capture_output({
    expect_error(paintSubTree_removeShift(painted$`Node 11`, root_node))
  })

})

# Test: paintSubTree_removeShift preserves edge lengths in maps
test_that("paintSubTree_removeShift preserves edge lengths in maps", {
  # Create a test tree
  set.seed(111)
  tree <- phytools::pbtree(n = 8, scale = 1)
  painted <- generatePaintedTrees(tree, min_tips = 3, state = "shift")

  # Get original total length for each edge from maps
  original_edge_lengths <- sapply(painted$`Node 9`$maps, sum)

  # Apply function
  shift_nodes <- unique(painted$`Node 9`$edge[,1][painted$`Node 9`$edge[,1] > length(painted$`Node 9`$tip.label)])
  result <- paintSubTree_removeShift(painted$`Node 9`, shift_nodes[2])

  # Check that edge lengths are preserved in maps
  result_edge_lengths <- sapply(result$maps, sum)
  expect_equal(result_edge_lengths, original_edge_lengths, tolerance = 1e-10)
})

# Test: paintSubTree_removeShift creates consistent mapped.edge matrix
test_that("paintSubTree_removeShift creates consistent mapped.edge matrix", {
  # Create a test tree
  set.seed(222)
  tree <- phytools::pbtree(n = 10, scale = 1)
  painted <- generatePaintedTrees(tree, min_tips = 4, state = "shift")

  # Apply function
  shift_nodes <- unique(painted$`Node 11`$edge[,1][painted$`Node 11`$edge[,1] > length(painted$`Node 11`$tip.label)])
  result <- paintSubTree_removeShift(painted$`Node 11`, shift_nodes[2])

  # Check that mapped.edge row sums equal edge lengths
  mapped_edge_sums <- as.vector(rowSums(result$mapped.edge))
  expect_equal(mapped_edge_sums, result$edge.length, tolerance = 1e-10)

  # Check that all values in mapped.edge are non-negative
  expect_true(all(result$mapped.edge >= 0))
})

# Test: paintSubTree_removeShift errors on trees without edge lengths (expects error)
test_that("paintSubTree_removeShift errors on trees without edge lengths", {
  # Create a tree and remove edge lengths
  set.seed(333)
  tree <- phytools::pbtree(n = 6, scale = 1)
  tree$edge.length <- NULL

  expect_error(paintSubTree_removeShift(tree, length(tree$tip.label) + 2))

})

# Test: paintSubTree_removeShift maintains class structure correctly
test_that("paintSubTree_removeShift maintains class structure correctly", {
  # Create a test tree
  set.seed(555)
  tree <- phytools::pbtree(n = 8, scale = 1)
  painted <- generatePaintedTrees(tree, min_tips = 3, state = "shift")

  # Apply function
  shift_nodes <- unique(painted$`Node 9`$edge[,1][painted$`Node 9`$edge[,1] > length(painted$`Node 9`$tip.label)])
  result <- paintSubTree_removeShift(painted$`Node 9`, shift_nodes[2])

  # Check that simmap comes first in class vector
  result_classes <- class(result)
  expect_true("simmap" %in% result_classes)
  expect_equal(result_classes[1], "simmap")
  expect_true("phylo" %in% result_classes)
})