1 ## write.tree.R (2007-12-22)
3 ## Write Tree File in Parenthetic Format
5 ## Copyright 2002-2007 Emmanuel Paradis
7 ## This file is part of the R-package `ape'.
8 ## See the file ../COPYING for licensing issues.
10 checkLabel <- function(x, ...)
12 ## delete all leading and trailing spaces and tabs, and
13 ## the leading left and trailing right parentheses:
14 ## (the syntax will work with any mix of these characters,
15 ## e.g., " ( ( (( " will correctly be deleted)
16 x <- gsub("^[[:space:]\\(]+", "", x)
17 x <- gsub("[[:space:]\\)]+$", "", x)
18 ## replace all spaces and tabs by underscores:
19 x <- gsub("[[:space:]]", "_", x)
20 ## remove all commas, colons, and semicolons
21 x <- gsub("[,:;]", "", x)
22 ## replace left and right parentheses with dashes:
23 x <- gsub("[\\(\\)]", "-", x)
24 ## delete extra underscores and extra dashes:
25 x <- gsub("_{2,}", "_", x)
26 x <- gsub("-{2,}", "-", x)
30 write.tree <- function(phy, file = "", append = FALSE,
33 if (class(phy) == "multiPhylo") {
34 write.tree(phy[[1]], file = file,
35 append = append, digits = digits)
37 for (i in 2:length(phy))
38 write.tree(phy[[i]], file = file,
39 append = TRUE, digits = digits)
40 return(invisible(NULL))
43 if (class(phy) != "phylo")
44 stop('object "phy" is not of class "phylo"')
46 brl <- !is.null(phy$edge.length)
48 ### Ne serait-il pas plus efficace de créer des node labels vides
49 ### "" et d'éviter l'évaluation if (nodelab) ????
50 ### Autre possibilité : créer plusieurs variants de ces fonctions
51 ### (au moins deux avec/sans edge.length)
53 ### Encore autre chose: les appels à which ne peuvent-ils pas
54 ### être évités ??? surtout si l'arbre est en cladewise order...
56 nodelab <- !is.null(phy$node.label)
57 phy$tip.label <- checkLabel(phy$tip.label)
59 phy$node.label <- checkLabel(phy$node.label)
61 f.d <- paste("%.", digits, "g", sep = "")
63 cp <- function(s) STRING <<- paste(STRING, s, sep = "")
64 add.internal <- function(i) {
66 br <- which(phy$edge[, 1] == i)
68 desc <- phy$edge[j, 2]
69 if (desc > n) add.internal(desc) else add.terminal(j)
70 if (j != br[length(br)]) cp(",")
73 if (nodelab) cp(phy$node.label[i - n])
76 cp(sprintf(f.d, phy$edge.length[which(phy$edge[, 2] == i)]))
79 add.terminal <- function(i) {
80 cp(phy$tip.label[phy$edge[i, 2]])
83 cp(sprintf(f.d, phy$edge.length[i]))
86 n <- length(phy$tip.label)
88 br <- which(phy$edge[, 1] == n + 1)
90 desc <- phy$edge[j, 2]
91 if (desc > n) add.internal(desc) else add.terminal(j)
92 if (j != br[length(br)]) cp(",")
94 if (is.null(phy$root.edge)) {
96 if (nodelab) cp(phy$node.label[1])
100 if (nodelab) cp(phy$node.label[1])
102 cp(sprintf(f.d, phy$root.edge))
105 if (file == "") return(STRING)
106 else cat(STRING, file = file, append = append, sep = "\n")