From f59a47e355be4ddb9234279c3b828a1c625b229a Mon Sep 17 00:00:00 2001 From: Peter Solymos Date: Mon, 23 May 2016 21:56:00 -0600 Subject: [PATCH 1/3] real data in example This commit addresses #177 --- man/nullmodel.Rd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/man/nullmodel.Rd b/man/nullmodel.Rd index be2e8b82a..ff798fde6 100644 --- a/man/nullmodel.Rd +++ b/man/nullmodel.Rd @@ -182,8 +182,8 @@ Jari Oksanen and Peter Solymos \code{\link{permatfull}}, \code{\link{permatswap}} } \examples{ -set.seed(123) -x <- matrix(rbinom(12*10, 1, 0.5)*rpois(12*10, 3), 12, 10) +data(mite) +x <- as.matrix(mite)[1:12, 21:30] ## non-sequential nullmodel (nm <- nullmodel(x, "r00")) From 96fbde080835ecb30e5b3cef1928075f0311b5fe Mon Sep 17 00:00:00 2001 From: Peter Solymos Date: Mon, 23 May 2016 23:08:27 -0600 Subject: [PATCH 2/3] handling 1 row/col cases addresses #177 --- R/make.commsim.R | 42 ++++++++++++++++++++++++++++++++++++------ 1 file changed, 36 insertions(+), 6 deletions(-) diff --git a/R/make.commsim.R b/R/make.commsim.R index a53c7806b..e08e19fe6 100644 --- a/R/make.commsim.R +++ b/R/make.commsim.R @@ -75,6 +75,8 @@ function(method) "quasiswap" = commsim(method="quasiswap", binary=TRUE, isSeq=FALSE, mode="integer", fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") out <- array(unlist(r2dtable(n, rs, cs)), c(nr, nc, n)) storage.mode(out) <- "integer" for (k in seq_len(n)) @@ -122,6 +124,8 @@ function(method) "backtrack" = commsim(method="backtrack", binary=TRUE, isSeq=FALSE, mode="integer", fun=function(x, n, nr, nc, rs, cs, rf, cf, s, fill, thin) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") btrfun <- function() { all <- matrix(as.integer(1:(nr * nc)), nrow = nr, ncol = nc) out <- matrix(0L, nrow = nr, ncol = nc) @@ -171,6 +175,8 @@ function(method) "r2dtable" = commsim(method="r2dtable", binary=FALSE, isSeq=FALSE, mode="integer", fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") out <- array(unlist(r2dtable(n, rs, cs)), c(nr, nc, n)) storage.mode(out) <- "integer" out @@ -178,6 +184,8 @@ function(method) "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) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") out <- array(0L, c(nr, nc, n)) out[,,1] <- .C("swapcount", m = x, nr, nc, thin, PACKAGE = "vegan")$m @@ -189,6 +197,8 @@ function(method) "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) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") out <- array(unlist(r2dtable(n, rs, cs)), c(nr, nc, n)) storage.mode(out) <- "integer" for (k in seq_len(n)) @@ -199,6 +209,8 @@ function(method) "swsh_samp" = commsim(method="swsh_samp", binary=FALSE, isSeq=FALSE, mode="double", fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") nz <- x[x > 0] out <- array(unlist(r2dtable(fill, rf, cf)), c(nr, nc, n)) storage.mode(out) <- "double" @@ -213,6 +225,8 @@ function(method) "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) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") indshuffle <- function(x) { drop(rmultinom(1, sum(x), rep(1, length(x)))) } @@ -230,6 +244,8 @@ function(method) "swsh_samp_r" = commsim(method="swsh_samp_r", binary=FALSE, isSeq=FALSE, mode="double", fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") out <- array(unlist(r2dtable(fill, rf, cf)), c(nr, nc, n)) storage.mode(out) <- "double" I <- seq_len(nr) @@ -250,6 +266,8 @@ function(method) "swsh_samp_c" = commsim(method="swsh_samp_c", binary=FALSE, isSeq=FALSE, mode="double", fun=function(x, n, nr, nc, cs, rs, rf, cf, s, fill, thin) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") out <- array(unlist(r2dtable(fill, rf, cf)), c(nr, nc, n)) storage.mode(out) <- "double" J <- seq_len(nc) @@ -270,6 +288,8 @@ function(method) "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) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") indshuffle <- function(x) { drop(rmultinom(1, sum(x), rep(1, length(x)))) } @@ -293,6 +313,8 @@ function(method) "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) { + if (nr < 2L || nc < 2) + stop("needs at least 2 items") indshuffle <- function(x) { drop(rmultinom(1, sum(x), rep(1, length(x)))) } @@ -351,7 +373,8 @@ function(method) J <- seq_len(nc) for (k in seq_len(n)) for (j in J) - out[, j, k] <- sample(x[,j]) + out[, j, k] <- if (nr < 2) + x[,j] else sample(x[,j]) out }), "r0_samp" = commsim(method="r0_samp", binary=FALSE, isSeq=FALSE, @@ -361,7 +384,8 @@ function(method) I <- seq_len(nr) for (k in seq_len(n)) for (i in I) - out[i, , k] <- sample(x[i,]) + out[i, , k] <- if (nc < 2) + x[i,] else sample(x[i,]) out }), "r00_ind" = commsim(method="r00_ind", binary=FALSE, isSeq=FALSE, @@ -426,8 +450,11 @@ function(method) 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]) + if (sum(x[,j]) > 0) { + out[,j,k][x[,j] > 0] <- indshuffle(x[,j][x[,j] > 0] - 1L) + 1L + out[,j,k] <- if (nr < 2) + out[,j,k] else sample(out[,j,k]) + } } out }), @@ -441,8 +468,11 @@ function(method) 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]) + if (sum(x[i,]) > 0) { + out[i,,k][x[i,] > 0] <- indshuffle(x[i,][x[i,] > 0] - 1L) + 1L + out[i,,k] <- if (nc < 2) + out[i,,k] else sample(out[i,,k]) + } } out }) From 4617d96d3a9cac15eeb570c1971c70b06895a4ec Mon Sep 17 00:00:00 2001 From: Peter Solymos Date: Mon, 23 May 2016 23:08:45 -0600 Subject: [PATCH 3/3] note about 1 row/col cases --- man/nullmodel.Rd | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/man/nullmodel.Rd b/man/nullmodel.Rd index ff798fde6..e8fa4443c 100644 --- a/man/nullmodel.Rd +++ b/man/nullmodel.Rd @@ -181,6 +181,12 @@ Jari Oksanen and Peter Solymos \code{\link{commsim}}, \code{\link{make.commsim}}, \code{\link{permatfull}}, \code{\link{permatswap}} } +\note{ +Care must be taken when the input matrix only contains a single +row or column. Such input is invalid for swapping and hypergeometric +distribution (calling \code{\link{r2dtable}}) based algorithms. +This also applies to cases when the input is stratified into subsets. +} \examples{ data(mite) x <- as.matrix(mite)[1:12, 21:30]