[Vegan-commits] r2981 - pkg/vegan/R

[noreply at r-forge.r-project.org]

Author: jarioksa
Date: 2015-11-30 08:46:30 +0100 (Mon, 30 Nov 2015)
New Revision: 2981

Modified:
   pkg/vegan/R/treedist.R
   pkg/vegan/R/treedive.R
   pkg/vegan/R/treeheight.R
Log:
Merge branch 'cran-2.3' into r-forge-svn-local

Modified: pkg/vegan/R/treedist.R
===================================================================
--- pkg/vegan/R/treedist.R	2015-11-26 09:14:58 UTC (rev 2980)
+++ pkg/vegan/R/treedist.R	2015-11-30 07:46:30 UTC (rev 2981)
@@ -1,6 +1,11 @@
 `treedist` <-
     function(x, tree, relative = TRUE,  match.force = TRUE, ...)
 {
+    ## we cannot reconstruct tree with reversals from cophenetic
+    tree <- as.hclust(tree)
+    if (any(diff(tree$height) < -sqrt(.Machine$double.eps)))
+        stop("tree with reversals cannot be handled")
+    x <- as.matrix(x)
     n <- nrow(x)
     ABJ <- matrix(0, n , n)
     dmat <- as.matrix(cophenetic(tree))

Modified: pkg/vegan/R/treedive.R
===================================================================
--- pkg/vegan/R/treedive.R	2015-11-26 09:14:58 UTC (rev 2980)
+++ pkg/vegan/R/treedive.R	2015-11-30 07:46:30 UTC (rev 2981)
@@ -1,8 +1,12 @@
 `treedive` <-
     function(comm, tree, match.force = TRUE, verbose = TRUE)
 {
+    EPS <- sqrt(.Machine$double.eps)
+    comm <- as.matrix(comm)
     if (!inherits(tree, c("hclust", "spantree")))
-        stop("'clus' must be an 'hclust' or 'spantree' result object")
+        stop("'tree' must be an 'hclust' or 'spantree' result object")
+    if (inherits(tree, "hclust") && any(diff(tree$height) < -EPS))
+        stop("tree with reversals cannot be handled")
     m <- as.matrix(cophenetic(tree))
     ## Check tree/comm match by names
     if (match.force || ncol(comm) != ncol(m)) {

Modified: pkg/vegan/R/treeheight.R
===================================================================
--- pkg/vegan/R/treeheight.R	2015-11-26 09:14:58 UTC (rev 2980)
+++ pkg/vegan/R/treeheight.R	2015-11-30 07:46:30 UTC (rev 2981)
@@ -4,6 +4,27 @@
     if (inherits(tree, "spantree"))
         return(sum(tree$dist))
     tree <- as.hclust(tree)
-    sum(tree$height) + max(tree$height)
+    ## nodes should start from 0 -- if there are negative heights,
+    ## tree is too pathological to be measured.
+    if (any(tree$height < 0))
+        stop("negative heights: tree cannot be measured")
+    ## can be done really fast if there are no reversals, but we need
+    ## to traverse the tree with reversals
+    if (is.unsorted(tree$height)) { # slow
+        h <- tree$height
+        m <- tree$merge
+        height <- 0
+        for (i in 1:nrow(m)) {
+            for (j in 1:2) {
+                if (m[i,j] < 0)
+                    height <- height + h[i]
+                else
+                    height <- height + abs(h[i] - h[m[i,j]])
+            }
+        }
+        height
+    }
+    else    # fast
+        sum(tree$height) + max(tree$height)
 }