1 ## write.tree.R (2010-12-07)
3 ## Write Tree File in Parenthetic Format
5 ## Copyright 2002-2010 Emmanuel Paradis, Daniel Lawson, and Klaus Schliep
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)
31 function(phy, file = "", append = FALSE, digits = 10, tree.names = FALSE)
33 if (!(inherits(phy, c("phylo", "multiPhylo"))))
34 stop("object \"phy\" has no trees")
36 if (inherits(phy, "phylo")) phy <- c(phy)
40 if (is.logical(tree.names)) {
43 if (is.null(names(phy))) character(N)
45 } else tree.names <- character(N)
49 res[i] <- .write.tree2(phy[[i]], digits = digits,
50 tree.prefix = tree.names[i])
52 if (file == "") return(res)
53 else cat(res, file = file, append = append, sep = "\n")
56 .write.tree2 <- function(phy, digits = 10, tree.prefix = "")
58 brl <- !is.null(phy$edge.length)
59 nodelab <- !is.null(phy$node.label)
60 phy$tip.label <- checkLabel(phy$tip.label)
61 if (nodelab) phy$node.label <- checkLabel(phy$node.label)
62 f.d <- paste("%.", digits, "g", sep = "")
67 add.internal <- function(i) {
71 if (j > n) add.internal(j)
72 else add.terminal(ind[j])
73 if (j != desc[length(desc)]) cp(",")
76 if (nodelab && i > n) cp(phy$node.label[i - n]) # fixed by Naim Matasci (2010-12-07)
79 cp(sprintf(f.d, phy$edge.length[ind[i]]))
82 add.terminal <- function(i) {
83 cp(phy$tip.label[phy$edge[i, 2]])
86 cp(sprintf(f.d, phy$edge.length[i]))
90 n <- length(phy$tip.label)
92 ## borrowed from phangorn:
93 parent <- phy$edge[, 1]
94 children <- phy$edge[, 2]
95 kids <- vector("list", n + phy$Nnode)
96 for (i in 1:length(parent))
97 kids[[parent[i]]] <- c(kids[[parent[i]]], children[i])
99 ind <- match(1:max(phy$edge), phy$edge[, 2])
102 if (brl) LS <- LS + 4*n
103 if (nodelab) LS <- LS + n
104 STRING <- character(LS)
108 getRoot <- function(phy)
109 phy$edge[, 1][!match(phy$edge[, 1], phy$edge[, 2], 0)][1]
110 root <- getRoot(phy) # replaced n+1 with root - root has not be n+1
113 if (j > n) add.internal(j)
114 else add.terminal(ind[j])
115 if (j != desc[length(desc)]) cp(",")
118 if (is.null(phy$root.edge)) {
120 if (nodelab) cp(phy$node.label[1])
125 if (nodelab) cp(phy$node.label[1])
127 cp(sprintf(f.d, phy$root.edge))
130 paste(STRING, collapse = "")