[Vegan-commits] r601 - in branches/1.15: R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Dec 1 20:04:59 CET 2008
Author: gsimpson
Date: 2008-12-01 20:04:59 +0100 (Mon, 01 Dec 2008)
New Revision: 601
Modified:
branches/1.15/R/anova.betadisper.R
branches/1.15/R/betadisper.R
branches/1.15/R/permutest.betadisper.R
branches/1.15/R/plot.betadisper.R
branches/1.15/R/scores.betadisper.R
branches/1.15/inst/ChangeLog
branches/1.15/man/betadisper.Rd
Log:
merge r590 to 1.15 branch
Modified: branches/1.15/R/anova.betadisper.R
===================================================================
--- branches/1.15/R/anova.betadisper.R 2008-11-29 11:29:36 UTC (rev 600)
+++ branches/1.15/R/anova.betadisper.R 2008-12-01 19:04:59 UTC (rev 601)
@@ -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: branches/1.15/R/betadisper.R
===================================================================
--- branches/1.15/R/betadisper.R 2008-11-29 11:29:36 UTC (rev 600)
+++ branches/1.15/R/betadisper.R 2008-12-01 19:04:59 UTC (rev 601)
@@ -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: branches/1.15/R/permutest.betadisper.R
===================================================================
--- branches/1.15/R/permutest.betadisper.R 2008-11-29 11:29:36 UTC (rev 600)
+++ branches/1.15/R/permutest.betadisper.R 2008-12-01 19:04:59 UTC (rev 601)
@@ -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: branches/1.15/R/plot.betadisper.R
===================================================================
--- branches/1.15/R/plot.betadisper.R 2008-11-29 11:29:36 UTC (rev 600)
+++ branches/1.15/R/plot.betadisper.R 2008-12-01 19:04:59 UTC (rev 601)
@@ -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: branches/1.15/R/scores.betadisper.R
===================================================================
--- branches/1.15/R/scores.betadisper.R 2008-11-29 11:29:36 UTC (rev 600)
+++ branches/1.15/R/scores.betadisper.R 2008-12-01 19:04:59 UTC (rev 601)
@@ -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: branches/1.15/inst/ChangeLog
===================================================================
--- branches/1.15/inst/ChangeLog 2008-11-29 11:29:36 UTC (rev 600)
+++ branches/1.15/inst/ChangeLog 2008-12-01 19:04:59 UTC (rev 601)
@@ -6,6 +6,9 @@
Version 1.15-1 (opened October 10, 2008)
* merged r598: text.decorana failed.
+
+ * merged r590: betadisper and related functions now work when
+ 'group' represents a single group/level.
* merged r550, 552: neat plot.cca when input rownames are NULL.
Modified: branches/1.15/man/betadisper.Rd
===================================================================
--- branches/1.15/man/betadisper.Rd 2008-11-29 11:29:36 UTC (rev 600)
+++ branches/1.15/man/betadisper.Rd 2008-12-01 19:04:59 UTC (rev 601)
@@ -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