final commit for ape 3.0-8

[ape.git] / R / dist.topo.R

diff --git a/R/dist.topo.R b/R/dist.topo.R
index d4791c333089bf5cd9a64a846e070a3d40e35a0d..fa7edf80d71b49d0c0422740fde374ea280c7a4e 100644 (file)
--- a/R/dist.topo.R
+++ b/R/dist.topo.R
@@ -1,9 +1,9 @@
-## dist.topo.R (2012-02-03)
+## dist.topo.R (2013-02-09)
 
 ##      Topological Distances, Tree Bipartitions,
 ##   Consensus Trees, and Bootstrapping Phylogenies
 
-## Copyright 2005-2012 Emmanuel Paradis
+## Copyright 2005-2013 Emmanuel Paradis
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
@@ -68,32 +68,29 @@ dist.topo <- function(x, y, method = "PH85")
     ## 'x' is a list of objects of class "phylo" possibly with no class
     if (!is.null(attr(x, "TipLabel"))) return(x)
     ref <- x[[1]]$tip.label
-    if (any(table(ref) != 1))
-        stop("some tip labels are duplicated in tree no. 1")
     n <- length(ref)
-    Ntree <- length(x)
-    if (Ntree > 1) {
-        for (i in 2:Ntree) {
-            label <- x[[i]]$tip.label
-            if (!identical(label, ref)) {
-                if (length(label) != length(ref))
-                    stop(paste("tree no.", i, "has a different number of tips"))
-                ilab <- match(label, ref)
-                ## can use tabulate here because 'ilab' contains integers
-                if (any(is.na(ilab)))
-                    stop(paste("tree no.", i, "has different tip labels"))
-### <FIXME> the test below does not seem useful anymore
-###            if (any(tabulate(ilab) > 1))
-###                stop(paste("some tip labels are duplicated in tree no.", i))
-### </FIXME>
-                ie <- match(1:n, x[[i]]$edge[, 2])
-                x[[i]]$edge[ie, 2] <- ilab
-            }
-            x[[i]]$tip.label <- NULL
+    if (length(unique(ref)) != n)
+        stop("some tip labels are duplicated in tree no. 1")
+
+    ## serious improvement by Joseph W. Brown!
+    relabel <- function (y) {
+        label <- y$tip.label
+        if (!identical(label, ref)) {
+            if (length(label) != length(ref))
+                stop(paste("tree ", y, "has a different number of tips"))
+            ilab <- match(label, ref)
+            if (any(is.na(ilab)))
+                stop(paste("tree ", y, "has different tip labels"))
+            ie <- match(1:n, y$edge[, 2])
+            y$edge[ie, 2] <- ilab
         }
+        y$tip.label <- NULL
+        y
     }
-    x[[1]]$tip.label <- NULL
+    x <- unclass(x) # another killer improvement by Tucson's hackathon (1/2/2013)
+    x <- lapply(x, relabel)
     attr(x, "TipLabel") <- ref
+    class(x) <- "multiPhylo"
     x
 }
 
@@ -169,8 +166,20 @@ prop.clades <- function(phy, ..., part = NULL, rooted = FALSE)
         part <- prop.part(obj, check.labels = TRUE)
     }
 
+    ## until ape 3.0-7 it was assumed implicitly that the labels in phy
+    ## are in the same order than in 'part' (bug report by Rupert Collins)
+    if (!identical(phy$tip.label, attr(part, "labels"))) {
+        i <- match(phy$tip.label, attr(part, "labels"))
+        j <- match(seq_len(Ntip(phy)), phy$edge[, 2])
+        phy$edge[j, 2] <- i
+        phy$tip.label <- attr(part, "labels")
+    }
     bp <- prop.part(phy)
-    if (!rooted) bp <- postprocess.prop.part(bp)
+    if (!rooted) {
+        bp <- postprocess.prop.part(bp)
+        part <- postprocess.prop.part(part) # fix by Klaus Schliep
+        ## actually the above line in not needed if called from boot.phylo()
+    }
 
     n <- numeric(phy$Nnode)
     for (i in seq_along(bp)) {
@@ -202,7 +211,8 @@ boot.phylo <- function(phy, x, FUN, B = 100, block = 1,
         }
     }
     boot.tree <- vector("list", B)
-    if (!quiet) progbar <- utils::txtProgressBar(style = 3) # suggestion by Alastair Potts
+    if (!quiet) # suggestion by Alastair Potts
+        progbar <- utils::txtProgressBar(style = 3)
     for (i in 1:B) {
         if (block > 1) {
             y <- seq(block, ncol(x), block)