R/write.nexus.R

   1 ## write.nexus.R (2011-03-26)
   2
   3 ##   Write Tree File in Nexus Format
   4
   5 ## Copyright 2003-2011 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 = 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     if (original.data) {
  25         if (!is.null(attr(obj[[1]], "origin"))) {
  26             if (!file.exists(attr(obj[[1]], "origin"))) {
  27                 warning(paste("the file", attr(obj[[1]], "origin"),
  28                               "cannot be found,
  29 the original data won't be written with the tree."))
  30                 original.data <- FALSE
  31             }
  32             else {
  33                 ORI <- scan(file = attr(obj[[1]], "origin"), what = character(),
  34                             sep = "\n", skip = 1)
  35                 start <- grep("BEGIN TAXA;", ORI)
  36                 ORI <- ORI[-(1:(start - 1))]
  37                 ORI <- gsub("ENDBLOCK;", "END;", ORI)
  38                 endblock <- grep("END;", ORI)
  39                 start <- grep("BEGIN TREES;", ORI)
  40                 end <- endblock[endblock > start][1]
  41                 cat(ORI[1:(start - 1)], file = file, append = TRUE, sep = "\n")
  42                 ORI <- ORI[-(1:end)]
  43             }
  44         }
  45         else original.data <- FALSE
  46     }
  47     N <- length(obj[[1]]$tip.label)
  48     if (!original.data) {
  49         cat("BEGIN TAXA;\n", file = file, append = TRUE)
  50         cat(paste("\tDIMENSIONS NTAX = ", N, ";\n", sep = ""),
  51             file = file, append = TRUE)
  52         cat("\tTAXLABELS\n", file = file, append = TRUE)
  53         cat(paste("\t\t", obj[[1]]$tip.label, sep = ""),
  54             sep = "\n", file = file, append = TRUE)
  55         cat("\t;\n", file = file, append = TRUE)
  56         cat("END;\n", file = file, append = TRUE)
  57     }
  58     cat("BEGIN TREES;\n", file = file, append = TRUE)
  59     if (translate) {
  60         cat("\tTRANSLATE\n", file = file, append = TRUE)
  61         obj <- .compressTipLabel(obj)
  62         X <- paste("\t\t", 1:N, "\t", attr(obj, "TipLabel"), ",", sep = "")
  63         ## We remove the last comma:
  64         X[length(X)] <- gsub(",", "", X[length(X)])
  65         cat(X, file = file, append = TRUE, sep = "\n")
  66         cat("\t;\n", file = file, append = TRUE)
  67         class(obj) <- NULL
  68         for (i in 1:ntree)
  69             obj[[i]]$tip.label <- as.character(1:N)
  70     } else {
  71         if (is.null(attr(obj, "TipLabel"))) {
  72             for (i in 1:ntree)
  73                 obj[[i]]$tip.label <- checkLabel(obj[[i]]$tip.label)
  74         } else {
  75             attr(obj, "TipLabel") <- checkLabel(attr(obj, "TipLabel"))
  76             obj <- .uncompressTipLabel(obj)
  77         }
  78     }
  79
  80     title <- names(obj)
  81     if (is.null(title))
  82         title <- rep("UNTITLED", ntree)
  83     else {
  84         if (any(s <- title == "")) title[s] <- "UNTITLED"
  85     }
  86
  87     for (i in 1:ntree) {
  88         if (class(obj[[i]]) != "phylo") next
  89         if (is.rooted(obj[[i]]))
  90           cat("\tTREE *,", title[i], "= [&R] ", file = file, append = TRUE)
  91         else cat("\tTREE *", title[i], "= [&U] ", file = file, append = TRUE)
  92         cat(write.tree(obj[[i]], file = ""),
  93             "\n", sep = "", file = file, append = TRUE)
  94     }
  95     cat("END;\n", file = file, append = TRUE)
  96     if(original.data) cat(ORI, file = file, append = TRUE, sep = "\n")
  97 }