[Vegan-commits] r1663 - in pkg/permute: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jun 29 09:28:27 CEST 2011
Author: gsimpson
Date: 2011-06-29 09:28:26 +0200 (Wed, 29 Jun 2011)
New Revision: 1663
Added:
pkg/permute/R/shuffle-utils.R
pkg/permute/man/shuffle-utils.Rd
Modified:
pkg/permute/R/shuffle.R
Log:
rip out the in-line functions that do the permutation and make available as top-level functions. Document.
Added: pkg/permute/R/shuffle-utils.R
===================================================================
--- pkg/permute/R/shuffle-utils.R (rev 0)
+++ pkg/permute/R/shuffle-utils.R 2011-06-29 07:28:26 UTC (rev 1663)
@@ -0,0 +1,72 @@
+
+`shuffleStrata` <- function(strata, type, mirror = FALSE, start = NULL,
+ flip = NULL, nrow, ncol, start.row = NULL,
+ start.col = NULL) {
+ lev <- length(levels(strata))
+ ngr <- length(strata) / lev
+ sp <- split(seq(along = strata), strata)
+ if(type == "free") {
+ unname(do.call(c, sp[shuffleFree(lev, lev)]))
+ } else if(type == "series") {
+ unname(do.call(c,
+ sp[shuffleSeries(seq_len(lev),
+ mirror = mirror,
+ start = start,
+ flip = flip)]))
+ } else if(type == "grid") {
+ unname(do.call(c,
+ sp[shuffleGrid(nrow = nrow, ncol = ncol,
+ mirror = mirror,
+ start.row = start.row,
+ start.col = start.col,
+ flip = flip)]))
+ } else {
+ stop("Invalid permutation type.")
+ }
+}
+
+`shuffleGrid` <- function(nrow, ncol, mirror = FALSE, start.row = NULL,
+ start.col = NULL, flip = NULL) {
+ if(is.null(start.row))
+ start.row <- shuffleFree(nrow, 1L)
+ if(is.null(start.col))
+ start.col <- shuffleFree(ncol, 1L)
+ ir <- seq(start.row, length=nrow) %% nrow
+ ic <- seq(start.col, length=ncol) %% ncol
+ if(!is.null(flip)) {
+ if(any(flip)) {
+ if(flip[1L])
+ ir <- rev(ir)
+ if(flip[2L])
+ ic <- rev(ic)
+ }
+ } else {
+ if (mirror) {
+ if (runif(1L) < 0.5)
+ ir <- rev(ir)
+ if (runif(1L) < 0.5)
+ ic <- rev(ic)
+ }
+ }
+ rep(ic, each=nrow) * nrow + rep(ir, len=nrow*ncol) + 1L
+}
+
+`shuffleSeries` <- function(x, mirror = FALSE, start = NULL,
+ flip = NULL) {
+ n <- length(x)
+ if(is.null(start))
+ start <- shuffleFree(n, 1L)
+ out <- seq(start, length = n) %% n + 1L
+ if(!is.null(flip)) {
+ if(flip)
+ out <- rev(out)
+ } else {
+ if(mirror && runif(1L) < 0.5)
+ out <- rev(out)
+ }
+ x[out]
+}
+
+`shuffleFree` <- function(x, size) {
+ .Internal(sample(x, size, FALSE, NULL))
+}
Modified: pkg/permute/R/shuffle.R
===================================================================
--- pkg/permute/R/shuffle.R 2011-06-29 07:26:23 UTC (rev 1662)
+++ pkg/permute/R/shuffle.R 2011-06-29 07:28:26 UTC (rev 1663)
@@ -1,86 +1,16 @@
`shuffle` <-
function (n, control = permControl())
{
- `pStrata` <- function(strata, type, mirror = FALSE, start = NULL,
- flip = NULL, nrow, ncol, start.row = NULL,
- start.col = NULL) {
- lev <- length(levels(strata))
- ngr <- length(strata) / lev
- sp <- split(seq(along = strata), strata)
- if(type == "free") {
- unname(do.call(c, sp[pFree(lev, lev)]))
- } else if(type == "series") {
- unname(do.call(c,
- sp[pSeries(seq_len(lev),
- mirror = mirror,
- start = start,
- flip = flip)]))
- } else if(type == "grid") {
- unname(do.call(c,
- sp[pGrid(nrow = nrow, ncol = ncol,
- mirror = mirror,
- start.row = start.row,
- start.col = start.col,
- flip = flip)]))
- } else {
- stop("Invalid permutation type.")
- }
- }
- `pGrid` <- function(nrow, ncol, mirror = FALSE, start.row = NULL,
- start.col = NULL, flip = NULL) {
- if(is.null(start.row))
- start.row <- pFree(nrow, 1L)
- if(is.null(start.col))
- start.col <- pFree(ncol, 1L)
- ir <- seq(start.row, length=nrow) %% nrow
- ic <- seq(start.col, length=ncol) %% ncol
- if(!is.null(flip)) {
- if(any(flip)) {
- if(flip[1L])
- ir <- rev(ir)
- if(flip[2L])
- ic <- rev(ic)
- }
- } else {
- if (mirror) {
- if (runif(1L) < 0.5)
- ir <- rev(ir)
- if (runif(1L) < 0.5)
- ic <- rev(ic)
- }
- }
- rep(ic, each=nrow) * nrow + rep(ir, len=nrow*ncol) + 1L
- }
- `pSeries` <- function(inds, mirror = FALSE, start = NULL,
- flip = NULL) {
- n <- length(inds)
- if(is.null(start))
- start <- pFree(n, 1L)
- out <- seq(start, length = n) %% n + 1L
- if(!is.null(flip)) {
- if(flip)
- out <- rev(out)
- } else {
- if(mirror && runif(1L) < 0.5)
- out <- rev(out)
- }
- inds[out]
- }
- `pFree` <- function(x, size)
- .Internal(sample(x, size, FALSE, NULL))
- ## END in-line Functions ##
-
## If no strata then permute all samples using stated scheme
if(is.null(control$strata)) {
out <-
switch(control$within$type,
- "free" = pFree(n, n),
- "series" =
- pSeries(1:n, mirror = control$within$mirror),
- "grid" =
- pGrid(nrow = control$within$nrow,
- ncol = control$within$ncol,
- mirror = control$within$mirror),
+ "free" = shuffleFree(n, n),
+ "series" = shuffleSeries(1:n,
+ mirror = control$within$mirror),
+ "grid" = shuffleGrid(nrow = control$within$nrow,
+ ncol = control$within$ncol,
+ mirror = control$within$mirror),
"none" = seq_len(n)
)
} else {
@@ -91,12 +21,12 @@
out <- 1:n
} else {
flip <- runif(1L) < 0.5
- out <- pStrata(control$strata,
- type = control$blocks$type,
- mirror = control$blocks$mirror,
- flip = flip,
- nrow = control$blocks$nrow,
- ncol = control$blocks$ncol)
+ out <- shuffleStrata(control$strata,
+ type = control$blocks$type,
+ mirror = control$blocks$mirror,
+ flip = flip,
+ nrow = control$blocks$nrow,
+ ncol = control$blocks$ncol)
}
## permute the samples within strata?
if(control$within$type != "none") {
@@ -107,13 +37,13 @@
if(control$within$constant) {
if(control$within$type == "free") {
n <- unique(tab)[1L]
- same.rand <- pFree(n, n)
+ same.rand <- shuffleFree(n, n)
} else if(control$within$type == "series") {
- start <- pFree(n / length(inds), 1L)
+ start <- shuffleFree(n / length(inds), 1L)
flip <- runif(1L) < 0.5
} else if(control$within$type == "grid") {
- start.row <- pFree(control$within$nrow, 1L)
- start.col <- pFree(control$within$ncol, 1L)
+ start.row <- shuffleFree(control$within$nrow, 1L)
+ start.col <- shuffleFree(control$within$ncol, 1L)
flip <- runif(2L) < 0.5
}
} else {
@@ -133,19 +63,18 @@
if(control$within$constant) {
gr[same.rand]
} else {
- out[gr][pFree(n.gr, n.gr)]
+ out[gr][shuffleFree(n.gr, n.gr)]
},
"series" =
- pSeries(gr,
- mirror = control$within$mirror,
- start = start, flip = flip),
+ shuffleSeries(gr, mirror = control$within$mirror,
+ start = start, flip = flip),
"grid" =
- gr[pGrid(nrow = control$within$nrow,
- ncol = control$within$ncol,
- mirror = control$within$mirror,
- start.row = start.row,
- start.col = start.col,
- flip = flip)]
+ gr[shuffleGrid(nrow = control$within$nrow,
+ ncol = control$within$ncol,
+ mirror = control$within$mirror,
+ start.row = start.row,
+ start.col = start.col,
+ flip = flip)]
)
}
}
Added: pkg/permute/man/shuffle-utils.Rd
===================================================================
--- pkg/permute/man/shuffle-utils.Rd (rev 0)
+++ pkg/permute/man/shuffle-utils.Rd 2011-06-29 07:28:26 UTC (rev 1663)
@@ -0,0 +1,83 @@
+\name{shuffle-utils}
+\alias{shuffle-utils}
+\alias{shuffleFree}
+\alias{shuffleGrid}
+\alias{shuffleSeries}
+\alias{shuffleStrata}
+
+\title{Utility functions for Unrestricted and restricted permutations}
+\description{
+ Unrestricted and restricted permutations for time series,
+ line transects, spatial grids and blocking factors.
+}
+\usage{
+shuffleFree(x, size)
+
+shuffleSeries(x, mirror = FALSE, start = NULL, flip = NULL)
+
+shuffleGrid(nrow, ncol, mirror = FALSE, start.row = NULL,
+ start.col = NULL, flip = NULL)
+
+shuffleStrata(strata, type, mirror = FALSE, start = NULL, flip = NULL,
+ nrow, ncol, start.row = NULL, start.col = NULL)
+}
+
+\arguments{
+ \item{x}{vector of indices to permute.}
+ \item{size}{number of random permutations required}
+ \item{mirror}{logical; should mirroring of sequences be allowed?}
+ \item{start}{integer; the starting point for time series
+ permutations. If missing, a random starting point is determined.}
+ \item{flip}{logical, length 1 (\code{shuffleSeries}) or length 2
+ (\code{shuffleGrid}); force mirroring of permutation. This will
+ always return the reverse of the computed permutation. For
+ \code{shuffleGrid}, the first element pertains to flipping rows, the
+ second to flipping columns of the grid.}
+ \item{nrow, ncol}{numeric; the number of rows and columns in the grid.}
+ \item{start.row, start.col}{numeric; the starting row and column for
+ the shifted grid permutation. If non supplied, a random starting row
+ and column will be selected.}
+ \item{strata}{factor; the blocks to permute.}
+ \item{type}{character; the type of permutation used to shuffle the
+ \code{strata}. One of \code{"free"}, \code{"grid"} or
+ \code{"series"}.}
+}
+\details{
+}
+\value{
+}
+%\note{
+% \code{shuffle} is currently used in one Vegan function;
+% \code{\link[vegan]{permutest.betadisper}}. Over time, the other functions
+% that currently use the older \code{\link[vegan]{shuffle}} will be
+% updated to use \code{shuffle}.
+%}
+%\references{
+%}
+\author{Gavin Simpson}
+\seealso{\code{\link{permCheck}}, a utility function for checking
+ permutation scheme described by
+ \code{\link{permControl}}. \code{\link{shuffle}} as a user-oriented
+ wrapper to these functions.}
+
+\examples{
+set.seed(3)
+
+## draw 1 value at random from the set 1:10
+shuffleFree(1:10, 1)
+
+## permute the series 1:10
+x <- 1:10
+shuffleSeries(x) ## with random starting point
+shuffleSeries(x, start = 5L) ## known starting point
+shuffleSeries(x, flip = TRUE) ## random start, forced mirror
+shuffleSeries(x, mirror = TRUE) ## random start, possibly mirror
+
+## permute a grid of size 3x3
+shuffleGrid(3, 3) ## random starting row/col
+shuffleGrid(3, 3, start.row = 2,
+ start.col = 3) ## with known row/col
+shuffleGrid(3, 3, flip = rep(TRUE, 2)) ## random start, forced mirror
+}
+\keyword{ htest }
+\keyword{ design }
More information about the Vegan-commits
mailing list