Retain tip labels for labelled trees

Author: ms609

R/tree_numbering.R

@@ -666,47 +666,59 @@ RenumberTips.multiPhylo <- function(tree, tipOrder) {
   at <- attributes(tree)
   labelled <- !is.null(at[["TipLabel"]])
 
-  startOrder <- if (labelled) at[["TipLabel"]] else tree[[1L]][["tip.label"]]
+  if (!labelled) {
+    # Unlabelled: each tree may have different tip orderings,
+    # so must process individually
+    tree <- lapply(tree, RenumberTips.phylo, tipOrder)
+    attributes(tree) <- at
+    return(tree)
+  }
+
+  startOrder <- at[["TipLabel"]]
   newOrder <- if (is.numeric(tipOrder)) {
     startOrder[tipOrder]
   } else {
     TipLabels(tipOrder, single = TRUE)
   }
 
-  if (identical(startOrder, newOrder)) return(tree)
-
-  if (any(duplicated(newOrder))) {
-    stop("Tree labels ",
-         paste0(newOrder[duplicated(newOrder)], collapse = ", "),
-         " repeated in `tipOrder`")
-  }
+  nTip <- length(startOrder)
+  if (identical(startOrder, newOrder)) {
+    # Tip numbering already correct; use identity permutation to ensure
+    # each tree materializes its own tip.label element
+    matchOrder <- seq_len(nTip)
+  } else {
+    if (any(duplicated(newOrder))) {
+      stop("Tree labels ",
+           paste0(newOrder[duplicated(newOrder)], collapse = ", "),
+           " repeated in `tipOrder`")
+    }
 
-  if (length(startOrder) != length(newOrder)) {
-    startOnly <- setdiff(startOrder, newOrder)
-    newOnly <- setdiff(newOrder, startOrder)
-    if (length(startOnly)) {
-      stop("Tree labels and tipOrder must match.",
-           if (length(newOnly)) "\n  Missing in `tree`: ",
-           paste0(newOnly, collapse = ", "),
-           if (length(startOnly)) "\n  Missing in `tipOrder`: ",
-           paste0(startOnly, collapse = ", ")
-      )
+    if (length(startOrder) != length(newOrder)) {
+      startOnly <- setdiff(startOrder, newOrder)
+      newOnly <- setdiff(newOrder, startOrder)
+      if (length(startOnly)) {
+        stop("Tree labels and tipOrder must match.",
+             if (length(newOnly)) "\n  Missing in `tree`: ",
+             paste0(newOnly, collapse = ", "),
+             if (length(startOnly)) "\n  Missing in `tipOrder`: ",
+             paste0(startOnly, collapse = ", ")
+        )
+      }
+      newOrder <- intersect(newOrder, startOrder)
     }
-    newOrder <- intersect(newOrder, startOrder)
-  }
 
-  nTip <- length(startOrder)
-  matchOrder <- match(startOrder, newOrder)
-  if (any(is.na(matchOrder))) {
-    stop("Tree labels ",
-         paste0(startOrder[is.na(matchOrder)], collapse = ", "),
-         " missing from `tipOrder`")
+    matchOrder <- match(startOrder, newOrder)
+    if (any(is.na(matchOrder))) {
+      stop("Tree labels ",
+           paste0(startOrder[is.na(matchOrder)], collapse = ", "),
+           " missing from `tipOrder`")
+    }
   }
 
   tree <- .Call(`_TreeTools_renumber_tips_batch`, tree, matchOrder, nTip,
                 newOrder)
 
-  if (labelled) at[["TipLabel"]] <- newOrder
+  at[["TipLabel"]] <- newOrder
   attributes(tree) <- at
   tree
 }

tests/testthat/test-tree_numbering.R

@@ -177,8 +177,10 @@ test_that("RenumberTips.multiPhylo() covers edge cases", {
   result <- RenumberTips(mp8, 8:1)
   expect_equal(TipLabels(result[[1]]), paste0("t", 8:1))
 
-  # Early return when order matches
-  expect_identical(RenumberTips(mp8, TipLabels(mp8[[1]])), mp8)
+  # No-op when order already matches (unlabelled: per-tree fallback)
+  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")
@@ -199,6 +201,38 @@ test_that("RenumberTips.multiPhylo() covers edge cases", {
   )
 })
 
+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() 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(