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

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

Author: jarioksa
Date: 2014-12-08 09:47:23 +0100 (Mon, 08 Dec 2014)
New Revision: 2917

Modified:
   pkg/vegan/R/as.hclust.spantree.R
   pkg/vegan/R/cophenetic.spantree.R
   pkg/vegan/R/lines.spantree.R
   pkg/vegan/R/plot.spantree.R
   pkg/vegan/R/spantree.R
Log:
Handle degenerate spantrees with two, one or zero points

(cherry picked from commit 8bc11fa94ca5ab17e007aaec30507505e377847c)

Modified: pkg/vegan/R/as.hclust.spantree.R
===================================================================
--- pkg/vegan/R/as.hclust.spantree.R	2014-12-03 10:46:54 UTC (rev 2916)
+++ pkg/vegan/R/as.hclust.spantree.R	2014-12-08 08:47:23 UTC (rev 2917)
@@ -12,7 +12,9 @@
 {
     ## Order by the lengths of spanning tree links
     o <- order(x$dist)
-    npoints <- length(o) + 1
+    npoints <- x$n
+    if(npoints < 2)
+        stop("needs at least two points")
     ## Ordered indices of dads and kids
     dad <- (2:npoints)[o]
     kid <- x$kid[o]

Modified: pkg/vegan/R/cophenetic.spantree.R
===================================================================
--- pkg/vegan/R/cophenetic.spantree.R	2014-12-03 10:46:54 UTC (rev 2916)
+++ pkg/vegan/R/cophenetic.spantree.R	2014-12-08 08:47:23 UTC (rev 2917)
@@ -1,8 +1,10 @@
-"cophenetic.spantree" <-
+`cophenetic.spantree` <-
     function(x)
 {
-    n <- length(x$kid) + 1
+    n <- x$n
     mat <- matrix(NA, nrow=n, ncol=n)
+    if (n < 2)
+        return(as.dist(mat))
     ind <- apply(cbind(2:n, x$kid), 1, sort)
     ind <- t(ind[2:1,])
     mat[ind] <- x$dist

Modified: pkg/vegan/R/lines.spantree.R
===================================================================
--- pkg/vegan/R/lines.spantree.R	2014-12-03 10:46:54 UTC (rev 2916)
+++ pkg/vegan/R/lines.spantree.R	2014-12-08 08:47:23 UTC (rev 2917)
@@ -1,9 +1,10 @@
-"lines.spantree" <-
+`lines.spantree` <-
     function (x, ord, display = "sites", ...)
 {
     ord <- scores(ord, display = display, ...)
     tree <- x$kid
-    ordiArgAbsorber(ord[-1, 1], ord[-1, 2], ord[tree, 1], ord[tree, 2],
-                   FUN = segments, ...)
+    if (x$n > 1)
+        ordiArgAbsorber(ord[-1, 1], ord[-1, 2], ord[tree, 1], ord[tree, 2],
+                        FUN = segments, ...)
     invisible()
 }

Modified: pkg/vegan/R/plot.spantree.R
===================================================================
--- pkg/vegan/R/plot.spantree.R	2014-12-03 10:46:54 UTC (rev 2916)
+++ pkg/vegan/R/plot.spantree.R	2014-12-08 08:47:23 UTC (rev 2917)
@@ -1,21 +1,24 @@
-"plot.spantree" <-
+`plot.spantree` <-
     function (x, ord, cex = 0.7, type = "p", labels, dlim, FUN = sammon, 
               ...) 
 {
     FUNname <- deparse(substitute(FUN))
     FUN <- match.fun(FUN)
-    n <- length(x$kid) + 1
+    n <- x$n
     if (missing(ord)) {
         d <- cophenetic(x)
         if (any(d<=0))
             d[d<=0] <- min(d>0)/10
         if (!missing(dlim)) 
             d[d > dlim ] <- dlim
-        y <- cmdscale(d)
-        dup <- duplicated(y)
-        if (any(dup))
-            y[dup, ] <- y[dup,] + runif(2*sum(dup), -0.01, 0.01) 
-        ord <- FUN(d, y)
+        if (n > 2) {
+            y <- cmdscale(d)
+            dup <- duplicated(y)
+            if (any(dup))
+            y[dup, ] <- y[dup,] + runif(2*sum(dup), -0.01, 0.01)
+            ord <- FUN(d, y)
+        } else
+            ord <- cbind(seq_len(n), rep(0,n))
     }
     ord <- scores(ord, display = "sites", ...)
     ordiArgAbsorber(ord, asp = 1, type = "n", FUN = "plot", ...)

Modified: pkg/vegan/R/spantree.R
===================================================================
--- pkg/vegan/R/spantree.R	2014-12-03 10:46:54 UTC (rev 2916)
+++ pkg/vegan/R/spantree.R	2014-12-08 08:47:23 UTC (rev 2917)
@@ -1,4 +1,4 @@
-"spantree" <-
+`spantree` <-
     function (d, toolong = 0) 
 {
     dis <- as.dist(d)
@@ -8,7 +8,7 @@
               n = as.integer(n), val = double(n + 1),
               dad = integer(n + 1), NAOK = TRUE, PACKAGE = "vegan")
     out <- list(kid = dis$dad[2:n] + 1, dist = dis$val[2:n],
-                labels = labels, call = match.call())
+                labels = labels, n = n, call = match.call())
     class(out) <- "spantree"
     out
 }