[Vegan-commits] r1876 - in pkg/vegan: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Sep 23 07:14:29 CEST 2011
Author: psolymos
Date: 2011-09-23 07:14:28 +0200 (Fri, 23 Sep 2011)
New Revision: 1876
Removed:
pkg/vegan/R/permatfull1.R
pkg/vegan/R/permatswap1.R
Modified:
pkg/vegan/NAMESPACE
pkg/vegan/R/permatfull.R
pkg/vegan/R/permatswap.R
pkg/vegan/man/permatfull.Rd
Log:
permat* uses new nullmodel interface
Modified: pkg/vegan/NAMESPACE
===================================================================
--- pkg/vegan/NAMESPACE 2011-09-22 21:08:49 UTC (rev 1875)
+++ pkg/vegan/NAMESPACE 2011-09-23 05:14:28 UTC (rev 1876)
@@ -20,7 +20,7 @@
ordiplot, ordipointlabel, ordiresids, ordirgl, ordisegments,
ordispider, ordisplom, ordistep, ordisurf, orditkplot, orditorp,
ordixyplot, orglpoints, orglsegments, orglspider, orgltext,
-pcnm, permatfull, permatswap, permatfull1, permatswap1,
+pcnm, permatfull, permatswap,
permutest, poolaccum, postMDS, prc,
prestondistr, prestonfit, procrustes, protest, radfit, radlattice,
rankindex, rarefy,raupcrick, rda, renyiaccum, renyi, rrarefy, scores,
Modified: pkg/vegan/R/permatfull.R
===================================================================
--- pkg/vegan/R/permatfull.R 2011-09-22 21:08:49 UTC (rev 1875)
+++ pkg/vegan/R/permatfull.R 2011-09-23 05:14:28 UTC (rev 1876)
@@ -1,23 +1,46 @@
## permatfull function
`permatfull` <-
-function(m, fixedmar="both", shuffle="both", strata=NULL, mtype="count", times=99)
+function(m, fixedmar="both", shuffle="both",
+strata=NULL, mtype="count", times=99, ...)
{
mtype <- match.arg(mtype, c("prab", "count"))
shuffle <- match.arg(shuffle, c("ind", "samp", "both"))
fixedmar <- match.arg(fixedmar, c("none", "rows", "columns", "both"))
m <- as.matrix(m)
-
- if (is.null(strata))
- str <- as.factor(rep(1, nrow(m)))
- else str <- as.factor(strata)[drop = TRUE]
-
- levels(str) <- 1:length(unique(str))
- str <- as.numeric(str)
+ str <- if (is.null(strata))
+ 1 else as.integer(as.factor(strata)[drop = TRUE])
+ levstr <- unique(str)
nstr <- length(unique(str))
- if (any(tapply(str,list(str),length) == 1))
+ if (!is.null(strata) && any(table(str) < 2))
stop("strata should contain at least 2 observations")
-
- perm <- replicate(times, permatfull1(m, fixedmar, shuffle, strata, mtype), simplify=FALSE)
+ ALGO <- switch(fixedmar,
+ "none" = "r00",
+ "rows" = "r0",
+ "columns" = "c0",
+ "both" = ifelse(mtype=="prab", "quasiswap", "r2dtable"))
+ if (mtype=="count") {
+ if (fixedmar!="both")
+ ALGO <- paste(ALGO, shuffle, sep="_")
+ }
+ if (is.null(strata)) {
+ tmp <- simulate(nullmodel(m, ALGO), nsim=times, ...)
+ perm <- vector("list", times)
+ for (i in seq_len(times))
+ perm[[i]] <- tmp[,,i]
+ } else {
+ perm <- vector("list", times)
+ tmp <- vector("list", length(unique(strata)))
+ for (j in seq_len(nstr)) {
+ tmp[[j]] <- simulate(nullmodel(m[strata==levstr[j],], ALGO),
+ nsim=times, ...)
+ }
+ for (i in seq_len(times)) {
+ perm[[i]] <- array(0, dim(m))
+ for (j in seq_len(nstr)) {
+ perm[[i]][strata==levstr[j],] <- tmp[[j]][,,i]
+ }
+ }
+ }
if (fixedmar == "both")
shuffle <- NA
if (mtype == "prab")
Deleted: pkg/vegan/R/permatfull1.R
===================================================================
--- pkg/vegan/R/permatfull1.R 2011-09-22 21:08:49 UTC (rev 1875)
+++ pkg/vegan/R/permatfull1.R 2011-09-23 05:14:28 UTC (rev 1876)
@@ -1,66 +0,0 @@
-## permatfull1 returns 1 permuted matrix
-## this function is called by permatfull
-`permatfull1` <-
-function(m, fixedmar="both", shuffle="both", strata=NULL, mtype="count")
-{
- ## internal functions
- indshuffle <- function(x)
- {
- N <- length(x)
- n <- sum(x)
- out <- numeric(N)
- names(out) <- 1:N
- y <- table(sample(1:N, n, replace = TRUE))
- out[names(out) %in% names(y)] <- y
- names(out) <- NULL
- out
- }
- bothshuffle <- function(x, y=1)
- {
- x[x!=0] <- indshuffle(x[x!=0] - y) + y
- sample(x)
- }
-
- if (!identical(all.equal(m, round(m)), TRUE))
- stop("function accepts only integers (counts)")
- mtype <- match.arg(mtype, c("prab", "count"))
- shuffle <- match.arg(shuffle, c("ind", "samp", "both"))
- count <- mtype == "count"
- fixedmar <- match.arg(fixedmar, c("none", "rows", "columns", "both"))
- sample.fun <- switch(shuffle,
- "ind"=indshuffle,
- "samp"=sample,
- "both"=bothshuffle)
- m <- as.matrix(m)
- n.row <- nrow(m)
- n.col <- ncol(m)
- if (mtype == "prab")
- m <- ifelse(m > 0, 1, 0)
-
- if (is.null(strata))
- str <- as.factor(rep(1, n.row))
- else str <- as.factor(strata)[drop = TRUE]
-
- levels(str) <- 1:length(unique(str))
- str <- as.numeric(str)
- nstr <- length(unique(str))
- if (any(tapply(str,list(str),length) == 1))
- stop("strata should contain at least 2 observations")
- perm <- matrix(0, n.row, n.col)
- for (j in 1:nstr) {
- id <- which(str == j)
- if (fixedmar == "none")
- if (count) perm[id,] <- matrix(sample.fun(array(m[id,])), length(id), n.col)
- else perm[id,] <- commsimulator(m[id,], method="r00")
- if (fixedmar == "rows")
- if (count) perm[id,] <- t(apply(m[id,], 1, sample.fun))
- else perm[id,] <- commsimulator(m[id,], method="r0")
- if (fixedmar == "columns")
- if (count) perm[id,] <- apply(m[id,], 2, sample.fun)
- else perm[id,] <- commsimulator(m[id,], method="c0")
- if (fixedmar == "both")
- if (count) perm[id,] <- r2dtable(1, apply(m[id,], 1, sum), apply(m[id,], 2, sum))[[1]]
- else perm[id,] <- commsimulator(m[id,], method="quasiswap")
- }
- perm
-}
Modified: pkg/vegan/R/permatswap.R
===================================================================
--- pkg/vegan/R/permatswap.R 2011-09-22 21:08:49 UTC (rev 1875)
+++ pkg/vegan/R/permatswap.R 2011-09-23 05:14:28 UTC (rev 1876)
@@ -1,51 +1,79 @@
## permatswap function
`permatswap` <-
function(m, method="quasiswap", fixedmar="both", shuffle="both", strata=NULL,
- mtype="count", times=99, burnin = 0, thin = 1)
+mtype="count", times=99, burnin = 0, thin = 1, ...)
{
mtype <- match.arg(mtype, c("prab", "count"))
fixedmar <- match.arg(fixedmar, c("rows", "columns", "both"))
shuffle <- match.arg(shuffle, c("samp", "both"))
count <- mtype == "count"
m <- as.matrix(m)
-
+ str <- if (is.null(strata))
+ 1 else as.integer(as.factor(strata)[drop = TRUE])
+ levstr <- unique(str)
+ nstr <- length(unique(str))
+ if (!is.null(strata) && any(table(str) < 2))
+ stop("strata should contain at least 2 observations")
## evaluating algo type
if (count) {
method <- match.arg(method, c("swap", "quasiswap", "swsh", "abuswap"))
- ## warning if swapcount is to be used
if (method == "swap") {
warning("quantitative swap method may not yield random null models, use only to study its properties")
isSeq <- TRUE
+ if (fixedmar != "both")
+ stop("if 'method=\"swap\"', 'fixedmar' must be \"both\"")
} else {
if (method == "abuswap") {
+ if (fixedmar == "both")
+ stop("if 'method=\"abuswap\"', 'fixedmar' must not be \"both\"")
+ direct <- if (fixedmar == "columns")
+ 0 else 1
isSeq <- TRUE
} else {
isSeq <- FALSE
+ if (method != "swsh" && fixedmar != "both")
+ stop("'fixedmar' must be \"both\"")
}
}
+ if (method %in% c("swap", "quasiswap"))
+ ALGO <- paste(method, "count", sep="_")
+ if (method == "abuswap")
+ ALGO <- paste(method, substr(fixedmar, 1, 1), sep="_")
+ if (method == "swsh") {
+ if (fixedmar=="both")
+ stop("if 'method=\"swsh\"', 'fixedmar' must not be \"both\"")
+ ALGO <- if (fixedmar=="none") {
+ paste(method, shuffle, sep="_")
+ } else {
+ paste(method, shuffle, substr(fixedmar, 1, 1), sep="_")
+ }
+ }
} else {
+ if (fixedmar != "both")
+ stop("if 'mtype=\"prab\"', 'fixedmar' must be \"both\"")
method <- match.arg(method, c("swap", "quasiswap", "tswap", "backtracking"))
isSeq <- method != "quasiswap"
+ ALGO <- method
}
-
- ## sequential algos: might have burnin
- if (isSeq) {
+ if (is.null(strata)) {
+ tmp <- simulate(nullmodel(m, ALGO),
+ nsim=times, burnin=burnin, thin=thin, ...)
perm <- vector("list", times)
- ## with burnin
- perm[[1]] <- permatswap1(m, method, fixedmar, shuffle, strata, mtype, burnin+thin)
- for (i in 2:times)
- perm[[i]] <- permatswap1(perm[[i-1]], method, fixedmar, shuffle, strata, mtype, thin)
- ## non-sequential algos: no burnin required
+ for (i in seq_len(times))
+ perm[[i]] <- tmp[,,i]
} else {
- if (burnin > 0)
- warning("Non sequential algorithm used: 'burnin' argument ignored")
- burnin <- 0
- if (thin != 1)
- warning("Non sequential algorithm used: 'thin' value set to 1")
- thin <- 1
- perm <- replicate(times,
- permatswap1(m, method, fixedmar, shuffle, strata, mtype, thin),
- simplify=FALSE)
+ perm <- vector("list", times)
+ tmp <- vector("list", length(unique(strata)))
+ for (j in seq_len(nstr)) {
+ tmp[[j]] <- simulate(nullmodel(m[strata==levstr[j],], ALGO),
+ nsim=times, burnin=burnin, thin=thin, ...)
+ }
+ for (i in seq_len(times)) {
+ perm[[i]] <- array(0, dim(m))
+ for (j in seq_len(nstr)) {
+ perm[[i]][strata==levstr[j],] <- tmp[[j]][,,i]
+ }
+ }
}
if (mtype == "prab")
m <- ifelse(m > 0, 1, 0)
Deleted: pkg/vegan/R/permatswap1.R
===================================================================
--- pkg/vegan/R/permatswap1.R 2011-09-22 21:08:49 UTC (rev 1875)
+++ pkg/vegan/R/permatswap1.R 2011-09-23 05:14:28 UTC (rev 1876)
@@ -1,136 +0,0 @@
-## permatswap1 returns 1 permuted matrix
-## this function is called by permatswap
-`permatswap1` <-
-function(m, method="quasiswap", fixedmar="both", shuffle="both", strata=NULL,
- mtype="count", thin = 1)
-{
- ## internal functions
- indshuffle <- function(x)
- {
- N <- length(x)
- n <- sum(x)
- out <- numeric(N)
- names(out) <- 1:N
- y <- table(sample(1:N, n, replace = TRUE))
- out[names(out) %in% names(y)] <- y
- names(out) <- NULL
- out
- }
- bothshuffle <- function(x, y=1)
- {
- x[x!=0] <- indshuffle(x[x!=0] - y) + y
- sample(x)
- }
- if (!identical(all.equal(m, round(m)), TRUE))
- stop("function accepts only integers (counts)")
- mtype <- match.arg(mtype, c("prab", "count"))
- fixedmar <- match.arg(fixedmar, c("rows", "columns", "both"))
- shuffle <- match.arg(shuffle, c("samp", "both"))
- count <- mtype == "count"
- if (thin < 1)
- stop("'thin' must be >= 1")
- if (count) {
- method <- match.arg(method, c("swap", "quasiswap", "swsh", "abuswap"))
- if (method == "swap") {
- isSeq <- TRUE
- if (fixedmar != "both")
- stop("if 'method=\"swap\"', 'fixedmar' must be \"both\"")
- } else {
- if (method == "abuswap") {
- if (fixedmar == "both")
- stop("if 'method=\"abuswap\"', 'fixedmar' must not be \"both\"")
- direct <- if (fixedmar == "columns")
- 0 else 1
- isSeq <- TRUE
- } else {
- isSeq <- FALSE
- if (fixedmar != "both")
- stop("'fixedmar' must be \"both\"")
- }
- }
- } else {
- if (fixedmar != "both")
- stop("if 'mtype=\"prab\"', 'fixedmar' must be \"both\"")
- method <- match.arg(method, c("swap", "quasiswap", "tswap", "backtracking"))
- isSeq <- method != "quasiswap"
- }
-
- m <- as.matrix(m)
- att <- attributes(m)
- n.row <- nrow(m)
- n.col <- ncol(m)
- if (mtype == "prab")
- m <- ifelse(m > 0, 1, 0)
-
- if (is.null(strata))
- str <- as.factor(rep(1, n.row))
- else str <- as.factor(strata)[drop = TRUE]
-
- levels(str) <- 1:length(unique(str))
- str <- as.numeric(str)
- nstr <- length(unique(str))
- if (any(tapply(str,list(str),length) == 1))
- stop("strata should contain at least 2 observations")
-
- perm <- matrix(0, n.row, n.col)
-
- for (j in 1:nstr) {
- id <- which(str == j)
- temp <- m[id,]
- nn.row <- nrow(m[id,])
- nn.col <- ncol(m[id,])
- if (isSeq) {
- if (count) {
- if (method == "swap")
- perm[id,] <- .C("swapcount",
- m = as.integer(temp),
- as.integer(nn.row),
- as.integer(nn.col),
- as.integer(thin),
- PACKAGE = "vegan")$m
- if (method == "abuswap")
- perm[id,] <- .C("abuswap",
- m = as.double(temp),
- as.integer(nn.row),
- as.integer(nn.col),
- as.integer(thin),
- as.integer(direct),
- PACKAGE = "vegan")$m
- } else {
- perm[id,] <- commsimulator(temp, method=method, thin=thin)
- }
- } else {
- if (method != "swsh") {
- r2tabs <- r2dtable(1, rowSums(m[id,]), colSums(m[id,]))[[1]]
- } else {
- tempPos <- temp[temp > 0]
- }
- if (count) {
- if (method != "swsh") {
- ms <- sum(m[id,] > 0)
- tmp <- r2tabs
- ## if fills are equal, no need to restore fill
- if (sum(tmp > 0) != ms) {
- tmp <- .C("rswapcount",
- m = as.integer(tmp),
- as.integer(nn.row),
- as.integer(nn.col),
- as.integer(ms),
- PACKAGE="vegan")$m
- }
- perm[id,] <- matrix(tmp, nrow(perm[id,]), ncol(perm[id,]))
- } else { # method == "swsh"
- tmp <- commsimulator(temp, method="quasiswap")
- if (shuffle == "samp") {
- tmp[tmp > 0] <- sample(tempPos)
- } else {
- tmp[tmp > 0] <- bothshuffle(tempPos)
- }
- perm[id,] <- tmp
- }
- } else perm[id,] <- commsimulator(temp, method=method)
- }
- } # for j end
- perm
-}
-
Modified: pkg/vegan/man/permatfull.Rd
===================================================================
--- pkg/vegan/man/permatfull.Rd 2011-09-22 21:08:49 UTC (rev 1875)
+++ pkg/vegan/man/permatfull.Rd 2011-09-23 05:14:28 UTC (rev 1876)
@@ -1,9 +1,7 @@
\encoding{UTF-8}
\name{permat}
\alias{permatfull}
-\alias{permatfull1}
\alias{permatswap}
-\alias{permatswap1}
\alias{summary.permat}
\alias{print.summary.permat}
\alias{print.permat}
@@ -22,14 +20,11 @@
Details section.}
\usage{
-permatfull1(m, fixedmar = "both", shuffle = "both", strata = NULL,
- mtype = "count")
-permatswap1(m, method = "quasiswap", fixedmar="both", shuffle = "both",
- strata = NULL, mtype = "count", thin = 1)
permatfull(m, fixedmar = "both", shuffle = "both", strata = NULL,
- mtype = "count", times = 99)
+ mtype = "count", times = 99, ...)
permatswap(m, method = "quasiswap", fixedmar="both", shuffle = "both",
- strata = NULL, mtype = "count", times = 99, burnin = 0, thin = 1)
+ strata = NULL, mtype = "count", times = 99,
+ burnin = 0, thin = 1, ...)
\method{print}{permat}(x, digits = 3, ...)
\method{summary}{permat}(object, ...)
\method{print}{summary.permat}(x, digits = 2, ...)
@@ -73,7 +68,8 @@
method, whether a locally weighted regression curve should be drawn,
the plot should be drawn, and statistic values should be printed on
the plot.}
- \item{\dots}{Other arguments passed to methods.}
+ \item{\dots}{Other arguments passed to \code{\link{simulate.nullmodel}}
+ or methods.}
}
\details{
@@ -146,13 +142,18 @@
column incidences constant, then non-zero values are modified
according to the \code{shuffle} argument (only \code{"samp"} and
\code{"both"} are available in this case, because it is applied only
- on non-zero values).
+ on non-zero values). It also recognizes the \code{fixedmar}
+ argument which cannot be \code{"both"} (\pkg{vegan} versions <= 2.0
+ had this algorithm with \code{fixedmar = "none"}).
The algorithm \code{"abuswap"} produces two kinds of null models
(based on \code{fixedmar="columns"} or \code{fixedmar="rows"}) as
described in Hardy (2008; randomization scheme 2x and 3x,
respectively). These preserve column and row occurrences, and column
- or row sums at the same time.
+ or row sums at the same time. (Note that similar constraints
+ can be achieved by the non sequential \code{"swsh"} algorithm
+ with \code{fixedmar} argument set to \code{"columns"} or
+ \code{"rows"}, respectively.)
Constraints on row/column sums, matrix fill, total sum and sums within
strata can be checked by the \code{summary} method. \code{plot} method
@@ -183,12 +184,7 @@
is useful for accessing diagnostic tools available in the \pkg{coda}
package. }
-\value{ Functions \code{permatfull1} and \code{permatswap1} return a
- single permuted matrix. These functions are called repeatedly
- by the corresponding \code{permatfull} and \code{permatswap}
- functions.
-
- Functions \code{permatfull} and \code{permatswap} return an
+\value{Functions \code{permatfull} and \code{permatswap} return an
object of class \code{"permat"} containing the the function call
(\code{call}), the original data matrix used for permutations
(\code{orig}) and a list of permuted matrices with length \code{times}
@@ -231,8 +227,11 @@
For time-series diagnostics: \code{\link{Box.test}},
\code{\link{lag.plot}}, \code{\link{tsdiag}}, \code{\link{ar}},
-\code{\link{arima}} }
+\code{\link{arima}}
+For underlying `low level' implementation:
+\code{\link{commsim}} and \code{\link{nullmodel}}.}
+
\examples{
## A simple artificial community data matrix.
m <- matrix(c(
More information about the Vegan-commits
mailing list