[Vegan-commits] r2882 - in pkg/vegan: . R inst man tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Sep 16 09:13:05 CEST 2014
Author: jarioksa
Date: 2014-09-16 09:13:05 +0200 (Tue, 16 Sep 2014)
New Revision: 2882
Added:
pkg/vegan/R/getPermuteMatrix.R
Removed:
pkg/vegan/R/ordiplot3d.R
pkg/vegan/R/ordirgl.R
pkg/vegan/R/orglpoints.R
pkg/vegan/R/orglsegments.R
pkg/vegan/R/orglspider.R
pkg/vegan/R/orgltext.R
pkg/vegan/R/rgl.isomap.R
pkg/vegan/R/rgl.renyiaccum.R
pkg/vegan/man/ordiplot3d.Rd
Modified:
pkg/vegan/DESCRIPTION
pkg/vegan/NAMESPACE
pkg/vegan/R/CCorA.R
pkg/vegan/R/SSarrhenius.R
pkg/vegan/R/adonis.R
pkg/vegan/R/anosim.R
pkg/vegan/R/anova.cca.R
pkg/vegan/R/envfit.default.R
pkg/vegan/R/factorfit.R
pkg/vegan/R/howHead.R
pkg/vegan/R/mantel.R
pkg/vegan/R/mantel.partial.R
pkg/vegan/R/mrpp.R
pkg/vegan/R/mso.R
pkg/vegan/R/nesteddisc.R
pkg/vegan/R/oecosimu.R
pkg/vegan/R/permuted.index.R
pkg/vegan/R/permutest.betadisper.R
pkg/vegan/R/permutest.cca.R
pkg/vegan/R/print.mrpp.R
pkg/vegan/R/print.protest.R
pkg/vegan/R/protest.R
pkg/vegan/R/raupcrick.R
pkg/vegan/R/simper.R
pkg/vegan/R/vectorfit.R
pkg/vegan/inst/ChangeLog
pkg/vegan/man/CCorA.Rd
pkg/vegan/man/add1.cca.Rd
pkg/vegan/man/adonis.Rd
pkg/vegan/man/anosim.Rd
pkg/vegan/man/anova.cca.Rd
pkg/vegan/man/envfit.Rd
pkg/vegan/man/isomap.Rd
pkg/vegan/man/mantel.Rd
pkg/vegan/man/mrpp.Rd
pkg/vegan/man/mso.Rd
pkg/vegan/man/ordistep.Rd
pkg/vegan/man/orditkplot.Rd
pkg/vegan/man/permutations.Rd
pkg/vegan/man/procrustes.Rd
pkg/vegan/man/raupcrick.Rd
pkg/vegan/man/renyi.Rd
pkg/vegan/man/simper.Rd
pkg/vegan/man/tsallis.Rd
pkg/vegan/man/vegan-internal.Rd
pkg/vegan/tests/vegan-tests.R
Log:
Merge branch 'master' into r-forge-svn-local
Modified: pkg/vegan/DESCRIPTION
===================================================================
--- pkg/vegan/DESCRIPTION 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/DESCRIPTION 2014-09-16 07:13:05 UTC (rev 2882)
@@ -1,14 +1,14 @@
Package: vegan
Title: Community Ecology Package
-Version: 2.1-42
-Date: September 4, 2014
+Version: 2.1-43
+Date: 2014-09-12
Author: Jari Oksanen, F. Guillaume Blanchet, Roeland Kindt, Pierre Legendre,
Peter R. Minchin, R. B. O'Hara, Gavin L. Simpson, Peter Solymos,
M. Henry H. Stevens, Helene Wagner
Maintainer: Jari Oksanen <jari.oksanen at oulu.fi>
Depends: permute (>= 0.7-8), lattice, R (>= 2.15.0)
-Suggests: parallel, scatterplot3d, tcltk
-Imports: MASS, rgl, cluster, mgcv
+Suggests: parallel, tcltk
+Imports: MASS, cluster, mgcv
Description: Ordination methods, diversity analysis and other
functions for community and vegetation ecologists.
License: GPL-2
Modified: pkg/vegan/NAMESPACE
===================================================================
--- pkg/vegan/NAMESPACE 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/NAMESPACE 2014-09-16 07:13:05 UTC (rev 2882)
@@ -16,10 +16,10 @@
mrpp, msoplot, mso, multipart, make.commsim, nestedbetajac, nestedbetasor, nestedchecker,
nesteddisc, nestedn0, nestednodf, nestedtemp, nullmodel, oecosimu,
ordiR2step, ordiarrows, ordicloud, ordicluster, ordiellipse, ordigrid,
-ordihull, ordilabel, ordiplot3d, ordiplot, ordipointlabel, ordiresids,
-ordirgl, ordisegments, ordispider, ordisplom, ordistep, ordisurf,
-orditkplot, orditorp, ordixyplot, orglpoints, orglsegments,
-orglspider, orgltext, pcnm, permatfull, permatswap, permutest,
+ordihull, ordilabel, ordiplot, ordipointlabel, ordiresids,
+ordisegments, ordispider, ordisplom, ordistep, ordisurf,
+orditkplot, orditorp, ordixyplot,
+pcnm, permatfull, permatswap, permutest,
poolaccum, postMDS, prc, prestondistr, prestonfit, procrustes,
protest, radfit, radlattice, rankindex, rarefy, rarecurve, raupcrick,
rda, renyiaccum, renyi, rrarefy, scores, scoverage,
@@ -45,8 +45,8 @@
export(as.fisher, as.mlm, as.preston, as.rad, fieller.MOStest,
fisher.alpha, kendall.global, kendall.post, make.cepnames,
mantel.correlog, mantel.partial, no.shared, rad.lognormal, rad.null,
-rad.preempt, rad.zipf, rad.zipfbrot, read.cep, rgl.isomap,
-rgl.renyiaccum, vif.cca)
+rad.preempt, rad.zipf, rad.zipfbrot, read.cep,
+vif.cca)
## Export panel functions
export(panel.ordi, panel.ordiarrows, panel.ordi3d, prepanel.ordi3d)
@@ -71,9 +71,9 @@
import(parallel)
import(tcltk)
importFrom(MASS, isoMDS, sammon, Shepard, mvrnorm)
-import(rgl)
importFrom(cluster, daisy)
-importFrom(mgcv, gam)
+## 's' must be imported in mgcv < 1.8-0 (not needed later)
+importFrom(mgcv, gam, s, te)
## Registration of S3 methods defined in vegan
# adipart: vegan
S3method(adipart, default)
Modified: pkg/vegan/R/CCorA.R
===================================================================
--- pkg/vegan/R/CCorA.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/CCorA.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -1,5 +1,5 @@
`CCorA` <-
- function(Y, X, stand.Y = FALSE, stand.X = FALSE, nperm = 0, ...)
+ function(Y, X, stand.Y = FALSE, stand.X = FALSE, permutations = 0, ...)
{
epsilon <- sqrt(.Machine$double.eps)
##
@@ -156,16 +156,12 @@
df2 <- (n - max(pp,qq) - 1)
Fval <- (PillaiTrace*df2)/((s-PillaiTrace)*df1)
p.Pillai <- pf(Fval, s*df1, s*df2, lower.tail=FALSE)
- if (length(nperm) == 1) {
- if (nperm > 0)
- permat <- t(replicate(nperm, permuted.index(n, ...)))
- } else {
- permat <- as.matrix(nperm)
- if (ncol(permat) != n)
- stop(gettextf("'permutations' have %d columns, but data have %d rows",
- ncol(permat), n))
- nperm <- nrow(permat)
- }
+ permat <- getPermuteMatrix(permutations, n, ...)
+ nperm <- nrow(permat)
+ if (ncol(permat) != n)
+ stop(gettextf("'permutations' have %d columns, but data have %d rows",
+ ncol(permat), n))
+
if (nperm > 0) {
p.perm <- sapply(1:nperm, function(indx, ...)
probPillai(Y[permat[indx,],] , X, n, S11.inv, S22.inv, s,
Modified: pkg/vegan/R/SSarrhenius.R
===================================================================
--- pkg/vegan/R/SSarrhenius.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/SSarrhenius.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -3,7 +3,7 @@
function(mCall, data, LHS)
{
xy <- sortedXyData(mCall[["area"]], LHS, data)
- value <- as.vector(coef(lm(log(xy[,"y"]) ~ log(xy[,"x"]))))
+ value <- as.vector(coef(lm(log(pmax(xy[,"y"],1)) ~ log(xy[,"x"]))))
value[1] <- exp(value[1])
names(value) <- mCall[c("k","z")]
value
Modified: pkg/vegan/R/adonis.R
===================================================================
--- pkg/vegan/R/adonis.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/adonis.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -90,58 +90,52 @@
) }
## Permutations
- if (length(permutations) == 1) {
- if (missing(strata))
- strata <- NULL
- p <- replicate(permutations,
- permuted.index(n, strata=strata))
- } else {
- p <- t(as.matrix(permutations))
- if (nrow(p) != n)
- stop(gettextf("'permutations' have %d columns, but data have %d rows",
- ncol(p), n))
- permutations <- ncol(p)
- }
-
- tH.s <- lapply(H.s, t)
- ## Apply permutations for each term
- ## This is the new f.test (2011-06-15) that uses fewer arguments
- ## Set first parallel processing for all terms
- if (is.null(parallel))
- parallel <- 1
- hasClus <- inherits(parallel, "cluster")
- isParal <- (hasClus || parallel > 1) && require(parallel)
- isMulticore <- .Platform$OS.type == "unix" && !hasClus
- if (isParal && !isMulticore && !hasClus) {
- parallel <- makeCluster(parallel)
- }
- if (isParal) {
- if (isMulticore) {
- f.perms <-
- sapply(1:nterms, function(i)
- unlist(mclapply(1:permutations, function(j)
- f.test(tH.s[[i]], G[p[,j], p[,j]],
- df.Exp[i], df.Res, tIH.snterm),
- mc.cores = parallel)))
+ p <- getPermuteMatrix(permutations, n, strata = strata)
+ permutations <- nrow(p)
+ if (permutations) {
+ tH.s <- lapply(H.s, t)
+ ## Apply permutations for each term
+ ## This is the new f.test (2011-06-15) that uses fewer arguments
+ ## Set first parallel processing for all terms
+ if (is.null(parallel))
+ parallel <- 1
+ hasClus <- inherits(parallel, "cluster")
+ isParal <- (hasClus || parallel > 1) && require(parallel)
+ isMulticore <- .Platform$OS.type == "unix" && !hasClus
+ if (isParal && !isMulticore && !hasClus) {
+ parallel <- makeCluster(parallel)
+ }
+ if (isParal) {
+ if (isMulticore) {
+ f.perms <-
+ sapply(1:nterms, function(i)
+ unlist(mclapply(1:permutations, function(j)
+ f.test(tH.s[[i]], G[p[j,], p[j,]],
+ df.Exp[i], df.Res, tIH.snterm),
+ mc.cores = parallel)))
+ } else {
+ f.perms <-
+ sapply(1:nterms, function(i)
+ parSapply(parallel, 1:permutations, function(j)
+ f.test(tH.s[[i]], G[p[j,], p[j,]],
+ df.Exp[i], df.Res, tIH.snterm)))
+ }
} else {
f.perms <-
- sapply(1:nterms, function(i)
- parSapply(parallel, 1:permutations, function(j)
- f.test(tH.s[[i]], G[p[,j], p[,j]],
- df.Exp[i], df.Res, tIH.snterm)))
+ sapply(1:nterms, function(i)
+ sapply(1:permutations, function(j)
+ f.test(tH.s[[i]], G[p[j,], p[j,]],
+ df.Exp[i], df.Res, tIH.snterm)))
}
- } else {
- f.perms <-
- sapply(1:nterms, function(i)
- sapply(1:permutations, function(j)
- f.test(tH.s[[i]], G[p[,j], p[,j]],
- df.Exp[i], df.Res, tIH.snterm)))
+ ## Close socket cluster if created here
+ if (isParal && !isMulticore && !hasClus)
+ stopCluster(parallel)
+ ## Round to avoid arbitrary P-values with tied data
+ f.perms <- round(f.perms, 12)
+ P <- (rowSums(t(f.perms) >= F.Mod)+1)/(permutations+1)
+ } else { # no permutations
+ f.perms <- P <- rep(NA, nterms)
}
- ## Close socket cluster if created here
- if (isParal && !isMulticore && !hasClus)
- stopCluster(parallel)
- ## Round to avoid arbitrary P-values with tied data
- f.perms <- round(f.perms, 12)
F.Mod <- round(F.Mod, 12)
SumsOfSqs = c(SS.Exp.each, SS.Res, sum(SS.Exp.each) + SS.Res)
tab <- data.frame(Df = c(df.Exp, df.Res, n-1),
@@ -149,8 +143,7 @@
MeanSqs = c(SS.Exp.each/df.Exp, SS.Res/df.Res, NA),
F.Model = c(F.Mod, NA,NA),
R2 = SumsOfSqs/SumsOfSqs[length(SumsOfSqs)],
- P = c((rowSums(t(f.perms) >= F.Mod)+1)/(permutations+1),
- NA, NA))
+ P = c(P, NA, NA))
rownames(tab) <- c(attr(attr(rhs.frame, "terms"), "term.labels")[u.grps],
"Residuals", "Total")
colnames(tab)[ncol(tab)] <- "Pr(>F)"
Modified: pkg/vegan/R/anosim.R
===================================================================
--- pkg/vegan/R/anosim.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/anosim.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -1,6 +1,6 @@
`anosim` <-
function (dat, grouping, permutations = 999,
- distance = "bray", strata, parallel = getOption("mc.cores"))
+ distance = "bray", strata = NULL, parallel = getOption("mc.cores"))
{
if (inherits(dat, "dist"))
x <- dat
@@ -35,39 +35,37 @@
tmp.ave <- tapply(x.rank, tmp.within, mean)
-diff(tmp.ave)/div
}
- if (length(permutations) == 1) {
- if (permutations > 0) {
- arg <- if (missing(strata)) NULL else strata
- permat <- t(replicate(permutations, permuted.index(N, strata = arg)))
- }
- } else {
- permat <- as.matrix(permutations)
- if (ncol(permat) != N)
- stop(gettextf("'permutations' have %d columns, but data have %d rows",
- ncol(permat), N))
- permutations <- nrow(permat)
- }
- ## Parallel processing
- if (is.null(parallel))
- parallel <- 1
- hasClus <- inherits(parallel, "cluster")
- if ((hasClus || parallel > 1) && require(parallel)) {
- if(.Platform$OS.type == "unix" && !hasClus) {
- perm <- unlist(mclapply(1:permutations, function(i, ...)
- ptest(permat[i,]),
- mc.cores = parallel))
- } else {
- if (!hasClus) {
- parallel <- makeCluster(parallel)
+ permat <- getPermuteMatrix(permutations, N, strata = strata)
+ if (ncol(permat) != N)
+ stop(gettextf("'permutations' have %d columns, but data have %d rows",
+ ncol(permat), N))
+ permutations <- nrow(permat)
+
+ if (permutations) {
+ ## Parallel processing
+ if (is.null(parallel))
+ parallel <- 1
+ hasClus <- inherits(parallel, "cluster")
+ if ((hasClus || parallel > 1) && require(parallel)) {
+ if(.Platform$OS.type == "unix" && !hasClus) {
+ perm <- unlist(mclapply(1:permutations, function(i, ...)
+ ptest(permat[i,]),
+ mc.cores = parallel))
+ } else {
+ if (!hasClus) {
+ parallel <- makeCluster(parallel)
+ }
+ perm <- parRapply(parallel, permat, ptest)
+ if (!hasClus)
+ stopCluster(parallel)
}
- perm <- parRapply(parallel, permat, ptest)
- if (!hasClus)
- stopCluster(parallel)
+ } else {
+ perm <- sapply(1:permutations, function(i) ptest(permat[i,]))
}
- } else {
- perm <- sapply(1:permutations, function(i) ptest(permat[i,]))
+ p.val <- (1 + sum(perm >= statistic))/(1 + permutations)
+ } else { # no permutations
+ p.val <- perm <- NA
}
- p.val <- (1 + sum(perm >= statistic))/(1 + permutations)
sol$signif <- p.val
sol$perm <- perm
sol$permutations <- permutations
Modified: pkg/vegan/R/anova.cca.R
===================================================================
--- pkg/vegan/R/anova.cca.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/anova.cca.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -5,31 +5,12 @@
cutoff = 1, scope = NULL)
{
model <- match.arg(model)
- ## permutations is either a single number, a how() structure or a
## permutation matrix
- if (length(permutations) == 1) {
- nperm <- permutations
- permutations <- how(nperm = nperm)
- }
- if (!is.null(strata)) {
- if (!inherits(permutations, "how"))
- stop("'strata' can be used only with simple permutation or with 'how()'")
- if (!is.null(permutations$block))
- stop("'strata' cannot be applied when 'blocks' are defined in 'how()'")
- setBlocks(permutations) <- strata
- }
- ## now permutations is either a how() structure or a permutation
- ## matrix. Make it to a matrix if it is "how"
- if (inherits(permutations, "how")) {
- permutations <- shuffleSet(nrow(object$CA$u),
- control = permutations)
- seed <- attr(permutations, "seed")
- control <- attr(permutations, "control")
- }
- else # we got a permutation matrix and seed & control are unknown
- seed <- control <- NULL
+ N <- nrow(object$CA$u)
+ permutations <- getPermuteMatrix(permutations, N, strata = strata)
+ seed <- attr(permutations, "seed")
+ control <- attr(permutations, "control")
nperm <- nrow(permutations)
- ## stop permutations block
## see if this was a list of ordination objects
dotargs <- list(...)
## we do not want to give dotargs to anova.ccalist, but we
Modified: pkg/vegan/R/envfit.default.R
===================================================================
--- pkg/vegan/R/envfit.default.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/envfit.default.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -1,5 +1,5 @@
`envfit.default` <-
- function (ord, env, permutations = 999, strata, choices = c(1, 2),
+ function (ord, env, permutations = 999, strata = NULL, choices = c(1, 2),
display = "sites", w = weights(ord), na.rm = FALSE, ...)
{
weights.default <- function(object, ...) NULL
@@ -18,18 +18,11 @@
}
## make permutation matrix for all variables handled in the next loop
nr <- nrow(X)
- if (length(permutations) == 1) {
- if (permutations > 0 ) {
- arg <- if (missing(strata)) NULL else strata
- permutations <- t(replicate(permutations,
- permuted.index(nr, strata=arg)))
- }
- } else {
- permat <- as.matrix(permutations)
- if (ncol(permat) != nr)
- stop(gettextf("'permutations' have %d columns, but data have %d rows",
- ncol(permat), nr))
- }
+ permat <- getPermuteMatrix(permutations, nr, strata = strata)
+ if (ncol(permat) != nr)
+ stop(gettextf("'permutations' have %d columns, but data have %d rows",
+ ncol(permat), nr))
+
if (is.data.frame(env)) {
vects <- sapply(env, is.numeric)
if (any(!vects)) { # have factors
Modified: pkg/vegan/R/factorfit.R
===================================================================
--- pkg/vegan/R/factorfit.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/factorfit.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -1,5 +1,5 @@
`factorfit` <-
- function (X, P, permutations = 0, strata, w, ...)
+ function (X, P, permutations = 0, strata = NULL, w, ...)
{
P <- as.data.frame(P)
## Check that all variables are factors, and coerce if necessary
@@ -24,16 +24,9 @@
sol <- centroids.cca(X, P, w)
var.id <- rep(names(P), sapply(P, nlevels))
## make permutation matrix for all variables handled in the next loop
- if (length(permutations) == 1) {
- if (permutations > 0) {
- arg <- if (missing(strata)) NULL else strata
- permat <- t(replicate(permutations,
- permuted.index(NR, strata=arg)))
- }
- } else {
- permat <- as.matrix(permutations)
- permutations <- nrow(permutations)
- }
+ permat <- getPermuteMatrix(permutations, NR, strata = strata)
+ permutations <- nrow(permat)
+
for (i in 1:length(P)) {
A <- as.integer(P[[i]])
NL <- nlevels(P[[i]])
Added: pkg/vegan/R/getPermuteMatrix.R
===================================================================
--- pkg/vegan/R/getPermuteMatrix.R (rev 0)
+++ pkg/vegan/R/getPermuteMatrix.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -0,0 +1,36 @@
+### Interface to the permute package
+
+### input can be (1) a single number giving the number of
+### permutations, (2) a how() structure for control parameter in
+### permute::shuffleSet, or (3) a permutation matrix which is returned
+### as is. In addition, there can be a 'strata' argument which will
+### modify case (1). The number of shuffled items must be given in 'N'.
+
+`getPermuteMatrix` <-
+ function(perm, N, strata = NULL)
+{
+ ## 'perm' is either a single number, a how() structure or a
+ ## permutation matrix
+ if (length(perm) == 1) {
+ perm <- how(nperm = perm)
+ }
+ ## apply 'strata'
+ if (!is.null(strata)) {
+ if (!inherits(perm, "how")) # 'perm' is a matrix
+ stop("'strata' can be used only with simple permutation or with 'how()'")
+ if (!is.null(getBlocks(perm)))
+ stop("'strata' cannot be applied when 'blocks' are defined in 'how()'")
+ setBlocks(perm) <- strata
+ }
+ ## now 'perm' is either a how() or a matrix
+ if (inherits(perm, "how"))
+ perm <- shuffleSet(N, control = perm)
+ ## now 'perm' is a matrix (or always was). If it is a plain
+ ## matrix, set minimal attributes for printing. This is a dirty
+ ## kluge: should be handled more cleanly.
+ if (is.null(attr(perm, "control")))
+ attr(perm, "control") <-
+ structure(list(within=list(type="supplied matrix"),
+ nperm = nrow(perm)), class = "how")
+ perm
+}
Modified: pkg/vegan/R/howHead.R
===================================================================
--- pkg/vegan/R/howHead.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/howHead.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -2,9 +2,9 @@
### permute:::print.how, but only displays non-default choices in how().
`howHead` <- function(x, ...)
{
- ## this should always work
+ ## print nothing is this not 'how'
if (is.null(x) || !inherits(x, "how"))
- stop("not a 'how' object: contact the package maintainer")
+ return()
## collect header
head <- NULL
## blocks
Modified: pkg/vegan/R/mantel.R
===================================================================
--- pkg/vegan/R/mantel.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/mantel.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -1,6 +1,6 @@
`mantel` <-
function (xdis, ydis, method = "pearson", permutations = 999,
- strata, na.rm = FALSE, parallel = getOption("mc.cores"))
+ strata = NULL, na.rm = FALSE, parallel = getOption("mc.cores"))
{
xdis <- as.dist(xdis)
ydis <- as.vector(as.dist(ydis))
@@ -17,19 +17,12 @@
spearman = "Spearman's rank correlation rho",
variant)
N <- attr(xdis, "Size")
- if (length(permutations) == 1) {
- if (permutations > 0) {
- arg <- if (missing(strata)) NULL else strata
- permat <- t(replicate(permutations,
- permuted.index(N, strata = arg)))
- }
- } else {
- permat <- as.matrix(permutations)
- if (ncol(permat) != N)
- stop(gettextf("'permutations' have %d columns, but data have %d observations",
- ncol(permat), N))
- permutations <- nrow(permutations)
- }
+ permat <- getPermuteMatrix(permutations, N, strata = strata)
+ if (ncol(permat) != N)
+ stop(gettextf("'permutations' have %d columns, but data have %d observations",
+ ncol(permat), N))
+ permutations <- nrow(permat)
+
if (permutations) {
perm <- numeric(permutations)
## asdist as an index selects lower diagonal like as.dist,
Modified: pkg/vegan/R/mantel.partial.R
===================================================================
--- pkg/vegan/R/mantel.partial.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/mantel.partial.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -1,6 +1,6 @@
`mantel.partial` <-
function (xdis, ydis, zdis, method = "pearson", permutations = 999,
- strata, na.rm = FALSE, parallel = getOption("mc.cores"))
+ strata = NULL, na.rm = FALSE, parallel = getOption("mc.cores"))
{
part.cor <- function(rxy, rxz, ryz) {
(rxy - rxz * ryz)/sqrt(1-rxz*rxz)/sqrt(1-ryz*ryz)
@@ -24,19 +24,12 @@
variant)
statistic <- part.cor(rxy, rxz, ryz)
N <- attr(xdis, "Size")
- if (length(permutations) == 1) {
- if (permutations > 0) {
- arg <- if(missing(strata)) NULL else strata
- permat <- t(replicate(permutations,
- permuted.index(N, strata = arg)))
- }
- } else {
- permat <- as.matrix(permutations)
- if (ncol(permat) != N)
- stop(gettextf("'permutations' have %d columns, but data have %d observations",
- ncol(permat), N))
- permutations <- nrow(permutations)
- }
+ permat <- getPermuteMatrix(permutations, N, strata = strata)
+ if (ncol(permat) != N)
+ stop(gettextf("'permutations' have %d columns, but data have %d observations",
+ ncol(permat), N))
+ permutations <- nrow(permat)
+
if (permutations) {
N <- attr(xdis, "Size")
perm <- rep(0, permutations)
Modified: pkg/vegan/R/mrpp.R
===================================================================
--- pkg/vegan/R/mrpp.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/mrpp.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -1,6 +1,7 @@
-"mrpp" <-
-function (dat, grouping, permutations = 999, distance = "euclidean",
- weight.type = 1, strata, parallel = getOption("mc.cores"))
+`mrpp` <-
+ function (dat, grouping, permutations = 999, distance = "euclidean",
+ weight.type = 1, strata = NULL,
+ parallel = getOption("mc.cores"))
{
classmean <- function(ind, dmat, indls) {
sapply(indls, function(x)
@@ -37,41 +38,43 @@
## significance test for it. Keep the item in reserve for
## possible later re-inclusion.
CS <- NA
- if (length(permutations) == 1) {
- if (missing(strata))
- strata <- NULL
- perms <- sapply(1:permutations,
- function(x) grouping[permuted.index(N, strata = strata)])
- } else {
+ permutations <- getPermuteMatrix(permutations, N, strata = strata)
+ if (ncol(permutations) != N)
+ stop(gettextf("'permutations' have %d columns, but data have %d rows",
+ ncol(permutations), N))
+
+
+ if(nrow(permutations)) {
perms <- apply(permutations, 1, function(indx) grouping[indx])
permutations <- ncol(perms)
- if (nrow(perms) != N)
- stop(gettextf("'permutations' have %d columns, but data have %d rows",
- ncol(perms), N))
- }
- ## Parallel processing
- if (is.null(parallel))
- parallel <- 1
- hasClus <- inherits(parallel, "cluster")
- if ((hasClus || parallel > 1) && require(parallel)) {
- if(.Platform$OS.type == "unix" && !hasClus) {
- m.ds <- unlist(mclapply(1:permutations, function(i, ...)
- mrpp.perms(perms[,i], dmat, indls, w),
- mc.cores = parallel))
+
+ ## Parallel processing
+ if (is.null(parallel))
+ parallel <- 1
+ hasClus <- inherits(parallel, "cluster")
+ if ((hasClus || parallel > 1) && require(parallel)) {
+ if(.Platform$OS.type == "unix" && !hasClus) {
+ m.ds <- unlist(mclapply(1:permutations, function(i, ...)
+ mrpp.perms(perms[,i], dmat, indls, w),
+ mc.cores = parallel))
+ } else {
+ if (!hasClus) {
+ parallel <- makeCluster(parallel)
+ }
+ m.ds <- parCapply(parallel, perms, function(x)
+ mrpp.perms(x, dmat, indls, w))
+ if (!hasClus)
+ stopCluster(parallel)
+ }
} else {
- if (!hasClus) {
- parallel <- makeCluster(parallel)
- }
- m.ds <- parCapply(parallel, perms, function(x)
- mrpp.perms(x, dmat, indls, w))
- if (!hasClus)
- stopCluster(parallel)
+ m.ds <- apply(perms, 2, function(x) mrpp.perms(x, dmat, indls, w))
}
- } else {
- m.ds <- apply(perms, 2, function(x) mrpp.perms(x, dmat, indls, w))
+ p <- (1 + sum(del >= m.ds))/(permutations + 1)
+ r2 <- 1 - del/E.del
+ } else { # no permutations
+ m.ds <- p <- r2 <- NA
+ permutations <- 0
}
- p <- (1 + sum(del >= m.ds))/(permutations + 1)
- r2 <- 1 - del/E.del
out <- list(call = match.call(), delta = del, E.delta = E.del, CS = CS,
n = ncl, classdelta = classdel,
Pvalue = p, A = r2, distance = distance, weight.type = weight.type,
Modified: pkg/vegan/R/mso.R
===================================================================
--- pkg/vegan/R/mso.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/mso.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -1,6 +1,6 @@
`mso` <-
function (object.cca, object.xy, grain = 1, round.up = FALSE,
- permutations = FALSE)
+ permutations = 0)
{
if (inherits(object.cca, "mso")) {
rm <- which(class(object.cca) == "mso")
@@ -58,27 +58,27 @@
H), mean)
object$vario <- cbind(object$vario, All = test$ca, CA = test$ca)
}
- if (permutations) {
- ##require(base)
+ permat <- getPermuteMatrix(permutations, nrow(object$CA$Xbar))
+ nperm <- nrow(permat)
+ if (nperm) {
object$H.test <- matrix(0, length(object$H), nrow(object$vario))
for (i in 1:nrow(object$vario)) {
object$H.test[, i] <- as.numeric(object$H == object$vario$H[i])
}
- xdis <- dist(object$CA$Xbar)^2
- N <- attr(xdis, "Size")
- statistic <- abs(cor(as.vector(xdis), object$H.test))
- perm <- matrix(0, length(statistic), permutations)
- for (i in 1:permutations) {
- take <- sample(N, N)
- permvec <- as.vector(as.dist(as.matrix(xdis)[take,
- take]))
- perm[, i] <- abs(cor(permvec, object$H.test))
+ xdis <- as.matrix(dist(object$CA$Xbar)^2)
+ ## taking lower triangle is faster than as.dist() because it
+ ## does not set attributes
+ ltri <- lower.tri(xdis)
+ statistic <- abs(cor(as.vector(xdis[ltri]), object$H.test))
+ permfunc <- function(k) {
+ permvec <- as.vector(xdis[k,k][ltri])
+ abs(cor(permvec, object$H.test))
}
- object$vario$CA.signif <- apply((perm >= matrix(statistic,
- nrow(perm), ncol(perm)))/permutations, 1, sum)
+ perm <- sapply(1:nperm, function(take) permfunc(permat[take,]))
+ object$vario$CA.signif <-
+ (rowSums(sweep(perm, 1, statistic, ">=")) + 1)/(nperm + 1)
}
object$call <- match.call()
class(object) <- c("mso", class(object))
object
}
-
Modified: pkg/vegan/R/nesteddisc.R
===================================================================
--- pkg/vegan/R/nesteddisc.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/nesteddisc.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -28,7 +28,8 @@
## Function to evaluate discrepancy
FUN <- function(x) sum(comm[col(comm)[,x] <= rowSums(comm)] == 0)
Ad <- FUN(x)
- ## Go through all le-items and permute ties
+ ## Go through all le-items and permute ties. Functions allPerms
+ ## and shuffleSet are in permute package.
for (i in 1:length(le)) {
if (le[i] > 1) {
take <- x
@@ -49,7 +50,7 @@
## duplicated orders
else {
ties <- TRUE
- perm <- t(replicate(niter, permuted.index(le[i])))
+ perm <- shuffleSet(le[i], niter)
perm <- perm + cle[i]
}
vals <- sapply(1:nrow(perm), function(j) {
Modified: pkg/vegan/R/oecosimu.R
===================================================================
--- pkg/vegan/R/oecosimu.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/oecosimu.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -93,7 +93,9 @@
if ((hasClus || parallel > 1) && require(parallel)) {
if(.Platform$OS.type == "unix" && !hasClus) {
for (i in seq_len(nbatch)) {
- x <- simulate(nm, nsim = batches[i], thin = thin)
+ ## simulate if no simmat_in
+ if(!simmat_in)
+ x <- simulate(nm, nsim = batches[i], thin = thin)
tmp <- mclapply(seq_len(batches[i]),
function(j)
applynestfun(x[,,j], fun=nestfun,
@@ -109,7 +111,8 @@
clusterEvalQ(parallel, library(vegan))
}
for(i in seq_len(nbatch)) {
- x <- simulate(nm, nsim = batches[i], thin = thin)
+ if (!simmat_in)
+ x <- simulate(nm, nsim = batches[i], thin = thin)
simind <- cbind(simind,
parApply(parallel, x, 3, function(z)
applynestfun(z, fun = nestfun,
@@ -120,7 +123,9 @@
}
} else {
for(i in seq_len(nbatch)) {
- x <- simulate(nm, nsim = batches[i], thin = thin)
+ ## do not simulate if x was already a simulation
+ if(!simmat_in)
+ x <- simulate(nm, nsim = batches[i], thin = thin)
simind <- cbind(simind, apply(x, 3, applynestfun, fun = nestfun,
statistic = statistic, ...))
}
Deleted: pkg/vegan/R/ordiplot3d.R
===================================================================
--- pkg/vegan/R/ordiplot3d.R 2014-09-05 11:55:04 UTC (rev 2881)
+++ pkg/vegan/R/ordiplot3d.R 2014-09-16 07:13:05 UTC (rev 2882)
@@ -1,92 +0,0 @@
-`ordiplot3d` <-
- function (object, display = "sites", choices = 1:3, ax.col = 2,
- arr.len = 0.1, arr.col = 4, envfit, xlab, ylab, zlab, ...)
-{
- require(scatterplot3d) || stop("Requires package 'scatterplot3d'")
- x <- scores(object, display = display, choices = choices, ...)
- if (missing(xlab)) xlab <- colnames(x)[1]
- if (missing(ylab)) ylab <- colnames(x)[2]
- if (missing(zlab)) zlab <- colnames(x)[3]
- ### scatterplot3d does not allow setting equal aspect ratio. We
- ### try to compensate this by setting equal limits for all axes
- ### and hoping the graph is more or less square so that the lines
- ### come correctly out.
- rnge <- apply(x, 2, range)
- scl <- c(-0.5, 0.5) * max(apply(rnge, 2, diff))
- pl <- ordiArgAbsorber(x[, 1], x[, 2], x[, 3],
- xlab = xlab, ylab = ylab, zlab = zlab,
- xlim = mean(rnge[,1]) + scl,
- ylim = mean(rnge[,2]) + scl,
- zlim = mean(rnge[,3]) + scl,
- FUN = "scatterplot3d", ...)
- pl$points3d(range(x[, 1]), c(0, 0), c(0, 0), type = "l",
- col = ax.col)
- pl$points3d(c(0, 0), range(x[, 2]), c(0, 0), type = "l",
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/vegan -r 2882
More information about the Vegan-commits
mailing list