Check preorder assertion is true in Preorder()

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: TreeTools
 Title: Create, Modify and Analyse Phylogenetic Trees
-Version: 2.2.0.9002
+Version: 2.2.0.9003
 Authors@R: c(
   person("Martin R.", 'Smith', role = c("aut", "cre", "cph"), 
          email = "martin.smith@durham.ac.uk",

NAMESPACE

@@ -468,6 +468,7 @@ export(as.multiPhylo)
 export(doubleFactorials)
 export(edge_to_splits)
 export(is.TreeNumber)
+export(is_valid_preorder)
 export(logDoubleFactorials)
 export(replicate64)
 export(root_on_node)

NEWS.md

@@ -1,9 +1,11 @@
-# TreeTools 2.2.0.9002 #
+# TreeTools 2.2.0.9003 #
 
 ## New functionality
 
 - `Paste0()` provides a fast Rcpp-backed drop-in for `paste0()` / `stri_paste()`
   with `NA` propagation. Exported for use by downstream packages.
+- `Preorder()` now validates edge order for trees with a "preorder" order attribute.
+- Split lists support 32768 leaves.
 
 ## Usability
 

R/RcppExports-manual.R

@@ -4,6 +4,23 @@ keep_tip <- function(edge, keep) {
   .Call(`_TreeTools_keep_tip`, edge, keep)
 }
 
+#' Validate preorder edge ordering
+#'
+#' Checks whether edges are in valid preorder: each edge's parent has been
+#' introduced (appeared as a child) by an earlier edge, or is the root.
+#'
+#' @param parent,child Integer vectors of edge endpoints (1-indexed).
+#' @param nTip Integer: number of tips in the tree.
+#' @returns Logical: `TRUE` if edges are in valid preorder, `FALSE` otherwise.
+#' @examples
+#' tree <- BalancedTree(8)
+#' is_valid_preorder(tree[["edge"]][, 1], tree[["edge"]][, 2], NTip(tree))
+#' @template MRS
+#' @export
+is_valid_preorder <- function(parent, child, nTip) {
+  .Call(`_TreeTools_is_valid_preorder`, parent, child, nTip)
+}
+
 postorder_order <- function(edge) {
   .Call(`_TreeTools_postorder_order`, edge)
 }

R/tree_numbering.R

@@ -439,11 +439,12 @@ Preorder <- function(tree, topologyOnly = FALSE) UseMethod("Preorder")
 #' @export
 Preorder.phylo <- function(tree, topologyOnly = FALSE) {
   startOrder <- attr(tree, "order")
-  if (length(startOrder) && startOrder == "preorder") {
-    # length(x) is twice as fast as !is.null(x)
-    tree
+  edge <- tree[["edge"]]
+  if (length(startOrder) && # length(x) is twice as fast as !is.null(x)
+    startOrder == "preorder" && 
+    is_valid_preorder(edge[, 1], edge[, 2], length(tree[["tip.label"]]))) {
+      tree
   } else {
-    edge <- tree[["edge"]]
     parent <- edge[, 1]
     child <- edge[, 2]
     if (topologyOnly) {

inst/include/TreeTools/renumber_tree.h

@@ -341,6 +341,28 @@ inline std::pair<Rcpp::IntegerMatrix, Rcpp::NumericVector> preorder_weighted_pai
   return preorder_weighted_impl(parent, child, weights);
 }
 
+// O(nEdge) check: in valid preorder, every edge's parent must already
+// have been "introduced" (appeared as a child of an earlier edge, or
+// be the root).
+// [[Rcpp::export]]
+inline bool is_valid_preorder(const Rcpp::IntegerVector& parent,
+                              const Rcpp::IntegerVector& child,
+                              int n_tip) {
+  const int32 n_edge = parent.length();
+  if (child.length() != n_edge) return false;
+  const int32 root = n_tip + 1;
+  const int32 max_node = n_edge + 2; // safe upper bound
+  std::vector<bool> introduced(max_node, false);
+  introduced[root] = true;
+  for (int32 i = 0; i < n_edge; ++i) {
+    if (parent[i] < 1 || parent[i] >= max_node) return false;
+    if (!introduced[parent[i]]) return false;
+    if (child[i] < 1 || child[i] >= max_node) return false;
+    introduced[child[i]] = true;
+  }
+  return true;
+}
+
 
 
   template <typename T, std::size_t StackSize>

src/RcppExports-manual.cpp

@@ -70,6 +70,19 @@ RcppExport SEXP _TreeTools_root_binary(SEXP edgeSEXP, SEXP outgroupSEXP) {
   return rcpp_result_gen;
   END_RCPP
 }
+// is_valid_preorder
+RcppExport SEXP _TreeTools_is_valid_preorder(SEXP parentSEXP,
+                                              SEXP childSEXP,
+                                              SEXP nTipSEXP) {
+  BEGIN_RCPP
+  Rcpp::RObject rcpp_result_gen;
+  Rcpp::traits::input_parameter< const IntegerVector& >::type parent(parentSEXP);
+  Rcpp::traits::input_parameter< const IntegerVector& >::type child(childSEXP);
+  Rcpp::traits::input_parameter< int >::type n_tip(nTipSEXP);
+  rcpp_result_gen = Rcpp::wrap(TreeTools::is_valid_preorder(parent, child, n_tip));
+  return rcpp_result_gen;
+  END_RCPP
+}
 // root_on_node
 RcppExport SEXP _TreeTools_root_on_node(SEXP phySEXP, SEXP outgroupSEXP) {
   BEGIN_RCPP

src/RcppExports.cpp

@@ -527,6 +527,7 @@ BEGIN_RCPP
 END_RCPP
 }
 
+RcppExport SEXP _TreeTools_is_valid_preorder(SEXP, SEXP, SEXP);
 RcppExport SEXP _TreeTools_keep_tip(SEXP, SEXP);
 RcppExport SEXP _TreeTools_postorder_order(SEXP);
 RcppExport SEXP _TreeTools_preorder_edges_and_nodes(SEXP, SEXP);
@@ -577,6 +578,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"_TreeTools_tips_in_splits", (DL_FUNC) &_TreeTools_tips_in_splits, 1},
     {"_TreeTools_edge_to_rooted_shape", (DL_FUNC) &_TreeTools_edge_to_rooted_shape, 3},
     {"_TreeTools_rooted_shape_to_edge", (DL_FUNC) &_TreeTools_rooted_shape_to_edge, 2},
+    {"_TreeTools_is_valid_preorder",        (DL_FUNC) &_TreeTools_is_valid_preorder,        3},
     {"_TreeTools_keep_tip",                 (DL_FUNC) &_TreeTools_keep_tip,                 2},
     {"_TreeTools_postorder_order",          (DL_FUNC) &_TreeTools_postorder_order,          1},
     {"_TreeTools_preorder_edges_and_nodes", (DL_FUNC) &_TreeTools_preorder_edges_and_nodes, 2},

tests/testthat/test-tree_numbering.R

@@ -439,3 +439,33 @@ test_that("Malformed trees don't cause crashes", {
   expect_postorder(reordered)
 })
 
+test_that("is_valid_preorder() detects valid and invalid orderings", {
+  tree <- Preorder(BalancedTree(8))
+  edge <- tree[["edge"]]
+  nTip <- NTip(tree)
+
+  expect_true(is_valid_preorder(edge[, 1], edge[, 2], nTip))
+
+  # Swap two edges so a child appears before its parent
+  bad_edge <- edge
+  bad_edge[c(2, 3), ] <- bad_edge[c(3, 2), ]
+  expect_false(is_valid_preorder(bad_edge[, 1], bad_edge[, 2], nTip))
+})
+
+test_that("Preorder() catches false preorder attribute", {
+  tree <- Preorder(BalancedTree(6))
+  good_edge <- tree[["edge"]]
+
+  # Corrupt the edge ordering while keeping the attribute
+  bad_tree <- tree
+  bad_tree[["edge"]][c(2, 3), ] <- bad_tree[["edge"]][c(3, 2), ]
+  expect_equal(attr(bad_tree, "order"), "preorder")
+
+  # Preorder() should detect the corruption and reorder
+
+  fixed <- Preorder(bad_tree)
+  expect_true(is_valid_preorder(
+    fixed[["edge"]][, 1], fixed[["edge"]][, 2], NTip(fixed)
+  ))
+})
+