new image.DNAbin()

[ape.git] / R / as.phylo.R

diff --git a/R/as.phylo.R b/R/as.phylo.R
index 2280652dc6987f7b2ff7b741a96c8802a1484f8d..e8d0f667a325b8df396f2f552d38ecbfa78e1f74 100644 (file)
--- a/R/as.phylo.R
+++ b/R/as.phylo.R
@@ -1,8 +1,8 @@
-## as.phylo.R (2007-03-05)
+## as.phylo.R (2010-12-15)
 
 ##     Conversion Among Tree Objects
 
-## Copyright 2005-2007 Emmanuel Paradis
+## Copyright 2005-2010 Emmanuel Paradis
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
@@ -36,31 +36,32 @@ as.phylo <- function (x, ...)
 as.phylo.hclust <- function(x, ...)
 {
     N <- dim(x$merge)[1]
-    edge <- matrix(NA, 2*N, 2)
+    edge <- matrix(0L, 2*N, 2)
     edge.length <- numeric(2*N)
     ## `node' gives the number of the node for the i-th row of x$merge
-    node <- numeric(N)
-    node[N] <- N + 2
-    cur.nod <- N + 3
-    j <- 1
+    node <- integer(N)
+    node[N] <- N + 2L
+    cur.nod <- N + 3L
+    j <- 1L
     for (i in N:1) {
         edge[j:(j + 1), 1] <- node[i]
         for (l in 1:2) {
-            k <- j + l - 1
-            if (x$merge[i, l] > 0) {
-                edge[k, 2] <- node[x$merge[i, l]] <- cur.nod
-                cur.nod <- cur.nod + 1
-                edge.length[k] <- x$height[i] - x$height[x$merge[i, l]]
+            k <- j + l - 1L
+            y <- x$merge[i, l]
+            if (y > 0) {
+                edge[k, 2] <- node[y] <- cur.nod
+                cur.nod <- cur.nod + 1L
+                edge.length[k] <- x$height[i] - x$height[y]
             } else {
-                edge[k, 2] <- -x$merge[i, l]
+                edge[k, 2] <- -y
                 edge.length[k] <- x$height[i]
             }
         }
-        j <- j + 2
+        j <- j + 2L
     }
     if (is.null(x$labels))
-      x$labels <- as.character(1:(N + 1))
-    obj <- list(edge = edge, edge.length = edge.length,
+        x$labels <- as.character(1:(N + 1))
+    obj <- list(edge = edge, edge.length = edge.length / 2,
                 tip.label = x$labels, Nnode = N)
     class(obj) <- "phylo"
     reorder(obj)
@@ -87,21 +88,25 @@ as.hclust.phylo <- function(x, ...)
 {
     if (!is.ultrametric(x)) stop("the tree is not ultrametric")
     if (!is.binary.tree(x)) stop("the tree is not binary")
+    if (!is.rooted(x)) stop("the tree is not rooted")
     n <- length(x$tip.label)
-    bt <- rev(branching.times(x))
-    N <- length(bt)
-    nm <- as.numeric(names(bt))
+    x$node.label <- NULL # by Jinlong Zhang (2010-12-15)
+    bt <- sort(branching.times(x))
+    inode <- as.numeric(names(bt))
+    N <- n - 1L
+    nm <- numeric(N + n) # hash table
+    nm[inode] <- 1:N
     merge <- matrix(NA, N, 2)
     for (i in 1:N) {
-        ind <- which(x$edge[, 1] == nm[i])
-        for (k in 1:2)
-          merge[i, k] <- if (x$edge[ind[k], 2] <= n) -x$edge[ind[k], 2]
-          else which(nm == x$edge[ind[k], 2])
+        ind <- which(x$edge[, 1] == inode[i])
+        for (k in 1:2) {
+            tmp <- x$edge[ind[k], 2]
+            merge[i, k] <- if (tmp <= n) -tmp else nm[tmp]
+        }
     }
     names(bt) <- NULL
-    obj <- list(merge = merge, height = bt, order = 1:(N + 1),
-                labels = x$tip.label, call = match.call(),
-                method = "unknown")
+    obj <- list(merge = merge, height = bt, order = 1:n, labels = x$tip.label,
+                call = match.call(), method = "unknown")
     class(obj) <- "hclust"
     obj
 }