R/write.tree.R

   1 ## write.tree.R (2009-05-10)
   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     if (is.logical(tree.names)) {
  34         output.tree.names <- tree.names
  35         tree.names <- NULL
  36     } else if (is.character(tree.names)) {
  37         output.tree.names <- TRUE
  38         names(tree) <- tree.names
  39     }
  40     if (output.tree.names)
  41         names(tree) <- checkLabel(names(tree))
  42     if (inherits(phy, "multiPhylo")) {
  43         write.tree(phy[[1]], file = file, append = append,
  44                    digits = digits, tree.names = names[1])
  45         if (length(phy) > 1)
  46             for (i in 2:length(phy)) write.tree(phy[[i]], file = file,
  47                 append = TRUE, digits = digits, tree.names = names(phy)[i])
  48         return(invisible(NULL))
  49     }
  50     if (!inherits(phy, "phylo"))
  51         stop("object \"phy\" is not of class \"phylo\"")
  52     brl <- !is.null(phy$edge.length)
  53     nodelab <- !is.null(phy$node.label)
  54     phy$tip.label <- checkLabel(phy$tip.label)
  55     if (nodelab) phy$node.label <- checkLabel(phy$node.label)
  56     f.d <- paste("%.", digits, "g", sep = "")
  57     cp <- function(s) STRING <<- paste(STRING, s, sep = "")
  58     add.internal <- function(i) {
  59         cp("(")
  60         br <- which(phy$edge[, 1] == i)
  61         for (j in br) {
  62             desc <- phy$edge[j, 2]
  63             if (desc > n)
  64                 add.internal(desc)
  65             else add.terminal(j)
  66             if (j != br[length(br)])
  67                 cp(",")
  68         }
  69         cp(")")
  70         if (nodelab)
  71             cp(phy$node.label[i - n])
  72         if (brl) {
  73             cp(":")
  74             cp(sprintf(f.d, phy$edge.length[which(phy$edge[,
  75                 2] == i)]))
  76         }
  77     }
  78     add.terminal <- function(i) {
  79         cp(phy$tip.label[phy$edge[i, 2]])
  80         if (brl) {
  81             cp(":")
  82             cp(sprintf(f.d, phy$edge.length[i]))
  83         }
  84     }
  85     n <- length(phy$tip.label)
  86     STRING <-
  87         if (output.tree.names) paste(tree.names, "(", sep = "") else "("
  88     br <- which(phy$edge[, 1] == n + 1)
  89     for (j in br) {
  90         desc <- phy$edge[j, 2]
  91         if (desc > n)
  92             add.internal(desc)
  93         else add.terminal(j)
  94         if (j != br[length(br)])
  95             cp(",")
  96     }
  97     if (is.null(phy$root.edge)) {
  98         cp(")")
  99         if (nodelab)
 100             cp(phy$node.label[1])
 101         cp(";")
 102     }
 103     else {
 104         cp(")")
 105         if (nodelab)
 106             cp(phy$node.label[1])
 107         cp(":")
 108         cp(sprintf(f.d, phy$root.edge))
 109         cp(";")
 110     }
 111     if (file == "")
 112         return(STRING)
 113     else cat(STRING, file = file, append = append, sep = "\n")
 114 }
 115