Cherries()

.github/workflows/R-CMD-check.yml

@@ -51,8 +51,8 @@ jobs:
         config:
           - {os: windows-latest, r: 'release'}
           - {os: macOS-latest, r: 'release'}
-          - {os: ubuntu-24.04, r: '3.6', rspm: "https://packagemanager.posit.co/cran/2022-04-01"}
-          - {os: ubuntu-24.04, r: '4.0', rspm: "https://packagemanager.posit.co/cran/2022-04-01"}
+          - {os: ubuntu-24.04, r: '3.6', rspm: "https://packagemanager.posit.co/cran/2022-10-11"}
+          - {os: ubuntu-24.04, r: '4.0', rspm: "https://packagemanager.posit.co/cran/2022-10-11"}
           - {os: ubuntu-24.04, r: 'release', rspm: "https://packagemanager.posit.co/cran/__linux__/noble/latest"}
           - {os: ubuntu-24.04, r: 'devel', rspm: "https://packagemanager.posit.co/cran/__linux__/noble/latest"}
 
@@ -86,7 +86,7 @@ jobs:
           fi
           echo "Current package version is now: $(grep "Version:" DESCRIPTION | awk '{print $2}')"
         shell: bash
-
+        
       - name: Set up R
         uses: r-lib/actions/setup-r@v2
         with:
@@ -97,7 +97,6 @@ jobs:
         run: |
           sudo apt-get install texlive-latex-base texlive-fonts-recommended
 
-
       - name: Install system dependencies (R 3.x)
         if: matrix.config.r < '4.0'
         run: |
@@ -127,11 +126,6 @@ jobs:
           sed -i '1i#include <cstdint>' vdiffr-src/src/devSVG.cpp
           R CMD INSTALL --preclean --no-multiarch --with-keep.source vdiffr-src
           rm -rf vdiffr-src
-
-      - name: Show installed R packages
-        run: |
-          Rscript -e 'sessionInfo()'
-          Rscript -e 'installed.packages()[, c("Package", "Version")]'
 
       - name: Set up R dependencies (R 3.x)
         if: matrix.config.r < '4.0'
@@ -142,7 +136,7 @@ jobs:
             github::ms609/PlotTools@v0.3.1
             rcmdcheck@1.3.3
             waldo@0.4.0
-            testthat@3.0.4
+            testthat@3.1.5
             pkgload@1.2.4
             pkgdown@2.0.1
             bslib@0.3.1
@@ -161,32 +155,18 @@ jobs:
           needs: |
             check
             coverage
-
-      - name: Show installed R packages
-        run: |
-          Rscript -e 'sessionInfo()'
-          Rscript -e 'installed.packages()[, c("Package", "Version")]'
 
       - name: Set up R dependencies (Non-Windows)
         if: ${{runner.os != 'Windows' && matrix.config.r >= '4.0' }}
         uses: r-lib/actions/setup-r-dependencies@v2
         with:
           needs: |
             check
-          extra-packages:
+          extra-packages: |
+            TreeDist=?ignore-before-r=4.0.0
+            vdiffr=?ignore-before-r=4.0.0
             phangorn=?ignore-before-r=4.1.0
-
-      - name: Show installed R packages
-        run: |
-          Rscript -e 'sessionInfo()'
-          Rscript -e 'installed.packages()[, c("Package", "Version")]'
-
-      - name: Debug package requirements
-        run: |
-          Rscript -e 'ip <- as.data.frame(installed.packages()[, c("Package","Version")]); print(ip[ip$Package %in% c("rmarkdown","knitr","xfun","htmltools","tinytex"), ])'
-          Rscript -e 'deps <- tools::package_dependencies("htmltools", db = available.packages(), which = c("Depends","Imports","LinkingTo")); print(deps)'
-          Rscript -e 'cat("rmarkdown DESCRIPTION:\n"); cat(readLines(system.file("DESCRIPTION", package = "rmarkdown")), sep="\n")'
-
+
       - name: Check package
         uses: r-lib/actions/check-r-package@v2
 

DESCRIPTION

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

NAMESPACE

@@ -32,6 +32,8 @@ S3method(ApePostorder,multiPhylo)
 S3method(ApePostorder,phylo)
 S3method(ArtificialExtinction,matrix)
 S3method(ArtificialExtinction,phyDat)
+S3method(Cherries,numeric)
+S3method(Cherries,phylo)
 S3method(Cladewise,"NULL")
 S3method(Cladewise,list)
 S3method(Cladewise,matrix)
@@ -270,6 +272,7 @@ export(ArtEx)
 export(ArtificialExtinction)
 export(BalancedTree)
 export(CharacterInformation)
+export(Cherries)
 export(CladeSizes)
 export(Cladewise)
 export(CladisticInfo)

NEWS.md

@@ -1,5 +1,6 @@
-# TreeTools 1.16.1.9001` (development) #
+# TreeTools 1.16.1.9002` (development) #
 
+- `Cherries()` counts the cherries in a binary tree.
 - New method `as.Splits.integer()`.
 - Fix `RoguePlot(sort = TRUE)`
   [Rogue#33](https://github.com/ms609/Rogue/issues/33).

R/Cherries.R

@@ -0,0 +1,29 @@
+#' Count cherries in a tree
+#' 
+#' `Cherries()` counts the number of vertices in a binary tree whose children
+#' are both leaves.
+#' 
+#' @param tree A binary tree, of class `phylo`; or a matrix corresponding to its
+#' edge matrix.
+#' @param nTip Number of leaves in tree.
+#' @return `Cherries()` returns an integer specifying the number of nodes whose
+#' children are both leaves.
+#' @family tree properties
+#' @template MRS
+#' @export
+Cherries <- function(tree, nTip) UseMethod("Cherries")
+
+#' @rdname Cherries
+#' @export
+Cherries.phylo <- function(tree, nTip = NTip(tree)) {
+  n_cherries_wrapper(tree[["edge"]][, 1], tree[["edge"]][, 2], nTip)
+}
+
+#' @rdname Cherries
+#' @export
+Cherries.numeric <- function(tree, nTip) {
+  if (is.null(dim(tree)) || dim(tree)[[2]] != 2) {
+    stop("`tree` must be the edge matrix of a tree of class phylo")
+  }
+  n_cherries_wrapper(tree[, 1], tree[, 2], nTip)
+}

R/RcppExports.R

@@ -69,6 +69,10 @@ minimum_spanning_tree <- function(order) {
     .Call(`_TreeTools_minimum_spanning_tree`, order)
 }
 
+n_cherries_wrapper <- function(parent, child, nTip) {
+    .Call(`_TreeTools_n_cherries_wrapper`, parent, child, nTip)
+}
+
 path_lengths <- function(edge, weight, init_nas) {
     .Call(`_TreeTools_path_lengths`, edge, weight, init_nas)
 }

inst/include/TreeTools/n_cherries.h

@@ -0,0 +1,70 @@
+#ifndef TreeTools_n_cherries_
+#define TreeTools_n_cherries_
+
+#include <memory>    /* for std::unique_ptr */
+#include <stdexcept> /* for errors */
+#include <vector>
+
+#include "assert.h" /* for ASSERT */
+
+namespace TreeTools{
+
+// Number of cherries in a binary phylogenetic tree
+inline int n_cherries(const int* parent,
+                      const int* child,
+                      const size_t n_edge,
+                      const int n_tip) {
+
+  const size_t n_node = n_edge / 2;
+  std::unique_ptr<bool[]> internal(new bool[n_node]());
+
+  const bool unrooted = n_edge % 2;
+  if (unrooted) {
+    std::unique_ptr<bool[]> is_child(new bool[n_node + n_tip + 1]());
+
+    for (size_t ed = 0; ed < n_edge; ++ed) {
+      is_child[child[ed]] = true;
+    }
+
+    const int i_limit = n_tip + n_node + 1;
+    int root_node = n_tip + 1;
+    for (; root_node <= i_limit; ++root_node) {
+      if (!is_child[root_node]) break;
+    }
+
+    if (root_node == i_limit) {
+      throw std::runtime_error("Tree must be acyclic"); // nocov
+    }
+
+    bool root_internal_found = false;
+    for (size_t ed = 0; ed < n_edge; ++ed) {
+      const int child_i = child[ed];
+      if (child_i > n_tip) {
+        const int node = parent[ed];
+        if (!root_internal_found && node == root_node) {
+          root_internal_found = true;
+        } else {
+          internal[node - n_tip] = true;
+        }
+      }
+    }
+
+  } else {
+    for (size_t ed = 0; ed < n_edge; ++ed) {
+      if (child[ed] > n_tip) {
+        const size_t node_idx = parent[ed] - n_tip;
+        internal[node_idx] = true;
+      }
+    }
+  }
+
+  int n_cherries = 0;
+  for (size_t i = 0; i < n_node; ++i) {
+    if (!internal[i]) ++n_cherries;
+  }
+  return n_cherries;
+}
+
+}
+
+#endif

src/RcppExports.cpp

@@ -223,6 +223,19 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
+// n_cherries_wrapper
+Rcpp::IntegerVector n_cherries_wrapper(const Rcpp::IntegerVector parent, const Rcpp::IntegerVector child, const int nTip);
+RcppExport SEXP _TreeTools_n_cherries_wrapper(SEXP parentSEXP, SEXP childSEXP, SEXP nTipSEXP) {
+BEGIN_RCPP
+    Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< const Rcpp::IntegerVector >::type parent(parentSEXP);
+    Rcpp::traits::input_parameter< const Rcpp::IntegerVector >::type child(childSEXP);
+    Rcpp::traits::input_parameter< const int >::type nTip(nTipSEXP);
+    rcpp_result_gen = Rcpp::wrap(n_cherries_wrapper(parent, child, nTip));
+    return rcpp_result_gen;
+END_RCPP
+}
 // path_lengths
 NumericMatrix path_lengths(const IntegerMatrix edge, const DoubleVector weight, const LogicalVector init_nas);
 RcppExport SEXP _TreeTools_path_lengths(SEXP edgeSEXP, SEXP weightSEXP, SEXP init_nasSEXP) {
@@ -452,6 +465,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"_TreeTools_mixed_base_to_parent", (DL_FUNC) &_TreeTools_mixed_base_to_parent, 2},
     {"_TreeTools_kept_vertices", (DL_FUNC) &_TreeTools_kept_vertices, 2},
     {"_TreeTools_minimum_spanning_tree", (DL_FUNC) &_TreeTools_minimum_spanning_tree, 1},
+    {"_TreeTools_n_cherries_wrapper", (DL_FUNC) &_TreeTools_n_cherries_wrapper, 3},
     {"_TreeTools_path_lengths", (DL_FUNC) &_TreeTools_path_lengths, 3},
     {"_TreeTools_cpp_edge_to_splits", (DL_FUNC) &_TreeTools_cpp_edge_to_splits, 3},
     {"_TreeTools_duplicated_splits", (DL_FUNC) &_TreeTools_duplicated_splits, 2},