R/write.nexus.R

   1 ## write.nexus.R (2012-02-09)
   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, original.data = NULL)
  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     if (!is.null(original.data))
  26         warning("the option 'original.data' is deprecated and will be removed soon. Please update your code.")
  27
  28     N <- length(obj[[1]]$tip.label)
  29
  30     cat("BEGIN TAXA;\n", file = file, append = TRUE)
  31     cat(paste("\tDIMENSIONS NTAX = ", N, ";\n", sep = ""),
  32         file = file, append = TRUE)
  33     cat("\tTAXLABELS\n", file = file, append = TRUE)
  34     cat(paste("\t\t", obj[[1]]$tip.label, sep = ""),
  35         sep = "\n", file = file, append = TRUE)
  36     cat("\t;\n", file = file, append = TRUE)
  37     cat("END;\n", file = file, append = TRUE)
  38
  39     cat("BEGIN TREES;\n", file = file, append = TRUE)
  40     if (translate) {
  41         cat("\tTRANSLATE\n", file = file, append = TRUE)
  42         obj <- .compressTipLabel(obj)
  43         X <- paste("\t\t", 1:N, "\t", attr(obj, "TipLabel"), ",", sep = "")
  44         ## We remove the last comma:
  45         X[length(X)] <- gsub(",", "", X[length(X)])
  46         cat(X, file = file, append = TRUE, sep = "\n")
  47         cat("\t;\n", file = file, append = TRUE)
  48         class(obj) <- NULL
  49         for (i in 1:ntree)
  50             obj[[i]]$tip.label <- as.character(1:N)
  51     } else {
  52         if (is.null(attr(obj, "TipLabel"))) {
  53             for (i in 1:ntree)
  54                 obj[[i]]$tip.label <- checkLabel(obj[[i]]$tip.label)
  55         } else {
  56             attr(obj, "TipLabel") <- checkLabel(attr(obj, "TipLabel"))
  57             obj <- .uncompressTipLabel(obj)
  58         }
  59     }
  60
  61     title <- names(obj)
  62     if (is.null(title))
  63         title <- rep("UNTITLED", ntree)
  64     else {
  65         if (any(s <- title == "")) title[s] <- "UNTITLED"
  66     }
  67
  68     for (i in 1:ntree) {
  69         if (class(obj[[i]]) != "phylo") next
  70         if (is.rooted(obj[[i]]))
  71           cat("\tTREE *,", title[i], "= [&R] ", file = file, append = TRUE)
  72         else cat("\tTREE *", title[i], "= [&U] ", file = file, append = TRUE)
  73         cat(write.tree(obj[[i]], file = ""),
  74             "\n", sep = "", file = file, append = TRUE)
  75     }
  76     cat("END;\n", file = file, append = TRUE)
  77 }