Add efficient ClusterTable-based split_frequencies C++ function for SplitFrequency(NULL)

NAMESPACE

@@ -254,12 +254,14 @@ S3method(print,ClusterTable)
 S3method(print,Splits)
 S3method(print,TreeNumber)
 S3method(rev,Splits)
+S3method(sort,Splits)
 S3method(sort,multiPhylo)
 S3method(summary,ClusterTable)
 S3method(summary,Splits)
 S3method(t,Splits)
 S3method(tail,Splits)
 S3method(unique,Splits)
+S3method(xtfrm,Splits)
 export(.CompatibleRaws)
 export(.CompatibleSplit)
 export(.RandomParent)

NEWS.md

@@ -1,6 +1,7 @@
 # TreeTools 2.1.0.9000 (2026-02-16) #
 
-- Add Splits and phylo methods for `SplitInformation()`.
+- `SplitInformation()` supports `Splits` and `phylo` objects.
+- `sort` and `order` support `Splits` objects.
 - `SplitFrequency(reference = NULL)` returns frequency of all splits.
 
 

R/RcppExports.R

@@ -25,6 +25,10 @@ as_newick <- function(edge) {
     .Call(`_TreeTools_as_newick`, edge)
 }
 
+split_frequencies <- function(trees) {
+    .Call(`_TreeTools_split_frequencies`, trees)
+}
+
 consensus_tree <- function(trees, p) {
     .Call(`_TreeTools_consensus_tree`, trees, p)
 }

R/Splits.R

@@ -315,6 +315,7 @@ as.logical.Splits <- function(x, tipLabels = attr(x, "tip.label"), ...) {
 print.Splits <- function(x, details = FALSE, ...) {
   nTip <- attr(x, "nTip")
   tipLabels <- attr(x, "tip.label")
+  count <- attr(x, "count")
   trivial <- TrivialSplits(x)
   cat(dim(x)[1], "bipartition", ifelse(dim(x)[1] == 1, "split", "splits"),
       if(any(trivial)) paste0("(", sum(trivial), " trivial)"),
@@ -324,9 +325,9 @@ print.Splits <- function(x, details = FALSE, ...) {
       } else {
         if (nTip) {
           if (nTip == 1) {
-            paste("tip,", tipLabels[1])
+            paste("tip,", tipLabels[[1]])
           } else {
-            paste("tips,", tipLabels[1], "..", tipLabels[nTip])
+            paste("tips,", tipLabels[[1]], "..", tipLabels[[nTip]])
           }
         } else {
           "tips"
@@ -345,18 +346,57 @@ print.Splits <- function(x, details = FALSE, ...) {
       splitNames <- character(length(x))
       nameLengths = 0L
     }
-    cat("\n ", paste0(rep.int(" ", max(nameLengths)), collapse = ""),
+    if (length(splitNames) > 0) {
+      cat("\n ", paste0(rep.int(" ", max(nameLengths)), collapse = ""),
         paste0(rep_len(c(1:9, " "), nTip), collapse = ""))
-
-    for (i in seq_len(dim(x)[1])) {
-      split <- x[i, , drop = FALSE]
-      cat("\n", splitNames[i], "",
-          paste(ifelse(as.logical(rawToBits(split)[seq_len(nTip)]), "*", "."),
-                collapse = ""))
+
+
+      nSplits <- dim(x)[[1]]
+      splitCounts <- if (!is.null(count)) {
+        if (length(count) != nSplits) {
+          warning("\"count\" attribute does not match number of splits")
+        }
+        paste0("\UD7 ", count)
+      } else {
+        rep("", nSplits)
+      }
+
+      for (i in seq_len(nSplits)) {
+        split <- x[i, , drop = FALSE]
+        cat("\n", splitNames[i], "",
+            paste(ifelse(as.logical(rawToBits(split)[seq_len(nTip)]), "*", "."),
+                  collapse = ""),
+            splitCounts[i])
+      }
     }
   }
 }
 
+#' @family Splits operations
+#' @export
+sort.Splits <- function(x, decreasing = TRUE, ...) {
+  newOrder <- order(x, decreasing = decreasing, ...)
+  count <- attr(x, "count")
+  if (is.null(count)) {
+    x[[newOrder]]
+  } else {
+    structure(x[[newOrder]], count = count[newOrder])
+  }
+}
+
+# Underpins `order`
+#' @family Splits operations
+#' @export
+xtfrm.Splits <- function(x) {
+  count <- attr(x, "count")
+  splitRanking <- as.integer(x)
+  if (is.null(count)) {
+    splitRanking
+  } else {
+    count + (splitRanking / max(splitRanking))
+  }
+}
+
 #' @family Splits operations
 #' @importFrom utils head
 #' @export
@@ -390,11 +430,14 @@ tail.Splits <- function(x, n = 6L, ...) {
 summary.Splits <- function(object, ...) {
   print(object, details = TRUE, ...)
   nTip <- attr(object, "nTip")
-  if (is.null(attr(object, "tip.label"))) {
+  tipLabels <- attr(object, "tip.label")
+  if (is.null(tipLabels)) {
     cat("\n\nTips not labelled.")
   } else {
-    cat("\n\n", paste0("Tip ", seq_len(nTip), ": ", attr(object, "tip.label"),
-                     "\t", c(character(4L), "\n")[seq_len(min(nTip, 5L))]))
+    if (length(tipLabels) > 0) {
+      cat("\n\n", paste0("Tip ", seq_len(nTip), ": ", tipLabels,
+                        "\t", c(character(4L), "\n")[seq_len(min(nTip, 5L))]))
+    }
   }
 }
 
@@ -584,7 +627,7 @@ rev.Splits <- function(x) {
 
 #' Polarize splits on a single taxon
 #'
-#' @param x Object of class [`Splits`].
+#' @param x Object that can be coerced into class [`Splits`].
 #' @param pole Numeric, character or logical vector identifying tip that will
 #' polarize each split.
 #'
@@ -593,6 +636,7 @@ rev.Splits <- function(x) {
 #' @family Splits operations
 #' @export
 PolarizeSplits <- function(x, pole = 1L) {
+  x <- as.Splits(x)
   nTip <- attr(x, "nTip")
   if (is.logical(pole)) {
     pole <- which(pole)[[1]]

R/Support.R

@@ -34,21 +34,60 @@
 SplitFrequency <- function(reference, forest = NULL) {
   if (is.null(reference) || is.null(forest)) {
     if (is.null(forest)) forest <- reference
+    if (inherits(forest, "phylo")) forest <- list(forest)
     if (length(unique(lapply(lapply(forest, TipLabels), sort))) > 1) {
       stop("All trees must bear identical labels")
     }
-    forestSplits <- do.call(c, as.Splits(forest, tipLabels = TipLabels(forest[[1]])))
-    dup <- duplicated(forestSplits)
-    ret <- forestSplits[[!dup]]
-    logicals <- vapply(seq_along(forestSplits),
-                       function(cf) ret %in% forestSplits[[cf]],
-                       logical(sum(!dup)))
-    count <- if (is.null(dim(logicals))) {
-      sum(logicals)
-    } else {
-      rowSums(logicals)
+    if (length(forest) == 0) {
+      return(structure(forest, count = integer()))
+    }
+    tipLabels <- TipLabels(forest[[1]])
+    if (length(tipLabels) < 4) {
+      return(structure(matrix(raw()), nTip = length(tipLabels),
+                       tip.label = tipLabels, count = integer(),
+                       class = "Splits"))
+    }
+    forest <- RenumberTips(forest, tipLabels)
+    forest <- Preorder(forest)
+    result <- split_frequencies(forest)
+    splits <- result[["splits"]]
+    counts <- result[["counts"]]
+    nTip <- length(tipLabels)
+    nbin <- ncol(splits)
+    if (nrow(splits) == 0) { # Not been able to hit these lines - included just in case
+      return(structure(splits, nTip = nTip, tip.label = tipLabels,              # nocov
+                       count = integer(), class = "Splits"))                    # nocov
+    }
+    # The ClusterTable outputs clusters (clades); normalize so bit 0 (tip 1)
+    # is not in the set (matching as.Splits convention)
+    nTipMod <- nTip %% 8L
+    lastByteMask <- if (nTipMod == 0L) as.raw(0xff) else as.raw(bitwShiftL(1L, nTipMod) - 1L)
+    keep <- logical(nrow(splits))
+    for (i in seq_len(nrow(splits))) {
+      val <- splits[i, ]
+      # Count bits set (to filter trivial splits)
+      nBits <- sum(vapply(as.integer(val), function(b) sum(as.integer(intToBits(b))), integer(1)))
+      if (nBits < 2L || nBits > nTip - 2L) next # trivial split
+      # Normalize: if bit 0 is NOT set, complement to match as.Splits format
+      if (!as.logical(as.integer(val[1]) %% 2L)) {
+        for (j in seq_along(val)) {
+          splits[i, j] <- as.raw(bitwXor(as.integer(val[j]), 0xffL))
+        }
+        # Mask last byte
+        if (nTipMod > 0L) {
+          splits[i, nbin] <- as.raw(bitwAnd(as.integer(splits[i, nbin]),
+                                             as.integer(lastByteMask)))
+        }
+      }
+      keep[i] <- TRUE
     }
-    attr(ret, "count") <- unname(count)
+    splits <- splits[keep, , drop = FALSE]
+    counts <- counts[keep]
+    ret <- structure(splits,
+                     nTip = nTip,
+                     tip.label = tipLabels,
+                     class = "Splits")
+    attr(ret, "count") <- counts
     ret
   } else {
     referenceSplits <- as.Splits(reference)

src/RcppExports.cpp

@@ -85,6 +85,17 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
+// split_frequencies
+List split_frequencies(const List trees);
+RcppExport SEXP _TreeTools_split_frequencies(SEXP treesSEXP) {
+BEGIN_RCPP
+    Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< const List >::type trees(treesSEXP);
+    rcpp_result_gen = Rcpp::wrap(split_frequencies(trees));
+    return rcpp_result_gen;
+END_RCPP
+}
 // consensus_tree
 RawMatrix consensus_tree(const List trees, const NumericVector p);
 RcppExport SEXP _TreeTools_consensus_tree(SEXP treesSEXP, SEXP pSEXP) {
@@ -478,6 +489,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"_TreeTools_ape_neworder_phylo", (DL_FUNC) &_TreeTools_ape_neworder_phylo, 5},
     {"_TreeTools_ape_neworder_pruningwise", (DL_FUNC) &_TreeTools_ape_neworder_pruningwise, 5},
     {"_TreeTools_as_newick", (DL_FUNC) &_TreeTools_as_newick, 1},
+    {"_TreeTools_split_frequencies", (DL_FUNC) &_TreeTools_split_frequencies, 1},
     {"_TreeTools_consensus_tree", (DL_FUNC) &_TreeTools_consensus_tree, 2},
     {"_TreeTools_descendant_edges", (DL_FUNC) &_TreeTools_descendant_edges, 3},
     {"_TreeTools_descendant_edges_single", (DL_FUNC) &_TreeTools_descendant_edges_single, 5},