tests/testthat/test-DropTip.R

In TreeTools: Create, Modify and Analyse Phylogenetic Trees

nasty <- structure(list(edge = structure(
  c(9, 12, 10, 13, 11, 10, 11, 13, 10, 13, 12, 9,
    5, 10,  1,  2,  3, 13,  9,  4, 11,  7,  8, 6),
  .Dim = c(12, 2)),
  Nnode = 5L,
  tip.label = letters[1:8]),
  class = "phylo") # Danger: Do not plot!

test_that("keep_tip() fails with small edge", {
  # False positives with ASaN
  skip_if(Sys.getenv("USING_ASAN") != "")
  expect_error(keep_tip(BalancedTree(8)$edge[, 1, drop = FALSE],
                        !tabulate(6:4, 8)))
  expect_error(keep_tip(BalancedTree(8)$edge[, 1], !tabulate(6:4, 8)))
})

test_that("keep_tip() works", {
  expect_error(keep_tip(BalancedTree(8)$edge[, c(1, 2, 1)], !tabulate(6:4, 8)))
  
  expect_equal(keep_tip(BalancedTree(9)$edge, !tabulate(5:8, 9)),
               matrix(c(6, 7, 8, 9, 9, 8, 7, 6,
                        7, 8, 9, 1, 2, 3, 4, 5), 8, 2))
  
  expect_equal(keep_tip(BalancedTree(8)$edge, !tabulate(6:4, 8)),
               matrix(c(6, 7, 8, 8, 7, 6, 9, 9,
                        7, 8, 1, 2, 3, 9, 4, 5), 8, 2))
  expect_equal(keep_tip(BalancedTree(8)$edge, !tabulate(1:4, 8)),
               BalancedTree(4)$edge)
  
  expect_equal(keep_tip(BalancedTree(8)$edge, !tabulate(3:8, 8)),
               BalancedTree(2)$edge)
  
  expect_equal(keep_tip(UnrootTree(BalancedTree(4))$edge, !tabulate(1, 4)),
               matrix(c(4, 4, 4, 1, 2, 3), 3, 2))
  
  expect_equal(Preorder(keep_tip(as.phylo(3, 7)$edge, !tabulate(1:4, 7))),
               PectinateTree(3)$edge)
  
  # Rooted tree may lose root when reaching a polytomy:
  expect_equal(keep_tip(root(StarTree(6), 4, resolve.root = TRUE)$edge,
                        !tabulate(4, 6)),
               StarTree(5)$edge)
  
  # But need not:
  expect_equal(keep_tip(RootTree(BalancedTree(5), 3)$edge, !tabulate(3, 5)),
               BalancedTree(4)$edge)
  
  unrooted <- ape::read.tree(text = "(a, b, (c, d, ((e1, e2), (f, g))));")
  expect_equal(keep_tip(unrooted$edge, !tabulate(1:4, 8)),
               UnrootTree(BalancedTree(4))$edge)
})

test_that("DropTip() works", {
  bal8 <- BalancedTree(8)
  expect_equal(NTip(DropTip(bal8, 1:8, check = FALSE)), 0)
  expect_warning(expect_true(all.equal(bal8, DropTip(bal8, -1))),
                 "`tip` must be > 0")
  expect_warning(expect_true(all.equal(bal8, DropTip(bal8, 99))),
                 "Tree only has 15 nodes")
  expect_warning(expect_true(all.equal(bal8, DropTip(bal8, "MissingTip"))),
                 "not present in tree")
  expect_warning(expect_identical(
    DropTip(bal8, c("t8", "NotThere"), check = TRUE),
    DropTip(bal8, c("t8", "NotThere"), check = FALSE)), "not present in tree")
  expect_error(DropTip(bal8, TRUE),
               "`tip` must list `TRUE` or `FALSE` for each leaf")
  expect_error(DropTip(bal8, list("Invalid format")), "`tip` must be of type")
  
  expect_equal(DropTip(bal8, 7:8), DropTip(bal8, 15L))
  expect_true(all.equal(ape::drop.tip(bal8, 6:8), DropTip(bal8, 6:8)))
  expect_true(all.equal(ape::drop.tip(bal8, c(3, 5, 7)), DropTip(bal8, c(3, 5, 7))))
  
  expect_equal(Preorder(DropTip(Preorder(nasty), c(1, 3))),
               Preorder(DropTip(nasty, c(1, 3))))
  
  expect_null(DropTip(NULL))
  expect_warning(expect_null(KeepTip(NULL, "tip")),
                 "Tips not in tree: tip")
})

test_that("DropTip() supports node labels", {
  bal8 <- RootTree(BalancedTree(8), 1)
  startLabel <- paste("Node", 9:15)
  bal8$node.label <- startLabel
  expect_equal(DropTip(bal8, 1)[["node.label"]], startLabel[-1])
  expect_equal(DropTip(bal8, 5:6)[["node.label"]], startLabel[-(5:6)])
})

test_that("DropTip() root relocation", {
  nTip <- 12
  nKept <- nTip / 2L
  for (i in c(8, 30, 324)) { # A selection of interesting failure cases
    set.seed(i)
    
    bigTree <- RandomTree(nTip)
    bigDrop <- sample.int(nTip, nKept)
    bigKeep <- setdiff(seq_len(nTip), bigDrop)
    
    reduced <- DropTip(bigTree, bigDrop)
    expect_true(all.equal(reduced, unroot(drop.tip(bigTree, bigDrop))))
    
    map <- which(KeptVerts(bigTree, !tabulate(bigDrop, nTip)))
    expect_equal(map[seq_len(nKept)], sort(bigKeep))
    newDesc <- .ListDescendants(reduced)
    bigDesc <- .ListDescendants(bigTree)
    
    for (newNode in (nKept + 1):(nKept * 2 - 2)) {
      expect_equal(sort(map[newDesc[[newNode]]]),
                   sort(intersect(bigDesc[[map[newNode]]], bigKeep)))
    }
  }
  #microbenchmark::microbenchmark(ape::drop.tip(bigTree, bigTip), DropTip(bigTree, bigTip))
  
  nTip <- 1284
  set.seed(43)
  bigTree <- RandomTree(nTip)
  bigDrop <- sample.int(nTip, nKept)
  bigKeep <- setdiff(seq_len(nTip), bigDrop)
  
  reduced <- DropTip(bigTree, bigDrop)
  expect_true(all.equal(reduced, unroot(drop.tip(bigTree, bigDrop))))
})

test_that("DropTip.multiPhylo() with attributes", {
  multi <- c(bal8 = BalancedTree(8), pec8 = PectinateTree(8))
  attr(multi, "TipLabel") <- paste0("t", 1:8)
  
  expect_equal(DropTip(unclass(multi), "t6"), unclass(DropTip(multi, "t6")))
  
  expect_equal(attr(DropTip(multi, "t8"), "TipLabel"),
               paste0("t", 1:7))
  expect_equal(names(DropTip(multi, "t8")), names(multi))
  expect_equal(DropTip(multi[1], "t1")[[1]], DropTip(multi[[1]], "t1"))
})

test_that("DropTip.Splits()", {
  bal9 <- BalancedTree(9)
  s9 <- as.Splits(bal9)
  s19 <- as.Splits(PectinateTree(19))
  
  expect_error(DropTip(s9, c(T, F)), "each leaf\\b")
  expect_warning(
    expect_warning(
      expect_equal(DropTip(s9, c(0, 9:10)), DropTip(s9, !tabulate(1:8, 9))),
      "only has 9 leaves"),
    "`tip` must be > 0"
  )
  expect_error(DropTip(s9, raw(1)), "`tip` must be of type")
  
  expect_equal(s9, DropTip(s9, NULL))
  expect_warning(
    expect_equal(DropTip(s9, c("t7", "missing")),
                 DropTip(s9, "t7", check = FALSE)),
    "not present in tree")
  
  expect_equal(unname(DropTip(s9, 4:5)), unname(as.Splits(DropTip(bal9, 4:5))))
  expect_equal(unname(KeepTip(s9, c(1:4, 7:9))),
               unname(as.Splits(DropTip(bal9, 6:5))))
  
  expect_equal(DropTip(s9[[1:5]], 8:9),
               DropTip(s9, 8:9))
  
  expect_equal(thin_splits(s9, !logical(9)),
                           structure(raw(0), .Dim = c(0L, 0L)))
  expect_equal(thin_splits(s19, 1:19 %in% 2:19),
               structure(raw(0), .Dim = c(0L, 1L)))
  expect_equal(thin_splits(s9, logical(9)), s9, ignore_attr = TRUE)
  
  expect_equal(DropTip(s9, TipLabels(s9)), as.Splits(ZeroTaxonTree()))
})

test_that("KeepTip() works", {
  expect_warning(expect_true(all.equal(
    BalancedTree(paste0("t", 5:8)),
    KeepTip(BalancedTree(8), paste0("t", 5:9))
  )))
  
  expect_warning(expect_true(all.equal(
    BalancedTree(paste0("t", 5:8)),
    KeepTip(BalancedTree(8), 5:9)
  )))
  
  expect_true(all.equal(
    KeepTip(Postorder(UnrootTree(BalancedTree(letters[1:12]))), 6:12),
    read.tree(text = "(f, (i, (g, h)), (l, (j, k)));")
  ))
  
  expect_identical(
    KeepTip(BalancedTree(12), !tabulate(1:5, 12)),
    DropTip(BalancedTree(12), !tabulate(6:12, 12))
    )
  
  s9 <- as.Splits(BalancedTree(9))
  expect_equal(KeepTip(s9, character(0)), DropTip(s9, TipLabels(s9)))
})

test_that("KeepTip() retains edge lengths", {
  bal9 <- BalancedTree(9)
  bal9$edge.length <- 10 * 1:16
  expect_equal(KeepTip(bal9, c(1, 3, 5, 7, 9))[["edge.length"]],
               c(10, 20, 30 + 40,
                 60,
                 70 + 90,
                 100, 110 + 130,
                 140 + 160))
})

test_that("KeepTipPreorder()/Postorder()", {
  pre <- Preorder(BalancedTree(1:9))
  post <- Postorder(pre)
  keep <- !tabulate(7, 9)
  expect_true(all.equal(KeepTipPreorder(pre, keep),
                        KeepTip(pre, keep)))
  expect_true(all.equal(KeepTipPostorder(post, keep),
                        KeepTip(post, keep)))
  
  emptyTree <- structure(list(edge = matrix(0, 0, 2),
                              tip.label = character(0),
                              Nnode = 0), class = "phylo")
  expect_equal(KeepTipPreorder(pre, logical(9)),
               emptyTree)
  expect_equal(KeepTipPostorder(post, logical(9)),
               emptyTree)

  expect_equal(KeepTipPreorder(pre, !logical(9)),
               pre)
  expect_equal(KeepTipPostorder(post, !logical(9)),
               post)
})