as.Splits edge cases (#4)

Catch some bugs with certain methods

Author: ms609

R/Splits.R

@@ -37,43 +37,6 @@
 #' @export
 as.Splits <- function (x, tipLabels = NULL, ...) UseMethod('as.Splits')
 
-#' @keywords internal
-#' @export
-.TipLabels <- function (x) UseMethod('.TipLabels')
-
-#' @keywords internal
-#' @export
-.TipLabels.phylo <- function (x) x$tip.label
-
-#' @keywords internal
-#' @export
-.TipLabels.list <- function (x) {
-  .TipLabels(x[[1]])
-}
-
-#' @keywords internal
-#' @export
-.TipLabels.matrix <- function (x) colnames(x)
-
-#' @keywords internal
-#' @export
-.TipLabels.multiPhylo <- function (x) {
-  .TipLabels(x[[1]])
-}
-
-#' @keywords internal
-#' @export
-.TipLabels.Splits <- function (x) attr(x, 'tip.label')
-
-#' @keywords internal
-#' @export
-.TipLabels.default <- function (x) x
-
-#' @keywords internal
-#' @export
-.TipLabels.numeric <- function (x) NextMethod('.TipLabels', as.character(x))
-
-
 #' @describeIn as.Splits Convert object of class `phylo` to `Splits`.
 #' @param asSplits Logical specifying whether to return a `Splits` object,
 #'   or an unannotated two-dimensional array (useful where performance is
@@ -83,7 +46,7 @@ as.Splits.phylo <- function (x, tipLabels = NULL, asSplits = TRUE, ...) {
   if (!is.null(tipLabels)) {
     x <- RenumberTips(x, .TipLabels(tipLabels))
   }
-  x <- Cladewise(x)
+  x <- Preorder(x)
   splits <- cpp_edge_to_splits(x$edge)
   nSplits <- dim(splits)[1]
   # Return:
@@ -336,18 +299,20 @@ names.Splits <- function (x) rownames(x)
 c.Splits <- function (...) {
   splits <- list(...)
   nTip <- unique(vapply(splits, attr, 1, 'nTip'))
-  if (length(nTip) > 1) {
+  if (length(nTip) > 1L) {
     stop("Splits must relate to identical tips.")
   }
-  tips <- vapply(splits, attr, character(nTip), 'tip.label')
-  if (dim(unique(tips, MARGIN = 2))[2] != 1) {
-    stop("Order of tip labels must be identical.")
+  tips <- lapply(splits, attr, 'tip.label')
+  if (length(unique(lapply(tips, sort))) > 1L) {
+    stop("All splits must bear identical tips")
   }
+  tipLabels <- tips[[1]]
+  splits <- c(splits[1], lapply(splits[seq_along(splits)[-1]], as.Splits,
+                                  tipLabels = tipLabels))
 
-  x <- rbind(...)
-  structure(x,
+  structure(do.call(rbind, splits),
             nTip = nTip,
-            tip.label = tips[, 1],
+            tip.label = tipLabels,
             class='Splits')
 }
 
@@ -480,3 +445,51 @@ in.Splits <- function (x, table, incomparables = NULL) {
   duplicated(c(x, table), fromLast = TRUE,
              incomparables = incomparables)[seq_along(x), ]
 }
+
+
+#' @keywords internal
+#' @export
+.TipLabels <- function (x) UseMethod('.TipLabels')
+
+#' @keywords internal
+#' @export
+.TipLabels.default <- function (x) {
+  if (is.null(names(x))) {
+    if (any(duplicated(x))) {
+      NULL
+    } else {
+      x
+    }
+  } else {
+    names(x)
+  }
+}
+
+#' @keywords internal
+#' @export
+.TipLabels.phylo <- function (x) x$tip.label
+
+#' @keywords internal
+#' @export
+.TipLabels.list <- function (x) {
+  .TipLabels(x[[1]])
+}
+
+#' @keywords internal
+#' @export
+.TipLabels.matrix <- function (x) colnames(x)
+
+#' @keywords internal
+#' @export
+.TipLabels.multiPhylo <- function (x) {
+  .TipLabels(x[[1]])
+}
+
+#' @keywords internal
+#' @export
+.TipLabels.Splits <- function (x) attr(x, 'tip.label')
+
+
+#' @keywords internal
+#' @export
+.TipLabels.numeric <- function (x) NextMethod('.TipLabels', as.character(x))

src/splits.cpp

@@ -8,6 +8,7 @@ const uint32_t powers_of_two[32] = {1, 2, 4, 8, 16, 32, 64, 128, 256, 512,
                                     2097152, 4194304, 8388608, 16777216,
                                     33554432, 67108864, 134217728, 268435456,
                                     536870912U, 1073741824U, 2147483648U};
+const int BIN_SIZE = 32;
 
 // [[Rcpp::export]]
 NumericMatrix cpp_edge_to_splits(NumericMatrix edge) {
@@ -18,26 +19,26 @@ NumericMatrix cpp_edge_to_splits(NumericMatrix edge) {
   const int n_edge = edge.rows(),
     n_node = n_edge + 1,
     n_tip = edge(0, 0) - 1,
-    n_bin = n_tip / 32 + 1;
-  
+    n_bin = (n_tip / BIN_SIZE) + 1;
+
   if (n_edge == n_tip) { /* No internal nodes resolved */
     return NumericMatrix (0, n_bin);
   }
 
   uint32_t** splits = new uint32_t*[n_node];
-  for (int i = 0; i < n_node; i++) {
+  for (int i = 0; i != n_node; i++) {
     splits[i] = new uint32_t[n_bin];
-    for (int j = 0; j < n_bin; j++) {
+    for (int j = 0; j != n_bin; j++) {
       splits[i][j] = 0;
     }
   }
 
-  for (int i = 0; i < n_tip; i++) {
+  for (int i = 0; i != n_tip; i++) {
     splits[i][(int) i / 32] = powers_of_two[i % 32];
   }
 
-  for (int i = n_edge - 1; i > 0; i--) { /* edge 0 is second root edge */
-    for (int j = 0; j < n_bin; j++) {
+  for (int i = n_edge - 1; i != 0; i--) { /* edge 0 is second root edge */
+    for (int j = 0; j != n_bin; j++) {
       splits[(int) edge(i, 0) - 1][j] |= splits[(int) edge(i, 1) - 1][j];
     }
   }

tests/testthat/test-Splits.R

@@ -30,8 +30,11 @@ test_that("as.Split", {
   expect_equal("0 bipartition splits dividing 5 tips.",
                capture_output(print(as.Splits(polytomy))))
 
-  tree1 <- PectinateTree(1:8)
-  tree2 <- BalancedTree(8:1)
+  notPreOrder <- structure(list(edge = structure(c(6L, 9L, 8L, 7L, 7L, 8L, 9L,
+                                            6L, 9L, 8L, 7L, 2L, 3L, 5L, 4L, 1L),
+                                          .Dim = c(8L, 2L)), Nnode = 4L,
+                         tip.label = 1:5), class = "phylo", order = "cladewise")
+  expect_equal(c(n8 = 22, n9 = 6), as.Splits(notPreOrder)[, 1])
 
 })
 
@@ -103,7 +106,7 @@ test_that("Split combination", {
 
   expect_equal(4L, length(splits12))
   expect_equal(c(FALSE, FALSE, TRUE, TRUE), as.logical(duplicated(splits12)))
-  expect_error(c(splits1, as.Splits(tree3)))
+  expect_equal(2L, length(unique(c(splits1, as.Splits(tree3)))))
   expect_error(c(splits1, as.Splits(tree4)))
   expect_error(c(splits1, as.Splits(tree5)))
   expect_equal(c(28L, 24L, 28L, 24L),