1 ## write.nexus.R (2012-03-30)
3 ## Write Tree File in Nexus Format
5 ## Copyright 2003-2012 Emmanuel Paradis
7 ## This file is part of the R-package `ape'.
8 ## See the file ../COPYING for licensing issues.
10 write.nexus <- function(..., file = "", translate = TRUE)
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
17 obj <- obj[[1]] # NOT use unlist()
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)
25 N <- length(obj[[1]]$tip.label)
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)
36 cat("BEGIN TREES;\n", file = file, append = TRUE)
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)
47 obj[[i]]$tip.label <- as.character(1:N)
49 if (is.null(attr(obj, "TipLabel"))) {
51 obj[[i]]$tip.label <- checkLabel(obj[[i]]$tip.label)
53 attr(obj, "TipLabel") <- checkLabel(attr(obj, "TipLabel"))
54 obj <- .uncompressTipLabel(obj)
60 title <- rep("UNTITLED", ntree)
62 if (any(s <- title == "")) title[s] <- "UNTITLED"
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)
72 cat("END;\n", file = file, append = TRUE)