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

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

Author: jarioksa
Date: 2010-05-27 14:08:55 +0200 (Thu, 27 May 2010)
New Revision: 1196

Modified:
   pkg/vegan/R/ordispider.R
   pkg/vegan/R/scores.default.R
Log:
scores.default more robust with 1-row scores

Modified: pkg/vegan/R/ordispider.R
===================================================================
--- pkg/vegan/R/ordispider.R	2010-05-27 11:36:16 UTC (rev 1195)
+++ pkg/vegan/R/ordispider.R	2010-05-27 12:08:55 UTC (rev 1196)
@@ -1,6 +1,6 @@
 "ordispider" <-
     function (ord, groups, display = "sites", w = weights(ord, display),
-              show.groups, ...)
+              show.groups, label = FALSE, ...)
 {
     weights.default <- function(object, ...) NULL
     if (inherits(ord, "cca") && missing(groups)) {
@@ -24,6 +24,8 @@
     }
     out <- seq(along = groups)
     inds <- names(table(groups))
+    if (label) 
+    cntrs <- names <- NULL
     for (is in inds) {
         gr <- out[groups == is]
         if (length(gr) > 1) {
@@ -32,7 +34,13 @@
             ave <- apply(X, 2, weighted.mean, w = W)
             ordiArgAbsorber(ave[1], ave[2], X[, 1], X[, 2],
                             FUN = segments, ...)
+            if (label) {
+                cntrs <- rbind(cntrs, ave)
+                names <- c(names, is)
+            }
         }
     }
+    if (label) 
+        ordiArgAbsorber(cntrs, label = names, FUN = ordilabel, ...)
     invisible()
 }

Modified: pkg/vegan/R/scores.default.R
===================================================================
--- pkg/vegan/R/scores.default.R	2010-05-27 11:36:16 UTC (rev 1195)
+++ pkg/vegan/R/scores.default.R	2010-05-27 12:08:55 UTC (rev 1196)
@@ -37,8 +37,14 @@
             X <- x$c1
         else stop("Can't find scores")
     }
-    else if (is.numeric(x))
+    else if (is.numeric(x)) {
         X <- as.matrix(x)
+        ## as.matrix() changes 1-row scores into 1-col matrix: this is
+        ## a hack which may fail sometimes (but probably less often
+        ## than without this hack):
+        if (ncol(X) == 1 && nrow(X) == length(choices))
+            X <- t(X)
+    }
     if (is.null(rownames(X))) {
         root <- substr(display, 1, 4)
         rownames(X) <- paste(root, 1:nrow(X), sep = "")