a collection of bug fixes

[ape.git] / R / root.R

diff --git a/R/root.R b/R/root.R
index e7c916b55e61679f5088bf892c36918d08b4e888..aadd6c15454454947c4e5fc1e2d3a3d0124ede26 100644 (file)
--- a/R/root.R
+++ b/R/root.R
@@ -1,26 +1,25 @@
-## root.R (2008-02-12)
+## root.R (2009-09-09)
 
 ##   Root of Phylogenetic Trees
 
-## Copyright 2004-2008 Emmanuel Paradis
+## Copyright 2004-2009 Emmanuel Paradis
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
 
 is.rooted <- function(phy)
 {
-    if (!"phylo" %in% class(phy))
+    if (!inherits(phy, "phylo"))
       stop('object "phy" is not of class "phylo"')
-    if (!is.null(phy$root.edge)) return(TRUE)
+    if (!is.null(phy$root.edge)) TRUE
     else
       if (tabulate(phy$edge[, 1])[length(phy$tip.label) + 1] > 2)
-        return(FALSE)
-      else return(TRUE)
+        FALSE else TRUE
 }
 
 unroot <- function(phy)
 {
-    if (class(phy) != "phylo")
+    if (!inherits(phy, "phylo"))
       stop('object "phy" is not of class "phylo"')
     if (dim(phy$edge)[1] < 3)
       stop("cannot unroot a tree with two edges.")
@@ -64,10 +63,9 @@ unroot <- function(phy)
 
 root <- function(phy, outgroup, node = NULL, resolve.root = FALSE)
 {
-    if (class(phy) != "phylo")
+    if (!inherits(phy, "phylo"))
       stop('object "phy" is not of class "phylo"')
-    ord <- attr(phy, "order")
-    if (!is.null(ord) && ord == "pruningwise") phy <- reorder(phy)
+    phy <- reorder(phy)
     n <- length(phy$tip.label)
     ROOT <- n + 1
     if (!is.null(node)) {
@@ -88,7 +86,6 @@ root <- function(phy, outgroup, node = NULL, resolve.root = FALSE)
         ## First check that the outgroup is monophyletic--
         ## unless there's only one tip specified of course
         if (length(outgroup) > 1) {
-            msg <- "the specified outgroup is not monophyletic"
             seq.nod <- .Call("seq_root2tip", phy$edge, n,
                              phy$Nnode, PACKAGE = "ape")
             sn <- seq.nod[outgroup]
@@ -108,19 +105,50 @@ root <- function(phy, outgroup, node = NULL, resolve.root = FALSE)
             ## (below is slightly faster than calling "bipartition")
             desc <- which(unlist(lapply(seq.nod,
                                         function(x) any(x %in% newroot))))
-            if (length(outgroup) != length(desc)) stop(msg)
-            ## both vectors below are already sorted:
-            if (!all(outgroup == desc)) stop(msg)
+            msg <- "the specified outgroup is not monophyletic"
+            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)
+            }
         } else newroot <- phy$edge[which(phy$edge[, 2] == outgroup), 1]
     }
-    if (newroot == ROOT) return(phy)
+    N <- Nedge(phy)
+    oldNnode <- phy$Nnode
+    if (newroot == ROOT) {
+        if (resolve.root) {
+            snw <- which(phy$edge[, 1] == newroot)
+            if (length(snw) > 2) {
+                a <- snw[1]:(snw[2] - 1)
+                b <- snw[2]:N
+                newnod <- oldNnode + n + 1
+                phy$edge[snw[-1], 1] <- newnod
+                phy$edge <- rbind(phy$edge[a, ], c(ROOT, newnod),
+                                  phy$edge[b, ])
+                if (!is.null(phy$edge.length))
+                phy$edge.length <-
+                    c(phy$edge.length[a], 0, phy$edge.length[b])
+                phy$Nnode <- phy$Nnode + 1L
+                ## node renumbering (see comments below)
+                newNb <- integer(n + oldNnode)
+                newNb[newroot] <- n + 1L
+                sndcol <- phy$edge[, 2] > n
+                phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2]] <-
+                    (n + 2):(n + phy$Nnode)
+                phy$edge[, 1] <- newNb[phy$edge[, 1]]
+            }
+        }
+        return(phy)
+    }
 
     phy$root.edge <- NULL # just in case...
     Nclade <- tabulate(phy$edge[, 1])[ROOT] # degree of the root node
     ## if only 2 edges connect to the root, we have to fuse them:
     fuseRoot <- Nclade == 2
 
-    N <- Nedge(phy)
     start <- which(phy$edge[, 1] == ROOT)
     end <- c(start[-1] - 1, N)
     o <- integer(N)
@@ -218,7 +246,6 @@ root <- function(phy, outgroup, node = NULL, resolve.root = FALSE)
     ne <- length(s)
     o[NEXT:(NEXT + ne - 1L)] <- s
 
-    oldNnode <- phy$Nnode
     if (fuseRoot) {
         phy$Nnode <- oldNnode - 1
         N <- N - 1L
@@ -270,14 +297,19 @@ root <- function(phy, outgroup, node = NULL, resolve.root = FALSE)
     phy$edge[, 1] <- newNb[phy$edge[, 1]]
 
     if (!is.null(phy$node.label)) {
+        #browser()
         newNb <- newNb[-(1:n)]
         if (fuseRoot) {
             newNb <- newNb[-1]
             phy$node.label <- phy$node.label[-1]
         }
         phy$node.label <- phy$node.label[order(newNb)]
-        if (resolve.root)
-             phy$node.label <- c(phy$node.label[1], NA, phy$node.label[-1])
+        if (resolve.root) {
+            phy$node.label[is.na(phy$node.label)] <- phy$node.label[1]
+            phy$node.label[1] <- NA
+            ##phy$node.label <- c(phy$node.label[1], NA, phy$node.label[-1])
+            ##phy$node.label <- c("NA", phy$node.label)
+        }
     }
     phy
 }