X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=R%2Fread.nexus.R;h=117b31f36ce61b33178734b3715dff078e23cb9e;hb=f3304b6f40610d9b7306a9275d593b5c038ab0a0;hp=06acd2fb39e4bbb6bf3b76780ff7525d3c37afa3;hpb=35ab8b00668b0993d0e8221094555adc997518c1;p=ape.git

diff --git a/R/read.nexus.R b/R/read.nexus.R
index 06acd2f..117b31f 100644
--- a/R/read.nexus.R
+++ b/R/read.nexus.R
@@ -1,8 +1,8 @@
-## read.nexus.R (2008-07-09)
+## read.nexus.R (2011-03-18)
 
 ##   Read Tree File in Nexus Format
 
-## Copyright 2003-2008 Emmanuel Paradis
+## Copyright 2003-2011 Emmanuel Paradis and 2010 Klaus Schliep
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
@@ -11,10 +11,10 @@
 {
     phy <- .Call("treeBuildWithTokens", x, PACKAGE = "ape")
     dim(phy[[1]]) <- c(length(phy[[1]])/2, 2)
-    nms <- c("edge", "edge.length", "Nnode", "node.label")
-    if (length(phy) == 5) nms <- c(nms, "root.edge")
+    nms <- c("edge", "edge.length", "Nnode", "node.label", "root.edge")
+    if (length(phy) == 4) nms <- nms[-5]
     names(phy) <- nms
-    if (!sum(phy[[4]])) phy[[4]] <- NULL
+    if (all(phy$node.label == "")) phy$node.label <- NULL
     class(phy) <- "phylo"
     phy
 }
@@ -25,18 +25,20 @@ clado.build <- function(tp)
         edge[j, 1] <<- current.node
         node <<- node + 1
         edge[j, 2] <<- current.node <<- node
+        index[node] <<- j # set index
         j <<- j + 1
     }
     add.terminal <- function() {
         edge[j, 1] <<- current.node
         edge[j, 2] <<- tip
+        index[tip] <<- j # set index
         tip.label[tip] <<- tpc[k]
         k <<- k + 1
         tip <<- tip + 1
         j <<- j + 1
     }
     go.down <- function() {
-        l <- which(edge[, 2] == current.node)
+        l <- index[current.node]
         node.label[current.node - nb.tip] <<- tpc[k]
         k <<- k + 1
         current.node <<- edge[l, 1]
@@ -45,7 +47,7 @@ clado.build <- function(tp)
         obj <- list(edge = matrix(c(2, 1), 1, 2), Nnode = 1)
         tp <- unlist(strsplit(tp, "[\\(\\);]"))
         obj$tip.label <- tp[2]
-        if (length(tp) == 3) obj$node.label <- tp[3]
+        if (tp[3] != "") obj$node.label <- tp[3]
         class(obj) <- "phylo"
         return(obj)
     }
@@ -69,11 +71,12 @@ clado.build <- function(tp)
     edge[nb.edge, 1] <- 0    # see comment above
     edge[nb.edge, 2] <- node #
 
+    index <- numeric(nb.edge + 1)
+    index[node] <- nb.edge
     ## j: index of the line number of edge
     ## k: index of the line number of tpc
     ## tip: tip number
     j <- k <- tip <- 1
-
     for (i in 2:nsk) {
         if (skeleton[i] == "(") add.internal()      # add an internal branch (on top)
         if (skeleton[i] == ",") {
@@ -87,7 +90,6 @@ clado.build <- function(tp)
             if (skeleton[i - 1] == ")") go.down()   # go down one level
         }
     }
-#    if(node.label[1] == "NA") node.label[1] <- ""
     edge <- edge[-nb.edge, ]
     obj <- list(edge = edge, tip.label = tip.label,
                 Nnode = nb.node, node.label = node.label)
@@ -153,16 +155,25 @@ read.nexus <- function(file, tree.names = NULL)
     tree <- X[start:end]
     rm(X)
     tree <- gsub("^.*= *", "", tree)
+    ## check whether there are empty lines from the above manips:
+    tree <- tree[tree != ""]
     semico <- grep(";", tree)
     Ntree <- length(semico)
     ## are some trees on several lines?
-    if (any(diff(semico) != 1)) {
-        STRING <- character(Ntree)
-        s <- c(1, semico[-Ntree] + 1)
-        j <- mapply(":", s, semico)
-        for (i in 1:Ntree)
-            STRING[i] <- paste(tree[j[, i]], collapse = "")
-    } else STRING <- tree
+    if (Ntree == 1 && length(tree) > 1) STRING <- paste(tree, collapse = "") else {
+        if (any(diff(semico) != 1)) {
+            STRING <- character(Ntree)
+            s <- c(1, semico[-Ntree] + 1)
+            j <- mapply(":", s, semico)
+            if (is.list(j)) {
+                for (i in 1:Ntree)
+                    STRING[i] <- paste(tree[j[[i]]], collapse = "")
+            } else {
+                for (i in 1:Ntree)
+                    STRING[i] <- paste(tree[j[, i]], collapse = "")
+            }
+        } else STRING <- tree
+    }
     rm(tree)
     STRING <- gsub(" ", "", STRING)
     colon <- grep(":", STRING)
@@ -208,15 +219,28 @@ read.nexus <- function(file, tree.names = NULL)
     }
     if (Ntree == 1) {
         trees <- trees[[1]]
-        if (translation)
-            trees$tip.label <- TRANS[, 2][as.numeric(trees$tip.label)]
+        if (translation) {
+            trees$tip.label <-
+                if (length(colon)) TRANS[, 2] else
+                TRANS[, 2][as.numeric(trees$tip.label)]
+        }
     } else {
         if (!is.null(tree.names)) names(trees) <- tree.names
-        if (translation) attr(trees, "TipLabel") <- TRANS[, 2]
+        if (translation) {
+            if (length(colon) == Ntree) # .treeBuildWithTokens() was used
+                attr(trees, "TipLabel") <- TRANS[, 2]
+            else { # reassign the tip labels then compress
+                for (i in 1:Ntree)
+                    trees[[i]]$tip.label <-
+                        TRANS[, 2][as.numeric(trees[[i]]$tip.label)]
+                trees <- .compressTipLabel(trees)
+            }
+        }
         class(trees) <- "multiPhylo"
     }
     if (length(grep("[\\/]", file)) == 1)
-        file <- paste(getwd(), file, sep = "/")
+        if (!file.exists(file)) # suggestion by Francois Michonneau
+            file <- paste(getwd(), file, sep = "/")
     attr(trees, "origin") <- file
     trees
 }