-## dist.topo.R (2008-05-07)
+## dist.topo.R (2009-07-06)
## Topological Distances, Tree Bipartitions,
## Consensus Trees, and Bootstrapping Phylogenies
-## Copyright 2005-2008 Emmanuel Paradis
+## Copyright 2005-2009 Emmanuel Paradis
## This file is part of the R-package `ape'.
## See the file ../COPYING for licensing issues.
dist.topo <- function(x, y, method = "PH85")
{
if (method == "BHV01" && (is.null(x$edge.length) || is.null(y$edge.length)))
- stop("trees must have branch lengths for Billera et al.'s distance.")
+ stop("trees must have branch lengths for Billera et al.'s distance.")
n <- length(x$tip.label)
bp1 <- .Call("bipartition", x$edge, n, x$Nnode, PACKAGE = "ape")
bp1 <- lapply(bp1, function(xx) sort(x$tip.label[xx]))
- bp2 <- .Call("bipartition", y$edge, n, y$Nnode, PACKAGE = "ape")
- bp2 <- lapply(bp2, function(xx) sort(y$tip.label[xx]))
+ ## fix by Tim Wallstrom:
+ bp2.tmp <- .Call("bipartition", y$edge, n, y$Nnode, PACKAGE = "ape")
+ bp2 <- lapply(bp2.tmp, function(xx) sort(y$tip.label[xx]))
+ bp2.comp <- lapply(bp2.tmp, function(xx) setdiff(1:n, xx))
+ bp2.comp <- lapply(bp2.comp, function(xx) sort(y$tip.label[xx]))
+ ## End
q1 <- length(bp1)
q2 <- length(bp2)
if (method == "PH85") {
p <- 0
for (i in 1:q1) {
for (j in 1:q2) {
- if (identical(all.equal(bp1[[i]], bp2[[j]]), TRUE)) {
+ if (identical(bp1[[i]], bp2[[j]]) |
+ identical(bp1[[i]], bp2.comp[[j]])) {
p <- p + 1
break
}
}
}
- dT <- if (q1 == q2) 2*(q1 - p) else 2*(min(q1, q2) - p) + abs(q1 - q2)
+ dT <- q1 + q2 - 2 * p # same than:
+ ##dT <- if (q1 == q2) 2*(q1 - p) else 2*(min(q1, q2) - p) + abs(q1 - q2)
}
if (method == "BHV01") {
dT <- 0
x
}
-prop.part <- function(..., check.labels = FALSE)
+prop.part <- function(..., check.labels = TRUE)
{
obj <- list(...)
if (length(obj) == 1 && class(obj[[1]]) != "phylo")
## class(obj) <- NULL # needed?
## </FIXME>
ntree <- length(obj)
+ if (ntree == 1) check.labels <- FALSE
if (check.labels) obj <- .compressTipLabel(obj)
for (i in 1:ntree) storage.mode(obj[[i]]$Nnode) <- "integer"
## <FIXME>
boot.phylo <- function(phy, x, FUN, B = 100, block = 1, trees = FALSE)
{
- if (is.list(x)) {
- if (class(x) == "DNAbin") x <- as.matrix(x)
+ if (is.list(x) && !is.data.frame(x)) {
+ if (inherits(x, "DNAbin")) x <- as.matrix(x)
else {
nm <- names(x)
n <- length(x)
ans
}
-consensus <- function(..., p = 1, check.labels = FALSE)
+consensus <- function(..., p = 1, check.labels = TRUE)
{
foo <- function(ic, node) {
## ic: index of 'pp'