R/collapse.singles.R

   1 ## collapse.singles.R (2010-07-23)
   2
   3 ##    Collapse "Single" Nodes
   4
   5 ## Copyright 2006 Ben Bolker
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 collapse.singles <- function(tree)
  11 {
  12     elen <- tree$edge.length
  13     xmat <- tree$edge
  14     ## added by Elizabeth Purdom (2008-06-19):
  15     node.lab <- tree$node.label
  16     nnode <- tree$Nnode
  17     ntip <- length(tree$tip.label)
  18     ## end
  19     singles <- NA
  20     while (length(singles) > 0) {
  21         ## changed by EP to make it slightly more efficient:
  22         ## tx <- table(xmat[xmat < 0])
  23         ## singles <- as.numeric(names(tx)[tx < 3])
  24         tx <- tabulate(xmat[, 1])
  25         singles <- which(tx == 1)
  26         ## END
  27         if (length(singles) > 0) {
  28             i <- singles[1]
  29             prev.node <- which(xmat[, 2] == i)
  30             next.node <- which(xmat[, 1] == i)
  31             xmat[prev.node, 2] <- xmat[next.node, 2]
  32             xmat <- xmat[xmat[, 1] != i, ] # drop
  33             ## changed by EP for the new coding of "phylo" (2006-10-05):
  34             ## xmat[xmat < i] <- xmat[xmat < i] + 1 ## adjust indices
  35             xmat[xmat > i] <- xmat[xmat > i] - 1L ## adjust indices # changed '1' by '1L' (2010-07-23)
  36             ## END
  37             elen[prev.node] <- elen[prev.node] + elen[next.node]
  38             ## added by Elizabeth Purdom (2008-06-19):
  39             if (!is.null(node.lab)) node.lab <- node.lab[-c(i - ntip)]
  40             nnode <- nnode - 1L
  41             ## end
  42             elen <- elen[-next.node]
  43         }
  44     }
  45     tree$edge <- xmat
  46     tree$edge.length <- elen
  47     ## added by Elizabeth Purdom (2008-06-19):
  48     tree$node.label <- node.lab
  49     tree$Nnode <- nnode
  50     ## end
  51     tree
  52 }