[Vegan-commits] r1865 - in pkg/vegan: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 21 17:52:14 CEST 2011
Author: psolymos
Date: 2011-09-21 17:52:14 +0200 (Wed, 21 Sep 2011)
New Revision: 1865
Modified:
pkg/vegan/R/make.commsim.R
pkg/vegan/R/update.nullmodel.R
pkg/vegan/man/commsim.Rd
pkg/vegan/man/nullmodel.Rd
pkg/vegan/man/permatfull.Rd
Log:
make.commsim returns algo list, thin is used for burnin
Modified: pkg/vegan/R/make.commsim.R
===================================================================
--- pkg/vegan/R/make.commsim.R 2011-09-20 18:09:15 UTC (rev 1864)
+++ pkg/vegan/R/make.commsim.R 2011-09-21 15:52:14 UTC (rev 1865)
@@ -9,10 +9,8 @@
make.commsim <-
function(method)
{
- if (inherits(method, "commsim"))
- return(method)
- switch(method,
- "r00" = return(commsim(method=method, binary=TRUE, isSeq=FALSE,
+ algos <- list(
+ "r00" = commsim(method="r00", binary=TRUE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- matrix(0L, nr * nc, n)
@@ -20,8 +18,8 @@
out[sample.int(nr * nc, s), k] <- 1
dim(out) <- c(nr, nc, n)
out
- })),
- "c0" = return(commsim(method=method, binary=TRUE, isSeq=FALSE,
+ }),
+ "c0" = commsim(method="c0", binary=TRUE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- array(0L, c(nr, nc, n))
@@ -30,8 +28,8 @@
for (j in J)
out[sample.int(nr, cs[j]), j, k] <- 1
out
- })),
- "r0" = return(commsim(method=method, binary=TRUE, isSeq=FALSE,
+ }),
+ "r0" = commsim(method="r0", binary=TRUE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- array(0L, c(nr, nc, n))
@@ -40,8 +38,8 @@
for (i in I)
out[i, sample.int(nc, rs[i]), k] <- 1
out
- })),
- "r1" = return(commsim(method=method, binary=TRUE, isSeq=FALSE,
+ }),
+ "r1" = commsim(method="r1", binary=TRUE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- array(0L, c(nr, nc, n))
@@ -50,8 +48,8 @@
for (i in I)
out[i, sample.int(nc, rs[i], prob=cs), k] <- 1
out
- })),
- "r2" = return(commsim(method=method, binary=TRUE, isSeq=FALSE,
+ }),
+ "r2" = commsim(method="r2", binary=TRUE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- array(0L, c(nr, nc, n))
@@ -61,8 +59,8 @@
for (i in I)
out[i, sample.int(nc, rs[i], prob=p), k] <- 1
out
- })),
- "quasiswap" = return(commsim(method=method, binary=TRUE, isSeq=FALSE,
+ }),
+ "quasiswap" = commsim(method="quasiswap", binary=TRUE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- array(unlist(r2dtable(n, rs, cs)), c(nr, nc, n))
@@ -71,8 +69,8 @@
out[,,k] <- .C("quasiswap",
m = out[,,k], nr, nc, PACKAGE = "vegan")$m
out
- })),
- "swap" = return(commsim(method=method, binary=TRUE, isSeq=TRUE,
+ }),
+ "swap" = commsim(method="swap", binary=TRUE, isSeq=TRUE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- array(0L, c(nr, nc, n))
@@ -83,8 +81,8 @@
m = out[,,k], nr, nc, thin,
PACKAGE = "vegan")$m
out
- })),
- "tswap" = return(commsim(method=method, binary=TRUE, isSeq=TRUE,
+ }),
+ "tswap" = commsim(method="tswap", binary=TRUE, isSeq=TRUE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- array(0L, c(nr, nc, n))
@@ -94,8 +92,8 @@
out[,,k+1] <- .C("trialswap",
m = out[,,k], nr, nc, thin, PACKAGE = "vegan")$m
out
- })),
- "backtrack" = return(commsim(method=method, binary=TRUE, isSeq=FALSE,
+ }),
+ "backtrack" = commsim(method="backtrack", binary=TRUE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
btrfun <- function() {
@@ -143,39 +141,36 @@
for (k in seq_len(n))
out[, , k] <- btrfun()
out
- })),
- "r2dtable" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "r2dtable" = commsim(method="r2dtable", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
out <- array(unlist(r2dtable(n, rs, cs)), c(nr, nc, n))
storage.mode(out) <- "integer"
out
- })),
- "swap_count" = return(commsim(method=method, binary=FALSE, isSeq=TRUE,
+ }),
+ "swap_count" = commsim(method="swap_count", binary=FALSE, isSeq=TRUE,
mode="integer",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
out <- array(0L, c(nr, nc, n))
out[,,1] <- .C("swapcount",
-# m = as.double(x), nr, nc, thin, PACKAGE = "vegan")$m
m = x, nr, nc, thin, PACKAGE = "vegan")$m
for (k in seq_len(n-1))
out[,,k+1] <- .C("swapcount",
-# m = as.double(out[,,k]), nr, nc, thin, PACKAGE = "vegan")$m
m = out[,,k], nr, nc, thin, PACKAGE = "vegan")$m
out
- })),
- "quasiswap_count" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "quasiswap_count" = commsim(method="quasiswap_count", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
out <- array(unlist(r2dtable(n, rs, cs)), c(nr, nc, n))
storage.mode(out) <- "integer"
for (k in seq_len(n))
out[,,k] <- .C("rswapcount",
-# m = as.double(out[,,k]), nr, nc, fill, PACKAGE = "vegan")$m
m = out[,,k], nr, nc, fill, PACKAGE = "vegan")$m
out
- })),
- "swsh_samp" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "swsh_samp" = commsim(method="swsh_samp", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
nz <- as.integer(x[x > 0])
@@ -187,8 +182,8 @@
out[,,k][out[,,k] > 0] <- sample(nz)
}
out
- })),
- "swsh_both" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "swsh_both" = commsim(method="swsh_both", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
indshuffle <- function(x) {
@@ -206,8 +201,8 @@
out[,,k][out[,,k] > 0] <- sample(indshuffle(nz - 1L) + 1L)
}
out
- })),
- "swsh_samp_r" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "swsh_samp_r" = commsim(method="swsh_samp_r", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
out <- array(unlist(r2dtable(fill, rf, cf)), c(nr, nc, n))
@@ -220,8 +215,8 @@
out[i,,k][out[i,,k] > 0] <- sample(as.integer(x[i,][x[i,] > 0]))
}
out
- })),
- "swsh_samp_c" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "swsh_samp_c" = commsim(method="swsh_samp_c", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
out <- array(unlist(r2dtable(fill, rf, cf)), c(nr, nc, n))
@@ -234,8 +229,8 @@
out[,j,k][out[,j,k] > 0] <- sample(as.integer(x[,j][x[,j] > 0]))
}
out
- })),
- "swsh_both_r" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "swsh_both_r" = commsim(method="swsh_both_r", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
indshuffle <- function(x) {
@@ -254,8 +249,8 @@
out[i,,k][out[i,,k] > 0] <- sample(indshuffle(as.integer(x[i,][x[i,] > 0]) - 1L) + 1L)
}
out
- })),
- "swsh_both_c" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "swsh_both_c" = commsim(method="swsh_both_c", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
indshuffle <- function(x) {
@@ -274,8 +269,8 @@
out[,j,k][out[,j,k] > 0] <- sample(indshuffle(as.integer(x[,j][x[,j] > 0]) - 1L) + 1L)
}
out
- })),
- "abuswap_r" = return(commsim(method=method, binary=FALSE, isSeq=TRUE,
+ }),
+ "abuswap_r" = commsim(method="abuswap_r", binary=FALSE, isSeq=TRUE,
mode="double",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
out <- array(0, c(nr, nc, n))
@@ -285,8 +280,8 @@
out[,,k+1] <- .C("abuswap",
m = out[,,k], nr, nc, thin, 1L, PACKAGE = "vegan")$m
out
- })),
- "abuswap_c" = return(commsim(method=method, binary=FALSE, isSeq=TRUE,
+ }),
+ "abuswap_c" = commsim(method="abuswap_c", binary=FALSE, isSeq=TRUE,
mode="double",
fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
out <- array(0, c(nr, nc, n))
@@ -296,8 +291,8 @@
out[,,k+1] <- .C("abuswap",
m = out[,,k], nr, nc, thin, 0L, PACKAGE = "vegan")$m
out
- })),
- "r00_samp" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "r00_samp" = commsim(method="r00_samp", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- matrix(0L, nr * nc, n)
@@ -305,8 +300,8 @@
out[, k] <- sample(x)
dim(out) <- c(nr, nc, n)
out
- })),
- "c0_samp" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "c0_samp" = commsim(method="c0_samp", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- array(0L, c(nr, nc, n))
@@ -315,8 +310,8 @@
for (j in J)
out[, j, k] <- sample(x[,j])
out
- })),
- "r0_samp" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "r0_samp" = commsim(method="r0_samp", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
out <- array(0L, c(nr, nc, n))
@@ -325,8 +320,8 @@
for (i in I)
out[i, , k] <- sample(x[i,])
out
- })),
- "r00_ind" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "r00_ind" = commsim(method="r00_ind", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
indshuffle <- function(x) {
@@ -340,8 +335,8 @@
out[, k] <- indshuffle(x)
dim(out) <- c(nr, nc, n)
out
- })),
- "c0_ind" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "c0_ind" = commsim(method="c0_ind", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
indshuffle <- function(x) {
@@ -356,8 +351,8 @@
for (j in J)
out[, j, k] <- indshuffle(x[,j])
out
- })),
- "r0_ind" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "r0_ind" = commsim(method="r0_ind", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
indshuffle <- function(x) {
@@ -372,8 +367,8 @@
for (i in I)
out[i, , k] <- indshuffle(x[i,])
out
- })),
- "r00_both" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "r00_both" = commsim(method="r00_both", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
indshuffle <- function(x) {
@@ -389,8 +384,8 @@
}
dim(out) <- c(nr, nc, n)
out
- })),
- "c0_both" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "c0_both" = commsim(method="c0_both", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
indshuffle <- function(x) {
@@ -407,8 +402,8 @@
out[,j,k] <- sample(out[,j,k])
}
out
- })),
- "r0_both" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ }),
+ "r0_both" = commsim(method="r0_both", binary=FALSE, isSeq=FALSE,
mode="integer",
fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
indshuffle <- function(x) {
@@ -425,7 +420,13 @@
out[i,,k] <- sample(out[i,,k])
}
out
- }))
+ })
)
+ if (missing(method))
+ return(names(algos))
+ if (inherits(method, "commsim"))
+ return(method)
+ if (method %in% names(algos))
+ return(algos[[method]])
stop("\"", method, "\" method not found")
}
Modified: pkg/vegan/R/update.nullmodel.R
===================================================================
--- pkg/vegan/R/update.nullmodel.R 2011-09-20 18:09:15 UTC (rev 1864)
+++ pkg/vegan/R/update.nullmodel.R 2011-09-21 15:52:14 UTC (rev 1865)
@@ -11,10 +11,9 @@
RNGstate <- structure(seed, kind = as.list(RNGkind()))
on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv))
}
- m <- object$data
if (object$commsim$isSeq) {
perm <- object$commsim$fun(x=object$state,
- n=nsim,
+ n=1,
nr=object$nrow,
nc=object$ncol,
rs=object$rowSums,
@@ -23,11 +22,15 @@
cf=object$colFreq,
s=object$totalSum,
fill=object$fill,
- thin=1, ...)
+ thin=nsim, ...)
state <- perm[,,nsim]
storage.mode(state) <- object$commsim$mode
+ iter <- as.integer(object$iter + nsim)
assign("state", state, envir=object)
- assign("iter", as.integer(object$iter + nsim), envir=object)
+ assign("iter", iter, envir=object)
+ attr(state, "iter") <- iter
+ } else {
+ state <- NULL
}
- invisible(NULL)
+ invisible(state)
}
Modified: pkg/vegan/man/commsim.Rd
===================================================================
--- pkg/vegan/man/commsim.Rd 2011-09-20 18:09:15 UTC (rev 1864)
+++ pkg/vegan/man/commsim.Rd 2011-09-21 15:52:14 UTC (rev 1865)
@@ -263,11 +263,13 @@
corresponding to the arguments (\code{method}, \code{binary},
\code{isSeq}, \code{fun}).
-IF the input of \code{make.comsimm} is a \code{commsim} object,
+If the input of \code{make.comsimm} is a \code{commsim} object,
it is returned without further evaluation. If this is not the case,
the character \code{method} argument is matched agains
predefined algorithm names. An error message is issued
-if none such is found.
+if none such is found. If the \code{method} argument is missing,
+the function returns names of all currently available
+null model algorithms as a character vector.
}
\references{
Hardy, O. J. (2008)
@@ -313,8 +315,11 @@
isSeq=FALSE, mode="integer"))
## retrieving the sequential swap algorithm
-make.commsim("swap")
+(cs <- make.commsim("swap"))
+## feeding a commsim object as argument
+make.commsim(cs)
+
## structural constraints
diagfun <- function(x, y) {
c(sum = sum(y) == sum(x),
@@ -334,15 +339,8 @@
c(z, out)
}
x <- matrix(rbinom(10*12, 1, 0.5)*rpois(10*12, 3), 12, 10)
-a <- t(sapply(c("r00","r0","r1","r2","c0",
- "swap","tswap","quasiswap","backtrack",
- "r2dtable","swap_count","quasiswap_count",
- "swsh_samp","swsh_both","abuswap_r","abuswap_c",
- "swsh_samp_r","swsh_samp_c","swsh_both_r","swsh_both_c",
- "r00_ind","r0_ind","c0_ind",
- "r00_samp","r0_samp","c0_samp",
- "r00_both","r0_both","c0_both"),
- evalfun, x=x, n=10))
+algos <- make.commsim()
+a <- t(sapply(algos, evalfun, x=x, n=10))
print(as.table(ifelse(a==1,1,0)), zero.print = ".")
}
\keyword{ multivariate }
Modified: pkg/vegan/man/nullmodel.Rd
===================================================================
--- pkg/vegan/man/nullmodel.Rd 2011-09-20 18:09:15 UTC (rev 1864)
+++ pkg/vegan/man/nullmodel.Rd 2011-09-21 15:52:14 UTC (rev 1865)
@@ -131,8 +131,9 @@
and \code{perm} for an array of simulated matrices (third dimension
corresponding to \code{nsim} argument).
-The \code{update} method returns \code{NULL} invisibly,
-and update the input object for sequential algorithms.
+The \code{update} method returns the current state (last updated matrix)
+invisibly, and update the input object for sequential algorithms.
+For non sequential algorithms, it returns \code{NULL}.
}
\author{
Peter Solymos \email{solymos at ualberta.ca}
Modified: pkg/vegan/man/permatfull.Rd
===================================================================
--- pkg/vegan/man/permatfull.Rd 2011-09-20 18:09:15 UTC (rev 1864)
+++ pkg/vegan/man/permatfull.Rd 2011-09-21 15:52:14 UTC (rev 1865)
@@ -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,10 +20,6 @@
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)
permatswap(m, method = "quasiswap", fixedmar="both", shuffle = "both",
@@ -146,13 +140,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{vega} 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,11 +182,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.
-
+\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
@@ -226,6 +221,9 @@
\code{\link{commsimulator}}, \code{\link{r2dtable}},
\code{\link{sample}}, \code{\link[bipartite]{swap.web}}.
+For underlying `low level' implementation, see
+\code{\link{commsim}} and \code{\link{nullmodel}}.
+
For the use of these permutation algorithms: \code{\link{oecosimu}},
\code{\link{adipart}}, \code{\link{hiersimu}}.
More information about the Vegan-commits
mailing list