X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=R%2Fcollapse.singles.R;h=e4d2bfe410516dcc0da6cd586cd6c65f40b6e8a6;hb=f5c4abe6ac31486e821d82788bf66b5db2be51d1;hp=ad3cd985bd6bbb90006b8a8b18c33cd6989c38ae;hpb=5c40f536fadaa42ad1683969cfe249c4fabba87a;p=ape.git

diff --git a/R/collapse.singles.R b/R/collapse.singles.R
index ad3cd98..e4d2bfe 100644
--- a/R/collapse.singles.R
+++ b/R/collapse.singles.R
@@ -1,52 +1,47 @@
-## collapse.singles.R (2008-06-19)
+## collapse.singles.R (2013-01-16)
 
 ##    Collapse "Single" Nodes
 
-## Copyright 2006 Ben Bolker
+## Copyright 2006 Ben Bolker, 2013 Klaus Schliep
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
 
 collapse.singles <- function(tree)
 {
+    tree <- reorder(tree) # added by Klaus
     elen <- tree$edge.length
     xmat <- tree$edge
     ## added by Elizabeth Purdom (2008-06-19):
-    node.lab<-tree$node.label
-    nnode<-tree$Nnode
-    ntip<-length(tree$tip.label)
+    node.lab <- tree$node.label
+    nnode <- tree$Nnode
+    ntip <- length(tree$tip.label)
     ## end
-    singles <- NA
-    while (length(singles) > 0) {
-        ## changed by EP to make it slightly more efficient:
-        ## tx <- table(xmat[xmat < 0])
-        ## singles <- as.numeric(names(tx)[tx < 3])
-        tx <- tabulate(xmat[, 1])
-        singles <- which(tx == 1)
-        ## END
-        if (length(singles) > 0) {
-            i <- singles[1]
-            prev.node <- which(xmat[, 2] == i)
-            next.node <- which(xmat[, 1] == i)
-            xmat[prev.node, 2] <- xmat[next.node, 2]
-            xmat <- xmat[xmat[, 1] != i, ] ## drop
-            ## changed by EP for the new coding of "phylo" (2006-10-05):
-            ## xmat[xmat < i] <- xmat[xmat < i] + 1 ## adjust indices
-            xmat[xmat > i] <- xmat[xmat > i] - 1 ## adjust indices
-            ## END
-            elen[prev.node] <- elen[prev.node] + elen[next.node]
-            ## added by Elizabeth Purdom (2008-06-19):
-            if(!is.null(node.lab)) node.lab<-node.lab[-c(i-ntip)]
-            nnode<-nnode-1
-            ## end
-            elen <- elen[-next.node]
+    ## Added by Klaus (2013-01-16):
+    tx <- tabulate(xmat[, 1])
+    singles <- which(tx == 1)
+    if (length(singles) > 0) {
+        prev.nodes <- match(singles, xmat[,2])
+        next.nodes <- match(singles, xmat[,1])
+        for(j in length(singles):1) {
+            i <- singles[j]
+            xmat[prev.nodes[j], 2] <- xmat[next.nodes[j], 2]
+            elen[prev.nodes[j]] <- elen[prev.nodes[j]] + elen[next.nodes[j]]
         }
+        xmat <- xmat[-next.nodes,]
+        elen <- elen[-next.nodes]
+        if (!is.null(node.lab)) node.lab <- node.lab[-c(singles - ntip)]
+        nnode = nnode - as.integer(length(singles))
+        tmp = integer(max(xmat))
+        tmp[sort(unique(as.vector(xmat)))] = as.integer(c(1:(ntip+nnode)))
+        xmat[] = tmp[xmat]
     }
+    # End
     tree$edge <- xmat
     tree$edge.length <- elen
     ## added by Elizabeth Purdom (2008-06-19):
-    tree$node.label<-node.lab
-    tree$Nnode<-nnode
+    tree$node.label <- node.lab
+    tree$Nnode <- nnode
     ## end
     tree
 }