fix rTraitDisc

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

diff --git a/R/write.tree.R b/R/write.tree.R
index e4614d8e0a97973637c53b280238046c1ba24166..996b9aa4f2b9488a87294c735839bce04322dd95 100644 (file)
--- a/R/write.tree.R
+++ b/R/write.tree.R
@@ -1,8 +1,8 @@
-## write.tree.R (2007-12-22)
+## write.tree.R (2009-06-16)
 
 ##   Write Tree File in Parenthetic Format
 
-## Copyright 2002-2007 Emmanuel Paradis
+## Copyright 2002-2009 Emmanuel Paradis and Daniel Lawson
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
@@ -27,53 +27,53 @@ checkLabel <- function(x, ...)
     x
 }
 
-write.tree <- function(phy, file = "", append = FALSE,
-                       digits = 10)
+write.tree <-
+    function (phy, file = "", append = FALSE, digits = 10, tree.names = FALSE)
 {
-    if (class(phy) == "multiPhylo") {
-        write.tree(phy[[1]], file = file,
-                   append = append, digits = digits)
+    output.tree.names <- FALSE
+    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 (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)
+            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 (class(phy) != "phylo")
-      stop('object "phy" is not of class "phylo"')
-
+    if (!inherits(phy, "phylo"))
+        stop("object \"phy\" is not of class \"phylo\"")
     brl <- !is.null(phy$edge.length)
-
-### Ne serait-il pas plus efficace de créer des node labels vides
-### "" et d'éviter l'évaluation if (nodelab) ????
-### Autre possibilité : créer plusieurs variants de ces fonctions
-### (au moins deux avec/sans edge.length)
-
-### Encore autre chose: les appels à which ne peuvent-ils pas
-### être évités ??? surtout si l'arbre est en cladewise order...
-
     nodelab <- !is.null(phy$node.label)
     phy$tip.label <- checkLabel(phy$tip.label)
-    if (nodelab)
-      phy$node.label <- checkLabel(phy$node.label)
-
+    if (nodelab) phy$node.label <- checkLabel(phy$node.label)
     f.d <- paste("%.", digits, "g", sep = "")
-
     cp <- function(s) STRING <<- paste(STRING, s, sep = "")
     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(",")
+            if (desc > n)
+                add.internal(desc)
+            else add.terminal(j)
+            if (j != br[length(br)])
+                cp(",")
         }
         cp(")")
-        if (nodelab) cp(phy$node.label[i - n])
+        if (nodelab)
+            cp(phy$node.label[i - n])
         if (brl) {
             cp(":")
-            cp(sprintf(f.d, phy$edge.length[which(phy$edge[, 2] == i)]))
+            cp(sprintf(f.d, phy$edge.length[which(phy$edge[,
+                2] == i)]))
         }
     }
     add.terminal <- function(i) {
@@ -84,24 +84,33 @@ write.tree <- function(phy, file = "", append = FALSE,
         }
     }
     n <- length(phy$tip.label)
-    STRING <- "("
+    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(",")
+        if (desc > n)
+            add.internal(desc)
+        else add.terminal(j)
+        if (j != br[length(br)])
+            cp(",")
     }
     if (is.null(phy$root.edge)) {
         cp(")")
-        if (nodelab) cp(phy$node.label[1])
+        if (nodelab)
+            cp(phy$node.label[1])
         cp(";")
-    } else {
+    }
+    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)
+    if (file == "")
+        return(STRING)
     else cat(STRING, file = file, append = append, sep = "\n")
 }
+