R/write.tree.R

   1 ## write.tree.R (2009-06-16)
   2
   3 ##   Write Tree File in Parenthetic Format
   4
   5 ## Copyright 2002-2009 Emmanuel Paradis and Daniel Lawson
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 checkLabel <- function(x, ...)
  11 {
  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)
  27     x
  28 }
  29
  30 write.tree <-
  31     function (phy, file = "", append = FALSE, digits = 10, tree.names = FALSE)
  32 {
  33     output.tree.names <- FALSE
  34     if (is.logical(tree.names)) {
  35         output.tree.names <- tree.names
  36         tree.names <- NULL
  37     } else if (is.character(tree.names)) {
  38         output.tree.names <- TRUE
  39         names(phy) <- tree.names
  40     }
  41     if (output.tree.names)
  42         names(phy) <- checkLabel(names(phy))
  43     if (inherits(phy, "multiPhylo")) {
  44         write.tree(phy[[1]], file = file, append = append,
  45                    digits = digits, tree.names = names(phy)[1])
  46         if (length(phy) > 1)
  47             for (i in 2:length(phy)) write.tree(phy[[i]], file = file,
  48                 append = TRUE, digits = digits, tree.names = names(phy)[i])
  49         return(invisible(NULL))
  50     }
  51     if (!inherits(phy, "phylo"))
  52         stop("object \"phy\" is not of class \"phylo\"")
  53     brl <- !is.null(phy$edge.length)
  54     nodelab <- !is.null(phy$node.label)
  55     phy$tip.label <- checkLabel(phy$tip.label)
  56     if (nodelab) phy$node.label <- checkLabel(phy$node.label)
  57     f.d <- paste("%.", digits, "g", sep = "")
  58     cp <- function(s) STRING <<- paste(STRING, s, sep = "")
  59     add.internal <- function(i) {
  60         cp("(")
  61         br <- which(phy$edge[, 1] == i)
  62         for (j in br) {
  63             desc <- phy$edge[j, 2]
  64             if (desc > n)
  65                 add.internal(desc)
  66             else add.terminal(j)
  67             if (j != br[length(br)])
  68                 cp(",")
  69         }
  70         cp(")")
  71         if (nodelab)
  72             cp(phy$node.label[i - n])
  73         if (brl) {
  74             cp(":")
  75             cp(sprintf(f.d, phy$edge.length[which(phy$edge[,
  76                 2] == i)]))
  77         }
  78     }
  79     add.terminal <- function(i) {
  80         cp(phy$tip.label[phy$edge[i, 2]])
  81         if (brl) {
  82             cp(":")
  83             cp(sprintf(f.d, phy$edge.length[i]))
  84         }
  85     }
  86     n <- length(phy$tip.label)
  87     STRING <-
  88         if (output.tree.names) paste(tree.names, "(", sep = "") else "("
  89     br <- which(phy$edge[, 1] == n + 1)
  90     for (j in br) {
  91         desc <- phy$edge[j, 2]
  92         if (desc > n)
  93             add.internal(desc)
  94         else add.terminal(j)
  95         if (j != br[length(br)])
  96             cp(",")
  97     }
  98     if (is.null(phy$root.edge)) {
  99         cp(")")
 100         if (nodelab)
 101             cp(phy$node.label[1])
 102         cp(";")
 103     }
 104     else {
 105         cp(")")
 106         if (nodelab)
 107             cp(phy$node.label[1])
 108         cp(":")
 109         cp(sprintf(f.d, phy$root.edge))
 110         cp(";")
 111     }
 112     if (file == "")
 113         return(STRING)
 114     else cat(STRING, file = file, append = append, sep = "\n")
 115 }
 116