[Vegan-commits] r590 - in pkg/vegan: R inst man

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Sun Nov 23 16:11:00 CET 2008


Author: gsimpson
Date: 2008-11-23 16:11:00 +0100 (Sun, 23 Nov 2008)
New Revision: 590

Modified:
   pkg/vegan/R/anova.betadisper.R
   pkg/vegan/R/betadisper.R
   pkg/vegan/R/permutest.betadisper.R
   pkg/vegan/R/plot.betadisper.R
   pkg/vegan/R/scores.betadisper.R
   pkg/vegan/inst/ChangeLog
   pkg/vegan/man/betadisper.Rd
Log:
betadisper and related functions now work with a single group level

Modified: pkg/vegan/R/anova.betadisper.R
===================================================================
--- pkg/vegan/R/anova.betadisper.R	2008-11-23 07:07:15 UTC (rev 589)
+++ pkg/vegan/R/anova.betadisper.R	2008-11-23 15:11:00 UTC (rev 590)
@@ -2,5 +2,8 @@
 {
     model.dat <- with(object, data.frame(Distances = distances,
                                          Groups = group))
+    n.grps <- with(model.dat, length(unique(as.numeric(Groups))))
+    if(n.grps < 2)
+        stop("anova() only applicable to 2 or more groups")
     anova(lm(Distances ~ Groups, data = model.dat))
 }

Modified: pkg/vegan/R/betadisper.R
===================================================================
--- pkg/vegan/R/betadisper.R	2008-11-23 07:07:15 UTC (rev 589)
+++ pkg/vegan/R/betadisper.R	2008-11-23 15:11:00 UTC (rev 590)
@@ -23,20 +23,37 @@
     centroids <- apply(vectors, 2, function(x) tapply(x, group, mean))
     ## for each of the groups, calculate distance to centroid for
     ## observation in the group
-    dist.pos <- vectors[, pos, drop=FALSE] - centroids[group, pos, drop=FALSE]
-    dist.pos <- rowSums(dist.pos^2)
-    if (any(!pos)) {
-        dist.neg <- vectors[, !pos, drop=FALSE] -
-            centroids[group, !pos, drop=FALSE]
-        dist.neg <- rowSums(dist.neg^2)
+    if(is.matrix(centroids)) {
+        dist.pos <- vectors[, pos, drop=FALSE] -
+            centroids[group, pos, drop=FALSE]
+        dist.pos <- rowSums(dist.pos^2)
+        if (any(!pos)) {
+            dist.neg <- vectors[, !pos, drop=FALSE] -
+                centroids[group, !pos, drop=FALSE]
+            dist.neg <- rowSums(dist.neg^2)
+        } else {
+            dist.neg <- 0
+        }
     } else {
-        dist.neg <- 0
+        dist.pos <- vectors[, pos, drop=FALSE] -
+            centroids[pos]
+        dist.pos <- rowSums(dist.pos^2)
+        if (any(!pos)) {
+            dist.neg <- vectors[, !pos, drop=FALSE] -
+                centroids[!pos]
+            dist.neg <- rowSums(dist.neg^2)
+        } else {
+            dist.neg <- 0
+        }
     }
     ## zij are the distances of each point to its group centroid
     zij <- sqrt(abs(dist.pos - dist.neg))
     ## add in correct labels
-    colnames(vectors) <- colnames(centroids) <- names(eig) <-
-        paste("PCoA", 1:n, sep = "")
+    colnames(vectors) <- names(eig) <- paste("PCoA", 1:n, sep = "")
+    if(is.matrix(centroids))
+        colnames(centroids) <- names(eig)
+    else
+        names(centroids) <- names(eig)
     rownames(vectors) <- names(zij) <- attr(d, "Labels")
     retval <- list(eig = eig, vectors = vectors, distances = zij,
                    group = group, centroids = centroids, call = match.call())

Modified: pkg/vegan/R/permutest.betadisper.R
===================================================================
--- pkg/vegan/R/permutest.betadisper.R	2008-11-23 07:07:15 UTC (rev 589)
+++ pkg/vegan/R/permutest.betadisper.R	2008-11-23 15:11:00 UTC (rev 590)
@@ -13,6 +13,8 @@
     }
     if(!inherits(x, "betadisper"))
         stop("Only for class \"betadisper\"")
+    ## will issue error if only a single group
+    mod.aov <- anova(x)
     nobs <- length(x$distances)
     mod <- lm(x$distances ~ x$group)
     mod.Q <- mod$qr
@@ -62,7 +64,6 @@
     } else {
         pairwise <- NULL
     }
-    mod.aov <- anova(x)
     retval <- cbind(mod.aov[, 1:4], c(control$nperm, NA), c(pval, NA))
     dimnames(retval) <- list(c("Groups", "Residuals"),
                              c("Df", "Sum Sq", "Mean Sq", "F", "N.Perm",

Modified: pkg/vegan/R/plot.betadisper.R
===================================================================
--- pkg/vegan/R/plot.betadisper.R	2008-11-23 07:07:15 UTC (rev 589)
+++ pkg/vegan/R/plot.betadisper.R	2008-11-23 15:11:00 UTC (rev 590)
@@ -14,20 +14,37 @@
         ylab <- paste("PCoA", axes[2])
     g <- scores(x, choices = axes)
     plot(g$sites, asp = 1, type = "n", axes = FALSE, ann = FALSE, ...)
-    for(i in levels(x$group)) {
-        j <- which(levels(x$group) == i)
-        segments(g$centroids[j, axes[1]],
-                 g$centroids[j, axes[2]],
-                 g$sites[x$group == i, axes[1]],
-                 g$sites[x$group == i, axes[2]], col = "blue", ...)
-        if(hull) {
-            ch <- chull(g$sites[x$group == i, axes])
-            ch <- c(ch, ch[1])
-            lines(x$vectors[x$group == i, axes][ch, ],
-                       col = "black", lty = "dashed", ...)
+    ## if more than 1 group level
+    if(is.matrix(g$centroids)) {
+        for(i in levels(x$group)) {
+            j <- which(levels(x$group) == i)
+            segments(g$centroids[j, axes[1]],
+                     g$centroids[j, axes[2]],
+                     g$sites[x$group == i, axes[1]],
+                     g$sites[x$group == i, axes[2]], col = "blue", ...)
+            if(hull) {
+                ch <- chull(g$sites[x$group == i, axes])
+                ch <- c(ch, ch[1])
+                lines(x$vectors[x$group == i, axes][ch, ],
+                      col = "black", lty = "dashed", ...)
+            }
         }
+        points(g$centroids, pch = 16, cex = 1, col = "red", ...)
+    } else {
+        ## single group
+        segments(g$centroids[axes[1]],
+                     g$centroids[axes[2]],
+                     g$sites[, axes[1]],
+                     g$sites[, axes[2]], col = "blue", ...)
+            if(hull) {
+                ch <- chull(g$sites[, axes])
+                ch <- c(ch, ch[1])
+                lines(x$vectors[, axes][ch, ],
+                      col = "black", lty = "dashed", ...)
+            }
+        points(g$centroids[axes[1]], g$centroids[axes[1]],
+               pch = 16, cex = 1, col = "red", ...)
     }
-    points(g$centroids, pch = 16, cex = 1, col = "red", ...)
     points(g$sites, pch = as.numeric(x$group),
            cex = cex, ...)
     localTitle(main = main, xlab = xlab, ylab = ylab, sub = sub, ...)

Modified: pkg/vegan/R/scores.betadisper.R
===================================================================
--- pkg/vegan/R/scores.betadisper.R	2008-11-23 07:07:15 UTC (rev 589)
+++ pkg/vegan/R/scores.betadisper.R	2008-11-23 15:11:00 UTC (rev 590)
@@ -2,21 +2,16 @@
                                 choices = c(1,2), ...)
 {
     display <- match.arg(display, several.ok = TRUE)
-    #tabula <- c("sites", "centroids")
-    #names(tabula) <- c("sites", "centroids")
-    #if(length(display) == 1) {
-    #    display <- match.arg(display, c("sites", "centroids",
-    #                                    "wa", "cn"))
-    #    if(display == "sites")
-    #        display <- "wa"
-    #}
-    #take <- tabula[display]
     sol <- list()
     if("sites" %in% display)
         sol$sites <- x$vectors[, choices]
-    if("centroids" %in% display)
-        sol$centroids <- x$centroids[, choices]
-    if (length(sol) == 1) 
+    if("centroids" %in% display) {
+        if(is.matrix(x$centroids))
+            sol$centroids <- x$centroids[, choices]
+        else
+            sol$centroids <- x$centroids[choices]
+    }
+    if (length(sol) == 1)
         sol <- sol[[1]]
     return(sol)
 }

Modified: pkg/vegan/inst/ChangeLog
===================================================================
--- pkg/vegan/inst/ChangeLog	2008-11-23 07:07:15 UTC (rev 589)
+++ pkg/vegan/inst/ChangeLog	2008-11-23 15:11:00 UTC (rev 590)
@@ -4,9 +4,9 @@
 
 Version 1.16-4 (opened November 1, 2008)
 
-    * oecosimu: got a new control argument for quantitative null
-    model analyses, and this is available if method = "permat".
-    The print method and help file modified accordingly.
+	* oecosimu: got a new control argument for quantitative null
+	model analyses, and this is available if method = "permat".
+	The print method and help file modified accordingly.
 
 	* vignettes: Figures with narrower margins. Vignetted
 	"diversity-vegan" adds functional diversity ('treedive'), 'beals'
@@ -46,6 +46,12 @@
 	vegan).  With this code, the discrepancy statistic of the 'sipoo'
 	data is 50 (cf. notes on 1.16-3) instead of the original 55.
 
+	* betadisper: now works for cases where there is only a single 
+	group. 'scores', 'plot' and 'boxplot' methods updated to work in
+	such cases. 'anova' and 'permutest' methods stop with an error if
+	used for such cases as they implement tests that do not make sense
+	for a single group.
+
 Version 1.16-3 (closed November 1, 2008)
 
 	* spantree: saves labels of points, and 'cophenetic' and 'plot'

Modified: pkg/vegan/man/betadisper.Rd
===================================================================
--- pkg/vegan/man/betadisper.Rd	2008-11-23 07:07:15 UTC (rev 589)
+++ pkg/vegan/man/betadisper.Rd	2008-11-23 15:11:00 UTC (rev 590)
@@ -47,7 +47,8 @@
     \code{\link{vegdist}}.}
   \item{group}{vector describing the group structure, usually a factor
     or an object that can be coerced to a factor using
-    \code{\link[base]{as.factor}}.}
+    \code{\link[base]{as.factor}}. Can consist of a factor with a single
+    level (i.e.~one group).}
   \item{type}{the type of analysis to perform. Only \code{type =
       "centroid"} is currently supported.}
   \item{display}{character; partial match to access scores for
@@ -165,6 +166,11 @@
     principal coordinates.}
   \item{call}{the matched function call.}
 }
+\note{
+  If \code{group} consists of a single level or group, then the
+  \code{anova} and \code{permutest} methods are not appropriate and if
+  used on such data will stop with an error.
+}
 \references{
   Anderson, M.J. (2006) Distance-based tests for homogeneity of
   multivariate dispersions. \emph{Biometrics} \strong{62(1)}, 245--253.



More information about the Vegan-commits mailing list