tests/testthat/test-tree_numbering.R

In TreeTools: Create, Modify and Analyse Phylogenetic Trees

nastyEdge <- structure(c(9, 12, 10, 13, 11, 10, 11, 13, 10, 13, 12, 9,
                         5, 10,  1,  2,  3, 13,  9,  4, 11,  7,  8, 6),
                       dim = c(12, 2))
nasty <- structure(list(edge = nastyEdge, Nnode = 5L, tip.label = letters[1:8]),
                   class = "phylo")

expect_postorder <- function(edge) {
  parent <- edge[, 1]
  child <- edge[, 2]
  visited <- logical(max(parent))
  root <- min(parent)
  for (i in seq_along(parent)) {
    visited[parent[i]] <- TRUE
    expect_true(child[i] < root || visited[child[i]])
  }
  expect_equal(visited, c(logical(root - 1), !logical(max(parent) + 1 - root)))
}

test_that("RenumberTree() fails safely", {
  expect_error(RenumberTree(1:3, 1:4), "Length.*must match")
  expect_error(RenumberTree(1:3, 1:4, 5:6), "Length.*match")
  expect_error(RenumberTree(1:4, 1:4, 5:6), "Length mismatch")
})


test_that("RenumberTree() handles polytomies", {
  tr <- ape::read.tree(text = "(a, (b, d, c));")
  edge <- tr$edge
  parent <- edge[, 1]
  child <- edge[, 2]

  ret <- RenumberTree(parent, child)
  expect_equal(c(5, 5, 6, 6, 6), ret[, 1])
  expect_equal(c(1, 6, 2, 3, 4), ret[, 2])


  edge <- structure(c(6L, 7L, 5L, 7L, 6L, 5L,
                      2L, 5L, 3L, 6L, 1L, 4L),
                    dim = c(6L, 2L))

  # Must be in preorder; i.e. each node in left subtree before each node in
  # right subtree for each subtree
  #
  # Also, nodes should be rotated such that the lowest tip in a subtree
  # is always encountered first.
  #
  # These rules ensure a unique representation for any tree.
  expectation <- structure(c(5L, 6L, 6L, 5L, 7L, 7L,
                             6L, 1L, 2L, 7L, 3L, 4L),
                           dim = c(6L, 2L))
  expect_equal(RenumberTree(edge[, 1], edge[, 2]),
               expectation)

  expect_equal(c(9, 10, 10, 11, 11, 11, 10, 12, 12, 13, 13, 9,
                 10, 1, 11,  2,  4,  7, 12,  3, 13,  5,  6, 8),
               as.integer(RenumberTree(nasty$edge[, 1], nasty$edge[, 2])))
})

test_that("RenumberTree() handles singles", {
  withSingles <- ape::read.tree(text = "(a, (b, (c), (((d), (e)))));")
  expect_equal(as.integer(Preorder(withSingles)$edge),
               c(6, 6, 7, 7, 8, 7, 9, 10, 11, 10, 12,
                 1, 7, 2, 8, 3, 9, 10, 11, 4, 12, 5))
})

test_that("Replacement reorder functions work correctly", {
  ## Tree
  tree <- ape::read.tree(text = "((((((1,2),3),4),5),6),(7,(8,(9,(10,(11,12))))));")
  expect_equal(ape::reorder.phylo(tree, "cladewise"), Cladewise(tree))
  expect_equal(ape::reorder.phylo(tree, "pruningwise"), Pruningwise(tree))

  post6 <- Postorder(BalancedTree(6))$edge
  expect_postorder(post6)
  parent6 <- post6[, 1]
  child6 <- post6[, 2]

  # Order of tip pairs is arbitrary\
  expect_equal(1:2, sort(child6[parent6 == 9]))
  expect_equal(4:5, sort(child6[parent6 == 11]))
  expect_equal(c(6, 11), sort(child6[parent6 == 10]))
  expect_equal(c(3, 9), sort(child6[parent6 == 8]))
  expect_equal(c(8, 10), sort(child6[parent6 == 7]))

  star <- ape::read.tree(text = "(a, b, d, c);")
  edge <- RenumberTips(star, letters[1:4])$edge
  expect_equal(edge,
               RenumberTips(star, ape::read.tree(text = "(a, b, c, d);"))$edge)
  expect_equal(star$edge, RenumberTree(edge[, 1], edge[, 2]))
  expect_equal(list(star$edge[, 1], star$edge[, 2]),
               RenumberEdges(edge[, 1], edge[, 2]))
  
  attr(star, "order") <- "preorder"
  expect_equal(attr(RenumberTips(star, letters[1:4]), "order"), "cladewise")
  attr(star, "order") <- NULL
  expect_null(attr(RenumberTips(star, letters[1:4]), "order"))
})

test_that("RenumberTips() with numeric tipOrder", {
  tr <- BalancedTree(6)
  order <- c(6, 5, 4, 2, 3, 1)
  expect_equal(RenumberTips(tr, order), RenumberTips(tr, TipLabels(order)))
})

test_that("RenumberTips() handles misspecification", {
  expect_error(RenumberTips(BalancedTree(8), paste0("t", 0:5)),
               "Missing in `tree`: t0.*Missing in `tipOrder`: t6, t7, t8")
  expect_error(RenumberTips(BalancedTree(8), c(1, 1:8)),
               "Tree labels t1 repeated in `tipOrder`")
})

test_that("RenumberTips() works correctly", {
  abcd <- letters[1:4]
  dcba <- letters[4:1]
  bal7b <- BalancedTree(dcba)
  bsp7b <- as.Splits(bal7b)
  bal7f <- BalancedTree(abcd)
  bsp7f <- as.Splits(bal7f)
  pec7f <- PectinateTree(abcd)
  psp7f <- as.Splits(bal7f)
  pec7b <- PectinateTree(dcba)
  psp7b <- as.Splits(bal7b)

  l7 <- list("bal7b" = bal7b, "bal7f" = bal7f, "pec7f" = pec7f)
  f7 <- list(bal7f, bal7f, pec7f)
  b7 <- list(bal7b, bal7b, pec7b)
  mp7 <- structure(l7, class = "multiPhylo")

  expect_true(all.equal(unname(RenumberTips(l7, dcba)), b7))
  expect_true(all.equal(unname(RenumberTips(l7, 4:1)), b7))
  expect_true(all.equal(unname(RenumberTips(l7, abcd)), f7))
  expect_true(all.equal(unname(RenumberTips(l7, 4:1)), f7))
  
  sl7 <- list("bsp7b" = bsp7b, "bsp7f" = bsp7f, "psp7f" = psp7f)
  sf7 <- list(bsp7f, bsp7f, psp7f)
  sb7 <- list(bsp7b, bsp7b, psp7b)
  
  expect_splits_same <- function(x, y) {
    if (is.list(x)) {
      for (i in seq_along(x)) {
        expect_splits_same(x[[i]], y[[i]])
      }
    } else {
      expect_equal(TipLabels(x), TipLabels(y))
      expect_equal(PolarizeSplits(x, 1), PolarizeSplits(y, 1))
    }
  }
  
  expect_splits_same(RenumberTips(bsp7b, abcd), bsp7f)
  expect_splits_same(RenumberTips(sl7, dcba), sb7)
  expect_splits_same(RenumberTips(sl7, abcd), sf7)
  

  expect_true(all.equal(structure(f7, class = "multiPhylo"),
                        unname(RenumberTips(mp7, abcd))))
  expect_true(all.equal(structure(b7, class = "multiPhylo"),
                        unname(RenumberTips(mp7, dcba))))
  
  expect_null(RenumberTips(NULL))

  expect_equal(Preorder(RenumberTips(l7, c("extra tip", letters[1:5]))),
               Preorder(RenumberTips(l7, letters[1:4])))
  expect_error(RenumberTips(l7, letters[2:5]))
  
  
  expect_equal(
    attr(
      RenumberTips(structure(b7, TipLabel = dcba, class = "multiPhylo"), abcd),
      "TipLabel"
    ),
    abcd
  )
    
})

test_that("RenumberTips.multiPhylo() covers edge cases", {
  mp8 <- structure(
    list(BalancedTree(8), PectinateTree(8)),
    class = "multiPhylo"
  )

  # Numeric tipOrder
  result <- RenumberTips(mp8, 8:1)
  expect_equal(TipLabels(result[[1]]), paste0("t", 8:1))

  # No-op when order already matches (unlabelled: C++ pass-through, unchanged)
  result_noop <- RenumberTips(mp8, TipLabels(mp8[[1]]))
  expect_equal(result_noop[[1]][["edge"]], mp8[[1]][["edge"]])
  expect_equal(result_noop[[2]][["edge"]], mp8[[2]][["edge"]])

  # Duplicate error
  expect_error(RenumberTips(mp8, rep("t1", 8)), "repeated")

  # Length mismatch error
  expect_error(RenumberTips(mp8, paste0("t", 0:5)),
               "Missing in `tree`.*Missing in `tipOrder`")

  # Missing label error
  mp_shared <- structure(
    list(BalancedTree(8), PectinateTree(8)),
    TipLabel = paste0("t", 1:8),
    class = "multiPhylo"
  )
  expect_error(
    RenumberTips(mp_shared, c(paste0("t", 1:7), "t_unknown")),
    "missing from `tipOrder`"
  )
})

test_that("RenumberTips() unlabelled C++ path matches the per-tree path", {
  # The unlabelled multiPhylo / list fast path (renumber_tips_to in C++) must
  # produce results IDENTICAL to applying RenumberTips.phylo per tree, across
  # mixed tip orderings (incl. trees already in target order -> pass-through).
  set.seed(91)
  canon <- paste0("t", 1:12)
  forest <- c(
    list(BalancedTree(canon), PectinateTree(canon)),          # already in order
    lapply(1:6, function(i) ape::rtree(12, br = NULL))         # random orders
  )
  for (target in list(canon, rev(canon))) {
    ref <- lapply(forest, function(tr) RenumberTips(tr, target)) # per-tree R path
    mp  <- RenumberTips(structure(forest, class = "multiPhylo"), target)
    ls  <- RenumberTips(forest, target)                          # list method
    for (i in seq_along(forest)) {
      expect_identical(mp[[i]][["edge"]], ref[[i]][["edge"]])
      expect_identical(mp[[i]][["tip.label"]], ref[[i]][["tip.label"]])
      expect_identical(attr(mp[[i]], "order"), attr(ref[[i]], "order"))
      expect_identical(ls[[i]][["edge"]], ref[[i]][["edge"]])
    }
  }
})

test_that("RenumberTips.multiPhylo() materializes tip.label", {
  # TipLabel-labelled multiPhylo: individual trees should gain tip.label
  # even when the order already matches (needed by RoguePlot and others
  # that later remove TipLabel)
  labs <- paste0("t", 1:6)
  mp_labelled <- structure(
    list(BalancedTree(6), PectinateTree(6)),
    TipLabel = labs,
    class = "multiPhylo"
  )
  result <- RenumberTips(mp_labelled, labs)
  attr(result, "TipLabel") <- NULL
  # After removing TipLabel, individual trees should still have tip.label
  expect_equal(result[[1]][["tip.label"]], labs)
  expect_equal(result[[2]][["tip.label"]], labs)
})

test_that("RenumberTips.multiPhylo() preserves phylo class on elements", {
  labs <- paste0("t", 1:6)
  mp <- structure(
    list(BalancedTree(6), PectinateTree(6)),
    TipLabel = labs,
    class = "multiPhylo"
  )
  result <- RenumberTips(mp, rev(labs))
  # Each element should retain class "phylo", not be downgraded to "list"
  expect_s3_class(.subset2(result, 1), "phylo")
  expect_s3_class(.subset2(result, 2), "phylo")
})

test_that("RenumberTips.multiPhylo() handles unlabelled different orderings", {
  # Trees with different tip orderings in an unlabelled multiPhylo
  tree_abc <- read.tree(text = "(a, (b, c));")
  tree_cab <- read.tree(text = "(c, (a, b));")
  mp_mixed <- structure(list(tree_abc, tree_cab), class = "multiPhylo")

  result <- RenumberTips(mp_mixed, c("a", "b", "c"))
  per_tree <- lapply(mp_mixed, RenumberTips, c("a", "b", "c"))

  expect_equal(result[[1]][["edge"]], per_tree[[1]][["edge"]])
  expect_equal(result[[2]][["edge"]], per_tree[[2]][["edge"]])
  expect_equal(result[[1]][["tip.label"]], c("a", "b", "c"))
  expect_equal(result[[2]][["tip.label"]], c("a", "b", "c"))
})

test_that("RenumberTips.multiPhylo() batch matches per-tree", {
  set.seed(7429)
  trees <- c(
    replicate(50, RandomTree(12, root = TRUE), simplify = FALSE),
    replicate(50, PectinateTree(12), simplify = FALSE)
  )
  class(trees) <- "multiPhylo"
  target <- sort(TipLabels(trees[[1]]))

  batch <- RenumberTips(trees, target)
  per_tree <- structure(
    lapply(trees, RenumberTips.phylo, target),
    class = "multiPhylo"
  )

  for (i in seq_along(batch)) {
    expect_equal(batch[[i]][["edge"]], per_tree[[i]][["edge"]],
                 info = paste("tree", i))
    expect_equal(batch[[i]][["tip.label"]], per_tree[[i]][["tip.label"]],
                 info = paste("tree", i))
  }
})

test_that("postorder_order() works", {
  edg7 <- BalancedTree(7)$edge
  expect_postorder(edg7[postorder_order(edg7), ])
  
  test2 <- edg7[c(1:4, 9, 8, 12, 11, 10, 7:5), ]
  expect_postorder(test2[postorder_order(test2), ])
  
  nastyEdge <- structure(c(9, 12, 10, 13, 11, 10, 11, 13, 10, 13, 12, 9,
                           5, 10,  1,  2,  3, 13,  9,  4, 11,  7,  8, 6),
                         dim = c(12, 2))
  expect_postorder(nastyEdge[postorder_order(nastyEdge), ])
  
  poly <- ape::read.tree(text = "((a, b, c), (d, (e, f)));")$edge
  expect_postorder(poly[postorder_order(poly), ])
  
  star <- ape::read.tree(text = "(a, b, c, d, e, f);")$edge
  expect_postorder(star[postorder_order(star), ])
  
  expect_error(PostorderOrder(1:5), "edge matrix of a `phylo` obj")
  expect_error(PostorderOrder(matrix(1, 3, 3)), "edge matrix of a `phylo` obj")
  expect_equal(PostorderOrder(BalancedTree(4)),
               rev(seq_len(nrow(BalancedTree(4)$edge))))
  expect_equal(PostorderOrder(Postorder(BalancedTree(4))),
               seq_len(nrow(BalancedTree(4)$edge)))
  expect_postorder(nastyEdge[PostorderOrder(nastyEdge), ])
  expect_postorder(nastyEdge[PostorderOrder(nasty), ])
  
})

test_that("Reorder methods work correctly", {
  bal7 <- BalancedTree(7)
  bal7$edge.length <- 1:12 * 10
  attr(bal7, "order") <- NULL
  pec7 <- PectinateTree(7)
  list7 <- list(bal7, pec7)
  stt <- SingleTaxonTree(1)
  bad <- bal7
  bad$Nnode <- 100
  attr(bad, "order") <- NULL
  mp7 <- structure(list7, class = "multiPhylo")
  
  Test <- function(Method, ..., testEdges = TRUE) {
    expect_identical(Method(bal7, ...), Method(list7, ...)[[1]])
    expect_identical(Method(pec7, ...), Method(mp7, ...)[[2]])
    expect_true(all.equal(Method(stt), stt))
    expect_identical(Method(bal7), Method(Method(bal7)))
    expect_equal(Method(bal7),
                 Method(Preorder(Postorder(Cladewise(Pruningwise(bal7))))))
    if (testEdges) expect_equal(Method(bal7)$edge, Method(bal7$edge))
    expect_error(Method(10))
    expect_error(Method(1:2))
    expect_error(Method(matrix("one")))
    expect_null(Method(NULL))
  }
  
  Test(ApePostorder, testEdges = FALSE)
  expect_error(ApePostorder(bad))

  Test(Postorder, testEdges = FALSE) # Different order if edge lengths present
  expect_postorder(Postorder(nastyEdge))

  Test(Cladewise)
  expect_error(Cladewise(bad))

  Test(Preorder)
  
  Test(TntOrder, testEdges = FALSE)

  Test(Pruningwise, testEdges = FALSE)
  expect_error(Pruningwise(bad))

})

test_that("Preorder() gives identical output", {
  tree1 <- BalancedTree(1:9)
  numbers <- c("One", "Two", "Three", "Four", "Five", "Six",
               "Seven", "Eight", "Nine")
  tree2 <- BalancedTree(numbers[1:9])
  # Force pre-order with NEW tip labels
  tree2 <- Preorder(Postorder(RenumberTips(tree2, sort(numbers))))
  tree2$tip.label <- as.character(match(sort(numbers), numbers))
  expect_true(all.equal(tree1, tree2))
  expect_false(identical(tree1, tree2))
  
  # Now preorder after renumbering.
  # Renumbering should drop the previous preorder attribute.
  pre2 <- Preorder(RenumberTips(tree2, as.character(1:9)))
  expect_equal(tree1, pre2)
  expect_identical(tree1, pre2)
})


test_that("Reorder methods retain edge weights", {
  bal7 <- BalancedTree(7)
  bal7$edge.length <- 1:12 * 10
  attr(bal7, "order") <- NULL
  expect_equal(Preorder(bal7)[["edge.length"]],
               bal7$edge.)
  expect_equal(Preorder(Cladewise(bal7))[["edge.length"]],
               bal7$edge.)
  expect_equal(Preorder(Postorder(bal7))[["edge.length"]],
               bal7$edge.)
})

test_that("Reorder methods retain node labels", {
  bal7 <- BalancedTree(7)
  startLabels <- paste("Node", 8:13)
  bal7[["node.label"]] <- startLabels
  attr(bal7, "order") <- NULL
  if (interactive()) {
    plot(bal7, show.node.label = TRUE, xpd = NA)
  }
  expect_equal(Preorder(bal7)[["node.label"]], startLabels)
  expect_equal(Cladewise(bal7)[["node.label"]], startLabels)
  expect_equal(Preorder(Cladewise(bal7))[["node.label"]], startLabels)
  expect_equal(Postorder(bal7)[["node.label"]], startLabels)
  expect_equal(Preorder(Postorder(bal7))[["node.label"]], startLabels)
})

test_that("Malformed trees don't cause crashes", {
  treeDoubleNode <- read.tree(text = "((((((1,2)),3),4),5),6);")
  treePolytomy   <- read.tree(text = "((((1,2,3),4),5),6);")
  treeDoublyPoly <- read.tree(text = "(((((1,2,3)),4),5),6);")
  nasty <- structure(list(edge = structure(
    c(9, 12, 10, 13, 11, 10, 11, 13, 10, 13, 12, 9,
      5, 10,  1,  2,  3, 13,  9,  4, 11,  7,  8, 6),
    dim = c(12, 2)),
    Nnode = 5L,
    tip.label = letters[1:8]),
    class = "phylo") # Danger: Do not plot!

  reordered <- Preorder(treeDoubleNode)$edge
  expect_equal(11L, dim(reordered)[1])
  expect_equal(5L, sum(tabulate(reordered[, 1]) == 2L))

  postordered <- Postorder(treeDoubleNode)$edge
  expect_equal(11L, dim(postordered)[1])
  expect_equal(5L, sum(tabulate(postordered[, 1]) == 2L))


  reordered <- Preorder(treePolytomy)$edge
  expect_equal(9L, dim(reordered)[1])
  expect_equal(c(2L, 2L, 2L, 3L), as.integer(table(reordered[, 1])))

  reordered <- Postorder(treePolytomy)$edge
  expect_equal(9L, dim(reordered)[1])
  expect_equal(c(2L, 2L, 2L, 3L), as.integer(table(reordered[, 1])))


  reordered <- Preorder(treeDoublyPoly)$edge
  expect_equal(10L, dim(reordered)[1])
  expect_equal(c(2L, 2L, 2L, 1L, 3L), as.integer(table(reordered[, 1])))

  reordered <- Postorder(treeDoublyPoly)$edge
  expect_equal(10L, dim(reordered)[1])
  expect_equal(c(2L, 2L, 2L, 1L, 3L), as.integer(table(reordered[, 1])))

  #C <- 0
  #plot(Preorder(nasty)); nodelabels(c(12, 10, 13, 11, 9) - C); tiplabels(1:8 - C)
  #edgelabels(c(2, 3, 6, 4, 8, 10, 9, 5, 7, 1, 12, 11) - C)
  reordered <- Preorder(nasty)$edge
  expect_equal(12L, dim(reordered)[1])
  # Nodes renumbered
  expect_equal(c(2L, 3L, 3L, 2L, 2L), tabulate(reordered[, 1])[9:13])

  reordered <- Postorder(nasty)$edge
  expect_equal(12L, dim(reordered)[1])
  expect_postorder(reordered)
})