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 }