[Vegan-commits] r1861 - pkg/vegan/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Sep 20 18:40:29 CEST 2011
Author: psolymos
Date: 2011-09-20 18:40:28 +0200 (Tue, 20 Sep 2011)
New Revision: 1861
Added:
pkg/vegan/R/commsim.R
pkg/vegan/R/make.commsim.R
pkg/vegan/R/nullmodel.R
pkg/vegan/R/print.commsim.R
pkg/vegan/R/print.nullmodel.R
pkg/vegan/R/print.simmat.R
pkg/vegan/R/simulate.nullmodel.R
pkg/vegan/R/update.nullmodel.R
Log:
new functions for nullmodel analysis
Added: pkg/vegan/R/commsim.R
===================================================================
--- pkg/vegan/R/commsim.R (rev 0)
+++ pkg/vegan/R/commsim.R 2011-09-20 16:40:28 UTC (rev 1861)
@@ -0,0 +1,24 @@
+## this is function to create a commsim object, does some checks
+## there is a finite number of useful arguments here
+## but I added ... to allow for unforeseen algorithms,
+## or being able to reference to external objects
+commsim <-
+function(method, fun, binary, isSeq, mode)
+{
+ fun <- if (!missing(fun))
+ match.fun(fun) else stop("'fun' missing")
+ if (any(!(names(formals(fun)) %in%
+ c("x", "n", "nr", "nc", "rs", "cs", "rf", "cf", "s", "fill", "thin", "..."))))
+ stop("unexpected arguments in 'fun'")
+ out <- structure(list(method = if (!missing(method))
+ as.character(method)[1L] else stop("'method' missing"),
+ binary = if (!missing(binary))
+ as.logical(binary)[1L] else stop("'binary' missing"),
+ isSeq = if (!missing(isSeq))
+ as.logical(isSeq)[1L] else stop("'isSeq' missing"),
+ mode = if (!missing(mode))
+ match.arg(as.character(mode)[1L],
+ c("integer", "double")) else stop("'mode' missing"),
+ fun = fun), class = "commsim")
+ out
+}
Added: pkg/vegan/R/make.commsim.R
===================================================================
--- pkg/vegan/R/make.commsim.R (rev 0)
+++ pkg/vegan/R/make.commsim.R 2011-09-20 16:40:28 UTC (rev 1861)
@@ -0,0 +1,431 @@
+## this lists all known algos in vegan and more
+## if method is commsim object, it is returned
+## if it is character, switch returns the right one, else stop with error
+## so it can be used instead of match.arg(method) in other functions
+## NOTE: very very long -- but it can be a central repository of algos
+## NOTE 2: storage mode coercions are avoided here
+## (with no apparent effect on speed), it should be
+## handled by nullmodel and commsim characteristics
+make.commsim <-
+function(method)
+{
+ if (inherits(method, "commsim"))
+ return(method)
+ switch(method,
+ "r00" = return(commsim(method=method, 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)
+ for (k in seq_len(n))
+ out[sample.int(nr * nc, s), k] <- 1
+ dim(out) <- c(nr, nc, n)
+ out
+ })),
+ "c0" = return(commsim(method=method, 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))
+ J <- seq_len(nc)
+ for (k in seq_len(n))
+ for (j in J)
+ out[sample.int(nr, cs[j]), j, k] <- 1
+ out
+ })),
+ "r0" = return(commsim(method=method, 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))
+ I <- seq_len(nr)
+ for (k in seq_len(n))
+ for (i in I)
+ out[i, sample.int(nc, rs[i]), k] <- 1
+ out
+ })),
+ "r1" = return(commsim(method=method, 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))
+ I <- seq_len(nr)
+ for (k in seq_len(n))
+ 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,
+ mode="integer",
+ fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
+ out <- array(0L, c(nr, nc, n))
+ p <- cs * cs
+ I <- seq_len(nr)
+ for (k in seq_len(n))
+ 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,
+ 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))
+ storage.mode(out) <- "integer"
+ for (k in seq_len(n))
+ out[,,k] <- .C("quasiswap",
+ m = out[,,k], nr, nc, PACKAGE = "vegan")$m
+ out
+ })),
+ "swap" = return(commsim(method=method, 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))
+ out[,,1] <- .C("swap",
+ m = x, nr, nc, thin, PACKAGE = "vegan")$m
+ for (k in seq_len(n-1))
+ out[,,k+1] <- .C("swap",
+ m = out[,,k], nr, nc, thin,
+ PACKAGE = "vegan")$m
+ out
+ })),
+ "tswap" = return(commsim(method=method, 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))
+ out[,,1] <- .C("trialswap",
+ m = x, nr, nc, thin, PACKAGE = "vegan")$m
+ for (k in seq_len(n-1))
+ out[,,k+1] <- .C("trialswap",
+ m = out[,,k], nr, nc, thin, PACKAGE = "vegan")$m
+ out
+ })),
+ "backtrack" = return(commsim(method=method, binary=TRUE, isSeq=FALSE,
+ mode="integer",
+ fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
+ btrfun <- function() {
+ all <- matrix(as.integer(1:(nr * nc)), nrow = nr, ncol = nc)
+ out <- matrix(0L, nrow = nr, ncol = nc)
+ free <- matrix(as.integer(1:(nr * nc)), nrow = nr)
+ icount <- integer(length(rs))
+ jcount <- integer(length(cs))
+ prob <- outer(rs, cs, "*")
+ ij <- sample(free, prob = prob)
+ i <- (ij - 1)%%nr + 1
+ j <- (ij - 1)%/%nr + 1
+ for (k in 1:length(ij)) {
+ if (icount[i[k]] < rs[i[k]] && jcount[j[k]] < cs[j[k]]) {
+ out[ij[k]] <- 1
+ icount[i[k]] <- icount[i[k]] + 1
+ jcount[j[k]] <- jcount[j[k]] + 1
+ }
+ }
+ ndrop <- 1
+ for (i in 1:10000) {
+ oldout <- out
+ oldn <- sum(out)
+ drop <- sample(all[out == 1], ndrop)
+ out[drop] <- 0
+ candi <- outer(rowSums(out) < rs, colSums(out) < cs, "&") & out == 0
+ while (sum(candi) > 0) {
+ if (sum(candi) > 1)
+ ij <- sample(all[candi], 1)
+ else ij <- all[candi]
+ out[ij] <- 1
+ candi <- outer(rowSums(out) < rs, colSums(out) < cs, "&") & out == 0
+ }
+ if (sum(out) >= fill)
+ break
+ if (oldn >= sum(out))
+ ndrop <- min(ndrop + 1, 4)
+ else ndrop <- 1
+ if (oldn > sum(out))
+ out <- oldout
+ }
+ out
+ }
+ out <- array(0, c(nr, nc, n))
+ for (k in seq_len(n))
+ out[, , k] <- btrfun()
+ out
+ })),
+ "r2dtable" = return(commsim(method=method, 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,
+ 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,
+ 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,
+ mode="integer",
+ fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
+ nz <- as.integer(x[x > 0])
+ out <- array(unlist(r2dtable(fill, rf, cf)), c(nr, nc, n))
+ storage.mode(out) <- "integer"
+ for (k in seq_len(n)) {
+ out[,,k] <- .C("quasiswap",
+ m = out[,,k], nr, nc, PACKAGE = "vegan")$m
+ out[,,k][out[,,k] > 0] <- sample(nz)
+ }
+ out
+ })),
+ "swsh_both" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ mode="integer",
+ fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
+ indshuffle <- function(x) {
+ out <- integer(length(x))
+ tmp <- table(sample.int(length(x), sum(x), replace = TRUE))
+ out[as.integer(names(tmp))] <- as.integer(tmp)
+ out
+ }
+ nz <- as.integer(x[x > 0])
+ out <- array(unlist(r2dtable(fill, rf, cf)), c(nr, nc, n))
+ storage.mode(out) <- "integer"
+ for (k in seq_len(n)) {
+ out[,,k] <- .C("quasiswap",
+ m = out[,,k], nr, nc, PACKAGE = "vegan")$m
+ out[,,k][out[,,k] > 0] <- sample(indshuffle(nz - 1L) + 1L)
+ }
+ out
+ })),
+ "swsh_samp_r" = return(commsim(method=method, 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))
+ storage.mode(out) <- "integer"
+ I <- seq_len(nr)
+ for (k in seq_len(n)) {
+ out[,,k] <- .C("quasiswap",
+ m = out[,,k], nr, nc, PACKAGE = "vegan")$m
+ for (i in I)
+ 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,
+ 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))
+ storage.mode(out) <- "integer"
+ J <- seq_len(nc)
+ for (k in seq_len(n)) {
+ out[,,k] <- .C("quasiswap",
+ m = out[,,k], nr, nc, PACKAGE = "vegan")$m
+ for (j in J)
+ 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,
+ mode="integer",
+ fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
+ indshuffle <- function(x) {
+ out <- integer(length(x))
+ tmp <- table(sample.int(length(x), sum(x), replace = TRUE))
+ out[as.integer(names(tmp))] <- as.integer(tmp)
+ out
+ }
+ I <- seq_len(nr)
+ out <- array(unlist(r2dtable(fill, rf, cf)), c(nr, nc, n))
+ storage.mode(out) <- "integer"
+ for (k in seq_len(n)) {
+ out[,,k] <- .C("quasiswap",
+ m = out[,,k], nr, nc, PACKAGE = "vegan")$m
+ for (i in I)
+ 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,
+ mode="integer",
+ fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
+ indshuffle <- function(x) {
+ out <- integer(length(x))
+ tmp <- table(sample.int(length(x), sum(x), replace = TRUE))
+ out[as.integer(names(tmp))] <- as.integer(tmp)
+ out
+ }
+ J <- seq_len(nc)
+ out <- array(unlist(r2dtable(fill, rf, cf)), c(nr, nc, n))
+ storage.mode(out) <- "integer"
+ for (k in seq_len(n)) {
+ out[,,k] <- .C("quasiswap",
+ m = out[,,k], nr, nc, PACKAGE = "vegan")$m
+ for (j in J)
+ 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,
+ mode="double",
+ fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
+ out <- array(0, c(nr, nc, n))
+ out[,,1] <- .C("abuswap",
+ m = x, nr, nc, thin, 1L, PACKAGE = "vegan")$m
+ for (k in seq_len(n-1))
+ 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,
+ mode="double",
+ fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) {
+ out <- array(0, c(nr, nc, n))
+ out[,,1] <- .C("abuswap",
+ m = x, nr, nc, thin, 0L, PACKAGE = "vegan")$m
+ for (k in seq_len(n-1))
+ 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,
+ mode="integer",
+ fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
+ out <- matrix(0L, nr * nc, n)
+ for (k in seq_len(n))
+ out[, k] <- sample(x)
+ dim(out) <- c(nr, nc, n)
+ out
+ })),
+ "c0_samp" = return(commsim(method=method, 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))
+ J <- seq_len(nc)
+ for (k in seq_len(n))
+ for (j in J)
+ out[, j, k] <- sample(x[,j])
+ out
+ })),
+ "r0_samp" = return(commsim(method=method, 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))
+ I <- seq_len(nr)
+ for (k in seq_len(n))
+ for (i in I)
+ out[i, , k] <- sample(x[i,])
+ out
+ })),
+ "r00_ind" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ mode="integer",
+ fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
+ indshuffle <- function(x) {
+ out <- integer(length(x))
+ tmp <- table(sample.int(length(x), sum(x), replace = TRUE))
+ out[as.integer(names(tmp))] <- as.integer(tmp)
+ out
+ }
+ out <- matrix(0L, nr * nc, n)
+ for (k in seq_len(n))
+ out[, k] <- indshuffle(x)
+ dim(out) <- c(nr, nc, n)
+ out
+ })),
+ "c0_ind" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ mode="integer",
+ fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
+ indshuffle <- function(x) {
+ out <- integer(length(x))
+ tmp <- table(sample.int(length(x), sum(x), replace = TRUE))
+ out[as.integer(names(tmp))] <- as.integer(tmp)
+ out
+ }
+ out <- array(0L, c(nr, nc, n))
+ J <- seq_len(nc)
+ for (k in seq_len(n))
+ for (j in J)
+ out[, j, k] <- indshuffle(x[,j])
+ out
+ })),
+ "r0_ind" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ mode="integer",
+ fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
+ indshuffle <- function(x) {
+ out <- integer(length(x))
+ tmp <- table(sample.int(length(x), sum(x), replace = TRUE))
+ out[as.integer(names(tmp))] <- as.integer(tmp)
+ out
+ }
+ out <- array(0L, c(nr, nc, n))
+ I <- seq_len(nr)
+ for (k in seq_len(n))
+ for (i in I)
+ out[i, , k] <- indshuffle(x[i,])
+ out
+ })),
+ "r00_both" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ mode="integer",
+ fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
+ indshuffle <- function(x) {
+ out <- integer(length(x))
+ tmp <- table(sample.int(length(x), sum(x), replace = TRUE))
+ out[as.integer(names(tmp))] <- as.integer(tmp)
+ out
+ }
+ out <- matrix(0L, nr * nc, n)
+ for (k in seq_len(n)) {
+ out[,k][x > 0] <- indshuffle(x[x > 0] - 1L) + 1L
+ out[,k] <- sample(out[,k])
+ }
+ dim(out) <- c(nr, nc, n)
+ out
+ })),
+ "c0_both" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ mode="integer",
+ fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
+ indshuffle <- function(x) {
+ out <- integer(length(x))
+ tmp <- table(sample.int(length(x), sum(x), replace = TRUE))
+ out[as.integer(names(tmp))] <- as.integer(tmp)
+ out
+ }
+ out <- array(0L, c(nr, nc, n))
+ J <- seq_len(nc)
+ for (k in seq_len(n))
+ for (j in J) {
+ out[,j,k][x[,j] > 0] <- indshuffle(x[,j][x[,j] > 0] - 1L) + 1L
+ out[,j,k] <- sample(out[,j,k])
+ }
+ out
+ })),
+ "r0_both" = return(commsim(method=method, binary=FALSE, isSeq=FALSE,
+ mode="integer",
+ fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) {
+ indshuffle <- function(x) {
+ out <- integer(length(x))
+ tmp <- table(sample.int(length(x), sum(x), replace = TRUE))
+ out[as.integer(names(tmp))] <- as.integer(tmp)
+ out
+ }
+ out <- array(0L, c(nr, nc, n))
+ I <- seq_len(nr)
+ for (k in seq_len(n))
+ for (i in I) {
+ out[i,,k][x[i,] > 0] <- indshuffle(x[i,][x[i,] > 0] - 1L) + 1L
+ out[i,,k] <- sample(out[i,,k])
+ }
+ out
+ }))
+ )
+ stop("\"", method, "\" method not found")
+}
Added: pkg/vegan/R/nullmodel.R
===================================================================
--- pkg/vegan/R/nullmodel.R (rev 0)
+++ pkg/vegan/R/nullmodel.R 2011-09-20 16:40:28 UTC (rev 1861)
@@ -0,0 +1,43 @@
+## this thing creates an environment
+## the whole point is to create all possible inputs for
+## commsim functions only once and reuse them as necessary
+## also helps keeping track of updating process for sequential algorithms
+## method$mode can be evaluated and use storage mode accordingly
+nullmodel <-
+function(x, method)
+{
+ x <- as.matrix(x)
+ if (is.null(dim(x)) || length(dim(x)) != 2L)
+ stop("'x' must be a matrix-like object")
+ if (any(is.na(x)))
+ stop("'NA' values not allowed")
+ if (any(x<0))
+ stop("negative values not allowed")
+ method <- make.commsim(method)
+ if (method$binary)
+ x <- ifelse(x > 0, 1L, 0L)
+ int <- method$mode == "integer"
+ if (int && abs(sum(x) - sum(as.integer(x))) > 10^-6)
+ stop("non integer values not allowed")
+ out <- list(
+ data=x,
+ nrow=as.integer(dim(x)[1L]),
+ ncol=as.integer(dim(x)[2L]),
+ rowSums=rowSums(x),
+ colSums=colSums(x),
+ rowFreq=as.integer(rowSums(x > 0)),
+ colFreq=as.integer(colSums(x > 0)),
+ totalSum=ifelse(int, as.integer(sum(x)), as.double(sum(x))),
+ fill=as.integer(sum(x > 0)),
+ commsim=method,
+ state=if (method$isSeq) x else NULL,
+ iter=if (method$isSeq) as.integer(0L) else NULL
+ )
+ storage.mode(out$x) <- method$mode
+ storage.mode(out$rowSums) <- method$mode
+ storage.mode(out$colSums) <- method$mode
+ out <- list2env(out, parent=emptyenv())
+ class(out) <- c("nullmodel", "environment")
+# class(out) <- "nullmodel"
+ out
+}
Added: pkg/vegan/R/print.commsim.R
===================================================================
--- pkg/vegan/R/print.commsim.R (rev 0)
+++ pkg/vegan/R/print.commsim.R 2011-09-20 16:40:28 UTC (rev 1861)
@@ -0,0 +1,8 @@
+print.commsim <- function(x, ...) {
+ cat("An object of class \"", class(x)[1L] , "\"\n", sep="")
+ isSeq <- ifelse(x$isSeq, "sequential", "non-sequential")
+ binary <- ifelse(x$binary, "binary", "count")
+ cat("\"", x$method, "\" method (",
+ binary, ", ", isSeq, ", ", x$mode, " mode)\n\n", sep="")
+ invisible(x)
+}
Added: pkg/vegan/R/print.nullmodel.R
===================================================================
--- pkg/vegan/R/print.nullmodel.R (rev 0)
+++ pkg/vegan/R/print.nullmodel.R 2011-09-20 16:40:28 UTC (rev 1861)
@@ -0,0 +1,11 @@
+print.nullmodel <- function(x, ...) {
+ isSeq <- ifelse(x$commsim$isSeq, "sequential", "non-sequential")
+ binary <- ifelse(x$commsim$binary, "binary", "count")
+ cat("An object of class \"", class(x)[1L], "\"\n", sep="")
+ cat("\"", x$commsim$method, "\" method (",
+ binary, ", ", isSeq, ")\n", sep="")
+ cat(x$nrow, "x", x$ncol, "matrix\n")
+ if (x$commsim$isSeq)
+ cat("Iterations =", x$iter, "\n\n") else cat("\n")
+ invisible(x)
+}
Added: pkg/vegan/R/print.simmat.R
===================================================================
--- pkg/vegan/R/print.simmat.R (rev 0)
+++ pkg/vegan/R/print.simmat.R 2011-09-20 16:40:28 UTC (rev 1861)
@@ -0,0 +1,15 @@
+print.simmat <- function(x, ...) {
+ isSeq <- ifelse(attr(x, "isSeq"), "sequential", "non-sequential")
+ binary <- ifelse(attr(x, "binary"), "binary", "count")
+ d <- dim(x)
+ cat("An object of class \"", class(x)[1L], "\"\n", sep="")
+ cat("\"", attr(x, "method"), "\" method (",
+ binary, ", ", isSeq, ")\n", sep="")
+ cat(d[1L], "x", d[2L], "matrix\n")
+ cat("Number of permuted matrices =", d[3L], "\n")
+ if (attr(x, "isSeq")) {
+ cat("Start = ", attr(x, "start"), ", End = ", attr(x, "end"),
+ ", Thin = ", attr(x, "thin"), "\n\n", sep="")
+ } else cat("\n")
+ invisible(x)
+}
Added: pkg/vegan/R/simulate.nullmodel.R
===================================================================
--- pkg/vegan/R/simulate.nullmodel.R (rev 0)
+++ pkg/vegan/R/simulate.nullmodel.R 2011-09-20 16:40:28 UTC (rev 1861)
@@ -0,0 +1,64 @@
+simulate.nullmodel <-
+function(object, nsim=1, seed = NULL, burnin=0, thin=1, ...)
+{
+ if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))
+ runif(1)
+ if (is.null(seed))
+ RNGstate <- get(".Random.seed", envir = .GlobalEnv)
+ else {
+ R.seed <- get(".Random.seed", envir = .GlobalEnv)
+ set.seed(seed)
+ RNGstate <- structure(seed, kind = as.list(RNGkind()))
+ on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv))
+ }
+ if (nsim < 1)
+ stop("'nsim' must be at least 1")
+ m <- object$data
+ if (object$commsim$isSeq) {
+ ## here is burnin, see update method
+ if (burnin > 0)
+ update(object, burnin, ...)
+ x <- object$state
+ } else {
+ x <- m
+ if (thin != 1)
+ warning("non-sequential model: 'thin' set to 1")
+ thin <- 1L
+ if (burnin > 0)
+ warning("non-sequential model: 'burnin' set to 0")
+ burnin <- 0L
+ }
+ perm <- object$commsim$fun(x=x,
+ n=nsim,
+ nr=object$nrow,
+ nc=object$ncol,
+ rs=object$rowSums,
+ cs=object$colSums,
+ rf=object$rowFreq,
+ cf=object$colFreq,
+ s=object$totalSum,
+ fill=object$fill,
+ thin=thin, ...)
+ if (object$commsim$isSeq) {
+ Start <- as.integer(object$iter + 1L)
+ End <- as.integer(object$iter + nsim * thin)
+ state <- perm[,,nsim]
+ storage.mode(state) <- object$commsim$mode
+ assign("state", state, envir=object)
+ assign("iter", as.integer(End), envir=object)
+ } else {
+ Start <- 1L
+ End <- as.integer(nsim)
+ }
+ attr(perm, "data") <- m
+ attr(perm, "seed") <- RNGstate
+ attr(perm, "method") <- object$commsim$method
+ attr(perm, "binary") <- object$commsim$binary
+ attr(perm, "isSeq") <- object$commsim$isSeq
+ attr(perm, "mode") <- object$commsim$mode
+ attr(perm, "start") <- Start
+ attr(perm, "end") <- End
+ attr(perm, "thin") <- as.integer(thin)
+ class(perm) <- c("simmat", "array")
+ perm
+}
Added: pkg/vegan/R/update.nullmodel.R
===================================================================
--- pkg/vegan/R/update.nullmodel.R (rev 0)
+++ pkg/vegan/R/update.nullmodel.R 2011-09-20 16:40:28 UTC (rev 1861)
@@ -0,0 +1,33 @@
+update.nullmodel <-
+function(object, nsim=1, seed = NULL, ...)
+{
+ if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))
+ runif(1)
+ if (is.null(seed))
+ RNGstate <- get(".Random.seed", envir = .GlobalEnv)
+ else {
+ R.seed <- get(".Random.seed", envir = .GlobalEnv)
+ set.seed(seed)
+ 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,
+ nr=object$nrow,
+ nc=object$ncol,
+ rs=object$rowSums,
+ cs=object$colSums,
+ rf=object$rowFreq,
+ cf=object$colFreq,
+ s=object$totalSum,
+ fill=object$fill,
+ thin=1, ...)
+ state <- perm[,,nsim]
+ storage.mode(state) <- object$commsim$mode
+ assign("state", state, envir=object)
+ assign("iter", as.integer(object$iter + nsim), envir=object)
+ }
+ invisible(NULL)
+}
More information about the Vegan-commits
mailing list