R/write.tree.R

   1 ## write.tree.R (2007-12-22)
   2
   3 ##   Write Tree File in Parenthetic Format
   4
   5 ## Copyright 2002-2007 Emmanuel Paradis
   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 <- function(phy, file = "", append = FALSE,
  31                        digits = 10)
  32 {
  33     if (class(phy) == "multiPhylo") {
  34         write.tree(phy[[1]], file = file,
  35                    append = append, digits = digits)
  36         if (length(phy) > 1)
  37             for (i in 2:length(phy))
  38                 write.tree(phy[[i]], file = file,
  39                            append = TRUE, digits = digits)
  40         return(invisible(NULL))
  41     }
  42
  43     if (class(phy) != "phylo")
  44       stop('object "phy" is not of class "phylo"')
  45
  46     brl <- !is.null(phy$edge.length)
  47
  48 ### Ne serait-il pas plus efficace de créer des node labels vides
  49 ### "" et d'éviter l'évaluation if (nodelab) ????
  50 ### Autre possibilité : créer plusieurs variants de ces fonctions
  51 ### (au moins deux avec/sans edge.length)
  52
  53 ### Encore autre chose: les appels à which ne peuvent-ils pas
  54 ### être évités ??? surtout si l'arbre est en cladewise order...
  55
  56     nodelab <- !is.null(phy$node.label)
  57     phy$tip.label <- checkLabel(phy$tip.label)
  58     if (nodelab)
  59       phy$node.label <- checkLabel(phy$node.label)
  60
  61     f.d <- paste("%.", digits, "g", sep = "")
  62
  63     cp <- function(s) STRING <<- paste(STRING, s, sep = "")
  64     add.internal <- function(i) {
  65         cp("(")
  66         br <- which(phy$edge[, 1] == i)
  67         for (j in br) {
  68             desc <- phy$edge[j, 2]
  69             if (desc > n) add.internal(desc) else add.terminal(j)
  70             if (j != br[length(br)]) cp(",")
  71         }
  72         cp(")")
  73         if (nodelab) cp(phy$node.label[i - n])
  74         if (brl) {
  75             cp(":")
  76             cp(sprintf(f.d, phy$edge.length[which(phy$edge[, 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     br <- which(phy$edge[, 1] == n + 1)
  89     for (j in br) {
  90         desc <- phy$edge[j, 2]
  91         if (desc > n) add.internal(desc) else add.terminal(j)
  92         if (j != br[length(br)]) cp(",")
  93     }
  94     if (is.null(phy$root.edge)) {
  95         cp(")")
  96         if (nodelab) cp(phy$node.label[1])
  97         cp(";")
  98     } else {
  99         cp(")")
 100         if (nodelab) cp(phy$node.label[1])
 101         cp(":")
 102         cp(sprintf(f.d, phy$root.edge))
 103         cp(";")
 104     }
 105     if (file == "") return(STRING)
 106     else cat(STRING, file = file, append = append, sep = "\n")
 107 }