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) add.internal(desc)
  65             else add.terminal(j)
  66             if (j != br[length(br)])  cp(",")
  67         }
  68         cp(")")
  69         if (nodelab) cp(phy$node.label[i - n])
  70         if (brl) {
  71             cp(":")
  72             cp(sprintf(f.d, phy$edge.length[which(phy$edge[, 2] == i)]))
  73         }
  74     }
  75     add.terminal <- function(i) {
  76         cp(phy$tip.label[phy$edge[i, 2]])
  77         if (brl) {
  78             cp(":")
  79             cp(sprintf(f.d, phy$edge.length[i]))
  80         }
  81     }
  82     n <- length(phy$tip.label)
  83     STRING <-
  84         if (output.tree.names) paste(tree.names, "(", sep = "") else "("
  85     br <- which(phy$edge[, 1] == n + 1)
  86     for (j in br) {
  87         desc <- phy$edge[j, 2]
  88         if (desc > n) add.internal(desc)
  89         else add.terminal(j)
  90         if (j != br[length(br)]) cp(",")
  91     }
  92     if (is.null(phy$root.edge)) {
  93         cp(")")
  94         if (nodelab) cp(phy$node.label[1])
  95         cp(";")
  96     }
  97     else {
  98         cp(")")
  99         if (nodelab) cp(phy$node.label[1])
 100         cp(":")
 101         cp(sprintf(f.d, phy$root.edge))
 102         cp(";")
 103     }
 104     if (file == "") return(STRING)
 105     cat(STRING, file = file, append = append, sep = "\n")
 106 }
 107