[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