-## write.tree.R (2009-06-16)
+## write.tree.R (2010-12-07)
## Write Tree File in Parenthetic Format
-## Copyright 2002-2009 Emmanuel Paradis and Daniel Lawson
+## Copyright 2002-2010 Emmanuel Paradis, Daniel Lawson, and Klaus Schliep
## This file is part of the R-package `ape'.
## See the file ../COPYING for licensing issues.
}
write.tree <-
- function (phy, file = "", append = FALSE, digits = 10, tree.names = FALSE)
+ function(phy, file = "", append = FALSE, digits = 10, tree.names = FALSE)
{
- output.tree.names <- FALSE
+ if (!(inherits(phy, c("phylo", "multiPhylo"))))
+ stop("object \"phy\" has no trees")
+
+ if (inherits(phy, "phylo")) phy <- c(phy)
+ N <- length(phy)
+ res <- character(N)
+
if (is.logical(tree.names)) {
- output.tree.names <- tree.names
- tree.names <- NULL
- } else if (is.character(tree.names)) {
- output.tree.names <- TRUE
- names(phy) <- tree.names
+ if (tree.names) {
+ tree.names <-
+ if (is.null(names(phy))) character(N)
+ else names(phy)
+ } else tree.names <- character(N)
}
- if (output.tree.names)
- names(phy) <- checkLabel(names(phy))
- if (inherits(phy, "multiPhylo")) {
- write.tree(phy[[1]], file = file, append = append,
- digits = digits, tree.names = names(phy)[1])
- if (length(phy) > 1)
- for (i in 2:length(phy)) write.tree(phy[[i]], file = file,
- append = TRUE, digits = digits, tree.names = names(phy)[i])
- return(invisible(NULL))
- }
- if (!inherits(phy, "phylo"))
- stop("object \"phy\" is not of class \"phylo\"")
+
+ for (i in 1:N)
+ res[i] <- .write.tree2(phy[[i]], digits = digits,
+ tree.prefix = tree.names[i])
+
+ if (file == "") return(res)
+ else cat(res, file = file, append = append, sep = "\n")
+}
+
+.write.tree2 <- function(phy, digits = 10, tree.prefix = "")
+{
brl <- !is.null(phy$edge.length)
nodelab <- !is.null(phy$node.label)
phy$tip.label <- checkLabel(phy$tip.label)
if (nodelab) phy$node.label <- checkLabel(phy$node.label)
f.d <- paste("%.", digits, "g", sep = "")
- cp <- function(s) STRING <<- paste(STRING, s, sep = "")
+ cp <- function(x){
+ STRING[k] <<- x
+ k <<- k + 1
+ }
add.internal <- function(i) {
cp("(")
- br <- which(phy$edge[, 1] == i)
- for (j in br) {
- desc <- phy$edge[j, 2]
- if (desc > n) add.internal(desc)
- else add.terminal(j)
- if (j != br[length(br)]) cp(",")
+ desc <- kids[[i]]
+ for (j in desc) {
+ if (j > n) add.internal(j)
+ else add.terminal(ind[j])
+ if (j != desc[length(desc)]) cp(",")
}
cp(")")
- if (nodelab) cp(phy$node.label[i - n])
+ if (nodelab && i > n) cp(phy$node.label[i - n]) # fixed by Naim Matasci (2010-12-07)
if (brl) {
cp(":")
- cp(sprintf(f.d, phy$edge.length[which(phy$edge[, 2] == i)]))
+ cp(sprintf(f.d, phy$edge.length[ind[i]]))
}
}
add.terminal <- function(i) {
cp(sprintf(f.d, phy$edge.length[i]))
}
}
+
n <- length(phy$tip.label)
- STRING <-
- if (output.tree.names) paste(tree.names, "(", sep = "") else "("
- br <- which(phy$edge[, 1] == n + 1)
- for (j in br) {
- desc <- phy$edge[j, 2]
- if (desc > n) add.internal(desc)
- else add.terminal(j)
- if (j != br[length(br)]) cp(",")
+
+ ## borrowed from phangorn:
+ parent <- phy$edge[, 1]
+ children <- phy$edge[, 2]
+ kids <- vector("list", n + phy$Nnode)
+ for (i in 1:length(parent))
+ kids[[parent[i]]] <- c(kids[[parent[i]]], children[i])
+
+ ind <- match(1:max(phy$edge), phy$edge[, 2])
+
+ LS <- 4*n + 5
+ if (brl) LS <- LS + 4*n
+ if (nodelab) LS <- LS + n
+ STRING <- character(LS)
+ k <- 1
+ cp(tree.prefix)
+ cp("(")
+ getRoot <- function(phy)
+ phy$edge[, 1][!match(phy$edge[, 1], phy$edge[, 2], 0)][1]
+ root <- getRoot(phy) # replaced n+1 with root - root has not be n+1
+ desc <- kids[[root]]
+ for (j in desc) {
+ if (j > n) add.internal(j)
+ else add.terminal(ind[j])
+ if (j != desc[length(desc)]) cp(",")
}
+
if (is.null(phy$root.edge)) {
cp(")")
if (nodelab) cp(phy$node.label[1])
cp(sprintf(f.d, phy$root.edge))
cp(";")
}
- if (file == "") return(STRING)
- cat(STRING, file = file, append = append, sep = "\n")
+ paste(STRING, collapse = "")
}
-