adding contribs by Daniel Lawson

[ape.git] / R / read.tree.R

diff --git a/R/read.tree.R b/R/read.tree.R
index cbcfd3f9c4a6e418cdf208fcd4075f15874ace5b..aa508b0eab5d37879162a9a0a16746cbc4e68041 100644 (file)
--- a/R/read.tree.R
+++ b/R/read.tree.R
@@ -1,8 +1,8 @@
-## read.tree.R (2008-02-18)
+## read.tree.R (2009-03-09)
 
 ##   Read Tree Files in Parenthetic Format
 
-## Copyright 2002-2008 Emmanuel Paradis
+## Copyright 2002-2009 Emmanuel Paradis and Daniel Lawson
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
@@ -94,9 +94,18 @@ tree.build <- function(tp)
     obj
 }
 
-read.tree <- function(file = "", text = NULL, tree.names = NULL,
-                      skip = 0, comment.char = "#", ...)
+read.tree <- function(file = "", text = NULL, tree.names = NULL, skip = 0,
+    comment.char = "#", keep.multi = FALSE, ...)
 {
+    unname <- function(treetext) {
+       tstart <- 1
+       while (substr(treetext, tstart, tstart) != "(" && tstart <= nchar(treetext))
+            tstart <- tstart + 1
+       if (tstart > 1)
+            return(c(substr(treetext, 1, tstart - 1),
+                     substr(treetext, tstart, nchar(treetext))))
+       return(c("", treetext))
+    }
     if (!is.null(text)) {
         if (!is.character(text))
           stop("argument `text' must be of mode character")
@@ -105,6 +114,10 @@ read.tree <- function(file = "", text = NULL, tree.names = NULL,
         tree <- scan(file = file, what = "", sep = "\n", quiet = TRUE,
                      skip = skip, comment.char = comment.char, ...)
     }
+    tmp <- lapply(tree, unname)
+    tmpnames <- sapply(tmp, function(x) x[1])
+    tree <- sapply(tmp, function(x) x[2])
+    if (is.null(tree.names) && any(nzchar(tmpnames))) tree.names <- tmpnames
     ## Suggestion from Eric Durand and Nicolas Bortolussi (added 2005-08-17):
     if (identical(tree, character(0))) {
         warning("empty character string.")
@@ -139,7 +152,7 @@ read.tree <- function(file = "", text = NULL, tree.names = NULL,
         if(sum(obj[[i]]$edge[, 1] == ROOT) == 1 && dim(obj[[i]]$edge)[1] > 1)
             stop(paste("There is apparently two root edges in your file: cannot read tree file.\n  Reading Newick file aborted at tree no.", i, sep = ""))
     }
-    if (Ntree == 1) obj <- obj[[1]] else {
+    if (Ntree == 1 && !keep.multi) obj <- obj[[1]] else {
         if (!is.null(tree.names)) names(obj) <- tree.names
         class(obj) <- "multiPhylo"
     }