X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=R%2Froot.R;h=ac5ec27b5b45d27470b8ca322adc787e86dc6193;hb=a03a8c554a6fde0dc4313688e3248bfae2e521e4;hp=832ab0f544ba0ef235870701ceb12798552b6b3c;hpb=4ceef408de61dc86f0a93b0396aecc6e30cc0d70;p=ape.git

diff --git a/R/root.R b/R/root.R
index 832ab0f..ac5ec27 100644
--- a/R/root.R
+++ b/R/root.R
@@ -1,8 +1,8 @@
-## root.R (2009-05-10)
+## root.R (2010-02-11)
 
 ##   Root of Phylogenetic Trees
 
-## Copyright 2004-2009 Emmanuel Paradis
+## Copyright 2004-2010 Emmanuel Paradis
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
@@ -10,20 +10,19 @@
 is.rooted <- function(phy)
 {
     if (!inherits(phy, "phylo"))
-      stop('object "phy" is not of class "phylo"')
-    if (!is.null(phy$root.edge)) return(TRUE)
+        stop('object "phy" is not of class "phylo"')
+    if (!is.null(phy$root.edge)) TRUE
     else
-      if (tabulate(phy$edge[, 1])[length(phy$tip.label) + 1] > 2)
-        return(FALSE)
-      else return(TRUE)
+        if (tabulate(phy$edge[, 1])[length(phy$tip.label) + 1] > 2)
+            FALSE else TRUE
 }
 
 unroot <- function(phy)
 {
     if (!inherits(phy, "phylo"))
-      stop('object "phy" is not of class "phylo"')
+        stop('object "phy" is not of class "phylo"')
     if (dim(phy$edge)[1] < 3)
-      stop("cannot unroot a tree with two edges.")
+        stop("cannot unroot a tree with less than three edges.")
     ## delete FIRST the root.edge (in case this is sufficient to
     ## unroot the tree, i.e. there is a multichotomy at the root)
     if (!is.null(phy$root.edge)) phy$root.edge <- NULL
@@ -36,11 +35,11 @@ unroot <- function(phy)
     ## nodes by adding 1, except the root (this remains the
     ## origin of the tree).
     nb.tip <- length(phy$tip.label)
-    ROOT <- nb.tip + 1
+    ROOT <- nb.tip + 1L
     EDGEROOT <- which(phy$edge[, 1] == ROOT)
     ## j: the target where to stick the edge
     ## i: the edge to delete
-    if (phy$edge[EDGEROOT[1], 2] == ROOT + 1) {
+    if (phy$edge[EDGEROOT[1], 2] == ROOT + 1L) {
         j <- EDGEROOT[2]
         i <- EDGEROOT[1]
     } else {
@@ -51,25 +50,29 @@ unroot <- function(phy)
     ## cladewise order.
     phy$edge <- phy$edge[-i, ]
     nodes <- phy$edge > ROOT # renumber all nodes except the root
-    phy$edge[nodes] <- phy$edge[nodes] - 1
+    phy$edge[nodes] <- phy$edge[nodes] - 1L
     if (!is.null(phy$edge.length)) {
         phy$edge.length[j] <- phy$edge.length[j] + phy$edge.length[i]
         phy$edge.length <- phy$edge.length[-i]
     }
-    phy$Nnode <- phy$Nnode - 1
+    phy$Nnode <- phy$Nnode - 1L
     if (!is.null(phy$node.label))
       phy$node.label <- phy$node.label[-2]
     phy
 }
 
-root <- function(phy, outgroup, node = NULL, resolve.root = FALSE)
+root <- function(phy, outgroup, node = NULL,
+                 resolve.root = FALSE, interactive = FALSE)
 {
     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)
+        stop('object "phy" is not of class "phylo"')
+    phy <- reorder(phy)
     n <- length(phy$tip.label)
-    ROOT <- n + 1
+    ROOT <- n + 1L
+    if (interactive) {
+        node <- identify(phy)$nodes
+        cat("You have set resolve.root =", resolve.root, "\n")
+    }
     if (!is.null(node)) {
         if (node <= n)
             stop("incorrect node#: should be greater than the number of taxa")
@@ -88,7 +91,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,9 +110,15 @@ 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]
     }
     N <- Nedge(phy)
@@ -128,7 +136,7 @@ root <- function(phy, outgroup, node = NULL, resolve.root = FALSE)
                 if (!is.null(phy$edge.length))
                 phy$edge.length <-
                     c(phy$edge.length[a], 0, phy$edge.length[b])
-                phy$Nnode <- phy$Nnode + 1
+                phy$Nnode <- phy$Nnode + 1L
                 ## node renumbering (see comments below)
                 newNb <- integer(n + oldNnode)
                 newNb[newroot] <- n + 1L
@@ -294,14 +302,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
 }