a fix in cophyloplot()

[ape.git] / R / root.R

diff --git a/R/root.R b/R/root.R
index ac5ec27b5b45d27470b8ca322adc787e86dc6193..8c1d9b26f9ebbfa49dc49f7826b910f262c07c47 100644 (file)
--- a/R/root.R
+++ b/R/root.R
@@ -1,8 +1,8 @@
-## root.R (2010-02-11)
+## root.R (2011-08-05)
 
 ##   Root of Phylogenetic Trees
 
-## Copyright 2004-2010 Emmanuel Paradis
+## Copyright 2004-2011 Emmanuel Paradis
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
@@ -31,7 +31,7 @@ unroot <- function(phy)
     ## eventually adding the branch length to the other one
     ## also coming from the root.
     ## In all cases, the node deleted is the 2nd one (numbered
-    ## nb.tip+2 in `edge'), so we simply need to renumber the
+    ## nb.tip+2 in 'edge'), so we simply need to renumber the
     ## nodes by adding 1, except the root (this remains the
     ## origin of the tree).
     nb.tip <- length(phy$tip.label)
@@ -57,7 +57,7 @@ unroot <- function(phy)
     }
     phy$Nnode <- phy$Nnode - 1L
     if (!is.null(phy$node.label))
-      phy$node.label <- phy$node.label[-2]
+        phy$node.label <- phy$node.label[-2]
     phy
 }
 
@@ -91,34 +91,21 @@ root <- function(phy, outgroup, node = NULL,
         ## First check that the outgroup is monophyletic--
         ## unless there's only one tip specified of course
         if (length(outgroup) > 1) {
-            seq.nod <- .Call("seq_root2tip", phy$edge, n,
-                             phy$Nnode, PACKAGE = "ape")
-            sn <- seq.nod[outgroup]
-            ## We go from the root to the tips: the sequence of nodes
-            ## is identical until the MRCA:
-            newroot <- ROOT
-            i <- 2 # we start at the 2nd position since the root
-                   # of the tree is a common ancestor to all tips
-            repeat {
-                x <- unique(unlist(lapply(sn, "[", i)))
-                if (length(x) != 1) break
-                newroot <- x
-                i <- i + 1
-            }
-            ## Check that all descendants of this node
-            ## are included in the outgroup.
-            ## (below is slightly faster than calling "bipartition")
-            desc <- which(unlist(lapply(seq.nod,
-                                        function(x) any(x %in% newroot))))
-            msg <- "the specified outgroup is not monophyletic"
+            pp <- prop.part(phy)
             ingroup <- (1:n)[-outgroup]
-            ## 'outgroup' and 'desc' are already sorted:
-            if (newroot != ROOT) {
-                if (!identical(outgroup, desc) && !identical(ingroup, desc))
-                    stop(msg)
-            } else { # otherwise check monophyly of the ingroup
-                if (!is.monophyletic(phy, ingroup)) stop(msg)
+            newroot <- 0L
+            for (i in 2:phy$Nnode) {
+                if (identical(pp[[i]], ingroup)) {
+                    newroot <- i + n
+                    break
+                }
+                if (identical(pp[[i]], outgroup)) {
+                    newroot <- phy$edge[which(phy$edge[, 2] == i + n), 1]
+                    break
+                }
             }
+            if (!newroot)
+                stop("the specified outgroup is not monophyletic")
         } else newroot <- phy$edge[which(phy$edge[, 2] == outgroup), 1]
     }
     N <- Nedge(phy)
@@ -252,7 +239,7 @@ root <- function(phy, outgroup, node = NULL,
     o[NEXT:(NEXT + ne - 1L)] <- s
 
     if (fuseRoot) {
-        phy$Nnode <- oldNnode - 1
+        phy$Nnode <- oldNnode - 1L
         N <- N - 1L
     }
     phy$edge[INV, ] <- phy$edge[INV, 2:1]
@@ -288,7 +275,7 @@ root <- function(phy, outgroup, node = NULL,
             }
         }
         ## N <- N + 1L ... not needed
-        phy$Nnode <- phy$Nnode + 1
+        phy$Nnode <- phy$Nnode + 1L
     }
 
     ## The block below renumbers the nodes so that they conform