R/write.tree.R

   1 ## write.tree.R (2010-09-27)
   2
   3 ##   Write Tree File in Parenthetic Format
   4
   5 ## Copyright 2002-2010 Emmanuel Paradis, Daniel Lawson, and Klaus Schliep
   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(x){
  59         STRING[k] <<- x
  60         k <<- k + 1
  61     }
  62     add.internal <- function(i) {
  63         cp("(")
  64         desc <- kids[[i]]
  65         for (j in desc) {
  66             if (j > n) add.internal(j)
  67             else add.terminal(ind[j])
  68             if (j != desc[length(desc)]) cp(",")
  69         }
  70         cp(")")
  71         if (nodelab) cp(phy$node.label[ind[i] - n])
  72         if (brl) {
  73             cp(":")
  74             cp(sprintf(f.d, phy$edge.length[ind[i]]))
  75         }
  76     }
  77     add.terminal <- function(i) {
  78         cp(phy$tip.label[phy$edge[i, 2]])
  79         if (brl) {
  80             cp(":")
  81             cp(sprintf(f.d, phy$edge.length[i]))
  82         }
  83     }
  84
  85     n <- length(phy$tip.label)
  86
  87     ## borrowed from phangorn:
  88     parent <- phy$edge[, 1]
  89     children <- phy$edge[, 2]
  90     kids <- vector("list", n + phy$Nnode)
  91     for (i in 1:length(parent))
  92         kids[[parent[i]]] <- c(kids[[parent[i]]], children[i])
  93
  94     ind <- match(1:max(phy$edge), phy$edge[, 2])
  95
  96     LS <- 4*n + 5
  97     if (brl) LS <- LS + 4*n
  98     if (nodelab)  LS <- LS + n
  99     STRING <- character(LS)
 100     k <- 1
 101     if (output.tree.names) cp(tree.names)
 102     cp("(")
 103     k <- 2
 104     getRoot <- function(phy)
 105         phy$edge[, 1][!match(phy$edge[, 1], phy$edge[, 2], 0)][1]
 106     root <- getRoot(phy) # replaced n+1 with root - root has not be n+1
 107     desc <- kids[[root]]
 108     for (j in desc) {
 109         if (j > n) add.internal(j)
 110         else add.terminal(ind[j])
 111         if (j != desc[length(desc)]) cp(",")
 112     }
 113
 114     if (is.null(phy$root.edge)) {
 115         cp(")")
 116         if (nodelab) cp(phy$node.label[1])
 117         cp(";")
 118     }
 119     else {
 120         cp(")")
 121         if (nodelab) cp(phy$node.label[1])
 122         cp(":")
 123         cp(sprintf(f.d, phy$root.edge))
 124         cp(";")
 125     }
 126     STRING <- paste(STRING, collapse = "")
 127     if (file == "")
 128         return(STRING)
 129     else cat(STRING, file = file, append = append, sep = "\n")
 130 }