R/write.nexus.R

   1 ## write.nexus.R (2012-03-30)
   2
   3 ##   Write Tree File in Nexus Format
   4
   5 ## Copyright 2003-2012 Emmanuel Paradis
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 write.nexus <- function(..., file = "", translate = TRUE)
  11 {
  12     obj <- list(...)
  13     ## We insure that all trees are in a list, even if there is a single one:
  14     if (length(obj) == 1) {
  15         if (class(obj[[1]]) == "phylo") ntree <- 1
  16         else {
  17             obj <- obj[[1]] # NOT use unlist()
  18             ntree <- length(obj)
  19         }
  20     } else ntree <- length(obj)
  21     cat("#NEXUS\n", file = file)
  22     cat(paste("[R-package APE, ", date(), "]\n\n", sep = ""),
  23         file = file, append = TRUE)
  24
  25     N <- length(obj[[1]]$tip.label)
  26
  27     cat("BEGIN TAXA;\n", file = file, append = TRUE)
  28     cat(paste("\tDIMENSIONS NTAX = ", N, ";\n", sep = ""),
  29         file = file, append = TRUE)
  30     cat("\tTAXLABELS\n", file = file, append = TRUE)
  31     cat(paste("\t\t", obj[[1]]$tip.label, sep = ""),
  32         sep = "\n", file = file, append = TRUE)
  33     cat("\t;\n", file = file, append = TRUE)
  34     cat("END;\n", file = file, append = TRUE)
  35
  36     cat("BEGIN TREES;\n", file = file, append = TRUE)
  37     if (translate) {
  38         cat("\tTRANSLATE\n", file = file, append = TRUE)
  39         obj <- .compressTipLabel(obj)
  40         X <- paste("\t\t", 1:N, "\t", attr(obj, "TipLabel"), ",", sep = "")
  41         ## We remove the last comma:
  42         X[length(X)] <- gsub(",", "", X[length(X)])
  43         cat(X, file = file, append = TRUE, sep = "\n")
  44         cat("\t;\n", file = file, append = TRUE)
  45         class(obj) <- NULL
  46         for (i in 1:ntree)
  47             obj[[i]]$tip.label <- as.character(1:N)
  48     } else {
  49         if (is.null(attr(obj, "TipLabel"))) {
  50             for (i in 1:ntree)
  51                 obj[[i]]$tip.label <- checkLabel(obj[[i]]$tip.label)
  52         } else {
  53             attr(obj, "TipLabel") <- checkLabel(attr(obj, "TipLabel"))
  54             obj <- .uncompressTipLabel(obj)
  55         }
  56     }
  57
  58     title <- names(obj)
  59     if (is.null(title))
  60         title <- rep("UNTITLED", ntree)
  61     else {
  62         if (any(s <- title == "")) title[s] <- "UNTITLED"
  63     }
  64
  65     for (i in 1:ntree) {
  66         if (class(obj[[i]]) != "phylo") next
  67         root.tag <- if (is.rooted(obj[[i]])) "= [&R] " else "= [&U] "
  68         cat("\tTREE *", title[i], root.tag, file = file, append = TRUE)
  69         cat(write.tree(obj[[i]], file = ""),
  70             "\n", sep = "", file = file, append = TRUE)
  71     }
  72     cat("END;\n", file = file, append = TRUE)
  73 }