fixes in mantel.test() and extract.clade()

[ape.git] / R / write.tree.R

diff --git a/R/write.tree.R b/R/write.tree.R
index 996b9aa4f2b9488a87294c735839bce04322dd95..08de505eaf78f90db4a2000a94d7dd733b3eaa9e 100644 (file)
--- a/R/write.tree.R
+++ b/R/write.tree.R
@@ -1,8 +1,8 @@
-## 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.
@@ -28,52 +28,55 @@ checkLabel <- function(x, ...)
 }
 
 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) {
@@ -83,34 +86,46 @@ write.tree <-
             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])
+        if (nodelab) cp(phy$node.label[1])
         cp(";")
     }
     else {
         cp(")")
-        if (nodelab)
-            cp(phy$node.label[1])
+        if (nodelab) cp(phy$node.label[1])
         cp(":")
         cp(sprintf(f.d, phy$root.edge))
         cp(";")
     }
-    if (file == "")
-        return(STRING)
-    else cat(STRING, file = file, append = append, sep = "\n")
+    paste(STRING, collapse = "")
 }
-