R/is.monophyletic.R

   1 ## ace.R (2009-06-19)
   2
   3 ##   Ancestral Character Estimation
   4
   5 ## Copyright 2009 Johan Nylander and Emmanuel Paradis
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 is.monophyletic <-
  11     function(phy, tips, reroot = !is.rooted(phy), plot = FALSE, ...)
  12 {
  13     if (!inherits(phy, "phylo"))
  14         stop("object 'phy' is not of class 'phylo'")
  15     if (length(tips) == 1) return(TRUE)
  16     n <- length(phy$tip.label)
  17     if (length(tips) == n) return(TRUE)
  18     ROOT <- n + 1
  19     if (is.numeric(tips)) {
  20         if (any(tips > n))
  21             stop("incorrect tip#: should not be greater than the number of tips")
  22         tips <- sort(tips)
  23     }
  24     if (is.character(tips))
  25         tips <- which(phy$tip.label %in% tips)
  26
  27     if (reroot) {
  28         outgrp <- phy$tip.label[-tips][1]
  29         phy <- root(phy, outgroup = outgrp, resolve.root = TRUE)
  30         rerooted <- TRUE
  31     } else rerooted <- FALSE
  32
  33     phy <- reorder(phy)
  34
  35     seq.nod <- .Call("seq_root2tip", phy$edge, n, phy$Nnode, PACKAGE = "ape")
  36     sn <- seq.nod[tips]
  37     newroot <- ROOT
  38     i <- 2
  39     repeat {
  40         x <- unique(unlist(lapply(sn, "[", i)))
  41         if (length(x) != 1) break
  42         newroot <- x
  43         i <- i + 1
  44     }
  45     desc <- which(unlist(lapply(seq.nod, function(x) any(x %in% newroot))))
  46     if (plot) {
  47         zoom(phy, tips, subtree = FALSE, ...)
  48         if (rerooted)
  49             mtext("Input tree arbitrarily rerooted", side = 1, cex = 0.9)
  50     }
  51     ## assuming that both vectors are sorted:
  52     identical(tips, desc)
  53 } # end of is.monophyletic