R/write.tree.R

   1 ## write.tree.R (2010-12-07)
   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     if (!(inherits(phy, c("phylo", "multiPhylo"))))
  34         stop("object \"phy\" has no trees")
  35
  36     if (inherits(phy, "phylo")) phy <- c(phy)
  37     N <- length(phy)
  38     res <- character(N)
  39
  40     if (is.logical(tree.names)) {
  41         if (tree.names) {
  42             tree.names <-
  43                 if (is.null(names(phy))) character(N)
  44                 else names(phy)
  45         } else tree.names <- character(N)
  46     }
  47
  48     for (i in 1:N)
  49         res[i] <- .write.tree2(phy[[i]], digits = digits,
  50                                tree.prefix = tree.names[i])
  51
  52     if (file == "") return(res)
  53     else cat(res, file = file, append = append, sep = "\n")
  54 }
  55
  56 .write.tree2 <- function(phy, digits = 10, tree.prefix = "")
  57 {
  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 = "")
  63     cp <- function(x){
  64         STRING[k] <<- x
  65         k <<- k + 1
  66     }
  67     add.internal <- function(i) {
  68         cp("(")
  69         desc <- kids[[i]]
  70         for (j in desc) {
  71             if (j > n) add.internal(j)
  72             else add.terminal(ind[j])
  73             if (j != desc[length(desc)]) cp(",")
  74         }
  75         cp(")")
  76         if (nodelab && i > n) cp(phy$node.label[i - n]) # fixed by Naim Matasci (2010-12-07)
  77         if (brl) {
  78             cp(":")
  79             cp(sprintf(f.d, phy$edge.length[ind[i]]))
  80         }
  81     }
  82     add.terminal <- function(i) {
  83         cp(phy$tip.label[phy$edge[i, 2]])
  84         if (brl) {
  85             cp(":")
  86             cp(sprintf(f.d, phy$edge.length[i]))
  87         }
  88     }
  89
  90     n <- length(phy$tip.label)
  91
  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])
  98
  99     ind <- match(1:max(phy$edge), phy$edge[, 2])
 100
 101     LS <- 4*n + 5
 102     if (brl) LS <- LS + 4*n
 103     if (nodelab)  LS <- LS + n
 104     STRING <- character(LS)
 105     k <- 1
 106     cp(tree.prefix)
 107     cp("(")
 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
 111     desc <- kids[[root]]
 112     for (j in desc) {
 113         if (j > n) add.internal(j)
 114         else add.terminal(ind[j])
 115         if (j != desc[length(desc)]) cp(",")
 116     }
 117
 118     if (is.null(phy$root.edge)) {
 119         cp(")")
 120         if (nodelab) cp(phy$node.label[1])
 121         cp(";")
 122     }
 123     else {
 124         cp(")")
 125         if (nodelab) cp(phy$node.label[1])
 126         cp(":")
 127         cp(sprintf(f.d, phy$root.edge))
 128         cp(";")
 129     }
 130     paste(STRING, collapse = "")
 131 }