[Vegan-commits] r2505 - in pkg/permute: . R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jun 10 22:00:19 CEST 2013
Author: gsimpson
Date: 2013-06-10 22:00:18 +0200 (Mon, 10 Jun 2013)
New Revision: 2505
Added:
pkg/permute/man/get-methods.Rd
Modified:
pkg/permute/DESCRIPTION
pkg/permute/NAMESPACE
pkg/permute/R/getFoo-methods.R
pkg/permute/R/numPerms.R
pkg/permute/R/permControl.R
pkg/permute/inst/ChangeLog
pkg/permute/man/numPerms.Rd
pkg/permute/man/shuffle.Rd
Log:
blocks now a factor not a list, numPerms works again
Modified: pkg/permute/DESCRIPTION
===================================================================
--- pkg/permute/DESCRIPTION 2013-05-28 15:42:43 UTC (rev 2504)
+++ pkg/permute/DESCRIPTION 2013-06-10 20:00:18 UTC (rev 2505)
@@ -1,6 +1,6 @@
Package: permute
Title: Functions for generating restricted permutations of data
-Version: 0.7-2
+Version: 0.7-3
Date: $Date$
Author: Gavin L. Simpson
Maintainer: Gavin L. Simpson <gavin.simpson at ucl.ac.uk>
Modified: pkg/permute/NAMESPACE
===================================================================
--- pkg/permute/NAMESPACE 2013-05-28 15:42:43 UTC (rev 2504)
+++ pkg/permute/NAMESPACE 2013-06-10 20:00:18 UTC (rev 2505)
@@ -2,7 +2,8 @@
export(`allPerms`, `Blocks`, `numPerms`, `check`, `permCheck`,
`permControl`, `permute`, `shuffle`, `Within`, `Plots`,
`shuffleFree`, `shuffleSeries`, `shuffleGrid`, `shuffleStrata`,
- `getBlocks`, `getWithin`, `getStrata`, `getType`,
+ `getBlocks`, `getWithin`, `getStrata`, `getType`, `getMirror`,
+ `getConstant`, `getPlots`,
`shuffleSet`, `permuplot`)
### Imports: nobs() only exists in R 2.13.0 for import. We define the
@@ -31,9 +32,15 @@
## getFoo methods
S3method(`getBlocks`, `default`)
S3method(`getBlocks`, `permControl`)
+S3method(`getPlots`, `default`)
+S3method(`getPlots`, `permControl`)
S3method(`getWithin`, `default`)
S3method(`getWithin`, `permControl`)
S3method(`getStrata`, `default`)
S3method(`getStrata`, `permControl`)
S3method(`getType`, `default`)
S3method(`getType`, `permControl`)
+S3method(`getMirror`, `default`)
+S3method(`getMirror`, `permControl`)
+S3method(`getConstant`, `default`)
+S3method(`getConstant`, `permControl`)
Modified: pkg/permute/R/getFoo-methods.R
===================================================================
--- pkg/permute/R/getFoo-methods.R 2013-05-28 15:42:43 UTC (rev 2504)
+++ pkg/permute/R/getFoo-methods.R 2013-06-10 20:00:18 UTC (rev 2505)
@@ -49,13 +49,13 @@
}
getStrata.permControl <- function(object,
- which = c("plots","blocks"),
+ which = c("plots","blocks"),
drop = TRUE, ...) {
which <- match.arg(which)
if(isTRUE(all.equal(which, "plots")))
strata <- object$plots$strata
else if(isTRUE(all.equal(which, "blocks")))
- strata <- object$blocks$strata
+ strata <- object$blocks #object$blocks$strata
else
stop("Ambiguous `which`")
if(isTRUE(drop) && !is.null(strata))
@@ -65,7 +65,7 @@
## Get type of permutation
getType <- function(object, ...) {
- UseMethod("getType")
+ UseMethod("getType")
}
getType.default <- function(object, ...) {
@@ -74,14 +74,49 @@
getType.permControl <- function(object,
which = c("plots","within"), ...) {
- which <- match.arg(which)
+ which <- match.arg(which)
if(isTRUE(all.equal(which, "plots")))
- type <- getPlots(object)$type
+ type <- getPlots(object)$type
else if(isTRUE(all.equal(which, "within")))
- type <- getWithin(object)$type
+ type <- getWithin(object)$type
else
- stop("Ambiguous `which`")
+ stop("Ambiguous `which`")
type
}
## suppose we can also have setBlocks() etc...
## to update the control object in place....
+
+## Get mirroring status
+`getMirror` <- function(object, ...) {
+ UseMethod("getMirror")
+}
+
+`getMirror.default` <- function(object, ...) {
+ stop("No default method for 'getMirror()'")
+}
+
+`getMirror.permControl` <- function(object,
+ which = c("plots","within"), ...) {
+ which <- match.arg(which)
+ if(isTRUE(all.equal(which, "plots")))
+ mirror <- getPlots(object)$mirror
+ else if(isTRUE(all.equal(which, "within")))
+ mirror <- getWithin(object)$mirror
+ else
+ stop("Ambiguous `which`")
+ mirror
+}
+
+## Get constant status - i.e. same permutation in each Plot
+`getConstant` <- function(object, ...) {
+ UseMethod("getConstant")
+}
+
+`getConstant.default` <- function(object, ...) {
+ stop("No default method for 'getConstant()'")
+}
+
+`getConstant.permControl` <- function(object, ...) {
+ getWithin(object)$constant
+}
+
Modified: pkg/permute/R/numPerms.R
===================================================================
--- pkg/permute/R/numPerms.R 2013-05-28 15:42:43 UTC (rev 2504)
+++ pkg/permute/R/numPerms.R 2013-06-10 20:00:18 UTC (rev 2505)
@@ -1,108 +1,157 @@
-`numPerms` <- function(object, control = permControl())
-{
- ## constant holding types where something is permuted
- PTYPES <- c("free","grid","series","none")
- ## expand object if a numeric or integer vector of length 1
- if((is.numeric(object) || is.integer(object)) &&
- (length(object) == 1))
- object <- seq_len(object)
- ## number of observations in data
- nobs <- nobs(object)
- ## within perms object
- WITHIN <- control$within
- ## strata perms object
- BLOCKS <- control$blocks
- ## are strata present?
- STRATA <- !is.null(control$strata)
- ## check that when permuting strata or constant within strata,
- ## strata have same number of samples
- if(STRATA) {
- tab.strata <- table(control$strata)
- same.n <- length(unique(tab.strata))
- if((BLOCKS$type %in% PTYPES || isTRUE(WITHIN$constant)) &&
- same.n > 1)
- stop("All levels of strata must have same number of samples for chosen scheme")
- if(BLOCKS$type == "grid" && same.n > 1)
- stop("Unbalanced grid designs are not supported")
+`numPerms` <- function(object, control = permControl()) {
+ ## constant holding types where something is permuted
+ TYPES <- c("free","grid","series","none")
+
+ ## expand object if a numeric or integer vector of length 1
+ if((is.numeric(object) || is.integer(object)) &&
+ (length(object) == 1))
+ object <- seq_len(object)
+ ## number of observations in data
+ n <- nobs(object)
+
+ ## get the permutation levels from control
+ WI <- getWithin(control)
+ PL <- getPlots(control)
+ BL <- getBlocks(control)
+
+ ## any strata to permute within / blocking?
+ BLOCKS <- getStrata(control, which = "blocks")
+ PSTRATA <- getStrata(control, which = "plots")
+ typeP <- getType(control, which = "plots")
+ typeW <- getType(control, which = "within")
+
+ ## mirroring?
+ mirrorP <- getMirror(control, which = "plots")
+ mirrorW <- getMirror(control, which = "within")
+
+ ## constant - i.e. same perm within each plot?
+ constantW <- getConstant(control)
+
+ ## Some checks; i) Plot strata must be of same size when permuting strata
+ ## or having the same constant permutation within strata
+ ## ii) In grid designs, grids must be of the same size for all
+ ## strata
+ ##
+ ## FIXME - this probably should be in check()!
+ if(!is.null(PSTRATA)) {
+ tab <- table(PSTRATA)
+ same.n <- length(unique(tab))
+ if((typeP %in% TYPES || isTRUE(WI$constant)) && same.n > 1) {
+ stop("All levels of strata must have same number of samples for chosen scheme")
}
- ## generate multiplier for restricted permutations
- if(WITHIN$type %in% c("series","grid")) {
- within.multi <- 2
- if(WITHIN$type == "grid" && WITHIN$ncol > 2) {
- within.multi <- 4
- } else {
- if(nobs == 2)
- within.multi <- 1
- }
+ if(typeP == "grid" && same.n > 1) {
+ stop("Unbalanced grid designs are not supported")
}
- if(BLOCKS$type %in% c("series","grid")) {
- blocks.multi <- 2
- if(BLOCKS$type == "grid" && BLOCKS$ncol > 2) {
- blocks.multi <- 4
- } else {
- if(nobs == 2)
- blocks.multi <- 1
- }
+ }
+
+ ## the various designs allowed imply multipliers to number of samples
+ ## for the restricted permutations
+
+ ## within types
+ if(typeW %in% c("series","grid")) {
+ mult.wi <- 2
+ if(isTRUE(all.equal(typeW, "grid")) && typeW$ncol > 2) {
+ mult.wi <- 4
+ } else {
+ if(isTRUE(all.equal(n, 2)))
+ mult.wi <- 1
}
- ## calculate number of possible permutations
- ## blocks
- num.blocks <- 1
- if(BLOCKS$type %in% PTYPES) {
- num.blocks <- if(BLOCKS$type == "free")
- exp(lfactorial(length(levels(control$strata))))
- else if(BLOCKS$type %in% c("series","grid")) {
- if(BLOCKS$mirror)
- blocks.multi * nobs
- else
- nobs
+ }
+ ## plot-level types
+ if(typeP %in% c("series","grid")) {
+ mult.p <- 2
+ if(isTRUE(all.equal(typeP, "grid")) && typeP$ncol > 2) {
+ mult.p <- 4
+ } else {
+ if(isTRUE(all.equal(n, 2)))
+ mult.p <- 1
+ }
+ }
+
+ ## within
+ ## another check - shouldn't this be moved? FIXME
+ if(!typeW %in% TYPES) {
+ stop("Ambiguous permutation type in 'control$within$type'")
+ }
+
+ ## calculate the number of possible permutations
+
+ ## Compute number of permutations for each block
+ if(is.null(BLOCKS))
+ BLOCKS <- factor(rep(1, n))
+
+ ## split an index vector
+ indv <- seq_len(n)
+ spl <- split(indv, BLOCKS)
+
+ ## loop over the components of spl & apply doNumPerms
+ np <- lapply(spl, doNumPerms, mult.p, mult.wi, typeP, typeW, PSTRATA,
+ mirrorP, mirrorW, constantW)
+
+ ## multiply up n perms per block
+ do.call(prod, np)
+}
+
+`doNumPerms` <- function(obs, mult.p, mult.wi, typeP, typeW, PSTRATA,
+ mirrorP, mirrorW, constantW) {
+ n <- nobs(obs) ## obs is index vector for object, split by blocks
+
+ ## need only those strata for the current block. As obs is the index
+ ## vector, split by block, this now gives nobs per plot strata
+ tab <- table(PSTRATA[obs])
+ same.n <- length(unitab <- unique(tab))
+
+ ## plots
+ num.p <- if(isTRUE(all.equal(typeP, "free"))) {
+ exp(lfactorial(length(levels(PSTRATA))))
+ } else if(typeP %in% c("series", "grid")) {
+ if(isTRUE(mirrorP)) {
+ mult.p * n
} else {
- 1
+ n
}
+ } else {
+ 1
}
- ## within
- if(!(WITHIN$type %in% PTYPES))
- stop("Ambiguous permutation type in 'control$within$type'")
- num.within <- if(WITHIN$type == "none") {
- ## no within permutations
- ## recall this is what we multiply num.blocks
- ## by hence not 0
+ num.wi <- if(isTRUE(all.equal(typeW, "none"))) {
+ ## no within permutations. note we multiply num.p by this
+ ## values so it is 1 not 0!!
1
- } else if(WITHIN$type == "free") {
- if(STRATA)
- prod(factorial(tab.strata))
- else
- exp(lfactorial(nobs))
+ } else if(isTRUE(all.equal(typeW, "free"))) {
+ if(!is.null(PSTRATA)) {
+ prod(factorial(tab))
+ } else {
+ exp(lfactorial(n))
+ }
} else {
- ##} else if(WITHIN$type %in% c("series","grid")) {
- if(STRATA) {
+ if(!is.null(PSTRATA)) {
if(same.n > 1) {
- multi <- rep(2, length = length(tab.strata))
- multi[which(tab.strata == 2)] <- 1
- if(WITHIN$mirror) {
- prod(multi * tab.strata)
+ multi <- rep(2, length = length(tab))
+ multi[which(tab == 2)] <- 1
+ if(mirrorW) {
+ prod(multi * tab)
} else {
- prod(tab.strata)
+ prod(tab)
}
} else {
- if(WITHIN$mirror) {
- if(WITHIN$constant)
- within.multi * unique(tab.strata)
+ if(mirrorW) {
+ if(constantW)
+ mult.wi * unitab
else
- prod(within.multi * tab.strata)
+ prod(mult.wi * tab)
} else {
- if(WITHIN$constant)
- unique(tab.strata)
+ if(constantW)
+ unitab ## FIXME: unitab[1]?? (unique(tab)[1])
else
- prod(tab.strata)
+ prod(tab)
}
}
} else {
- if(WITHIN$mirror)
- within.multi * nobs
+ if(mirrorW)
+ mult.wi * n
else
- nobs
+ n
}
}
- return(num.blocks * num.within)
}
Modified: pkg/permute/R/permControl.R
===================================================================
--- pkg/permute/R/permControl.R 2013-05-28 15:42:43 UTC (rev 2504)
+++ pkg/permute/R/permControl.R 2013-06-10 20:00:18 UTC (rev 2505)
@@ -16,7 +16,7 @@
`permControl` <- function(within = Within(),
plots = Plots(),
- blocks = Blocks(),
+ blocks = NULL, #Blocks(),
nperm = 199, complete = FALSE,
maxperm = 9999, minperm = 99,
all.perms = NULL,
@@ -28,5 +28,5 @@
all.perms = all.perms, observed = observed,
name.strata = deparse(substitute(strata)))
class(out) <- "permControl"
- return(out)
+ out
}
Modified: pkg/permute/inst/ChangeLog
===================================================================
--- pkg/permute/inst/ChangeLog 2013-05-28 15:42:43 UTC (rev 2504)
+++ pkg/permute/inst/ChangeLog 2013-06-10 20:00:18 UTC (rev 2505)
@@ -2,6 +2,21 @@
permute ChangeLog
+Version 0.7-3
+
+ * Tweak to 0.7-2 API changes: argument `blocks` no longer takes
+ a list from helper function `Blocks()`. It is easier and simpler
+ if this just takes a factor. In essence, `blocks` in synonymous
+ with `strata` from `vegan::permuted.index` and the new change will
+ allow for an easier transition.
+
+ * get-methods: New extractor functions `getMirror()`, and
+ `getConstant()` which retrieve the mirroring and constant elements
+ of a permutation design.
+
+ * numPerms: updated to work with the new API and now handles
+ blocking. Exmaples now pass checks again.
+
Version 0.7-2
* Major API change: Added capability to handle true blocking
Added: pkg/permute/man/get-methods.Rd
===================================================================
--- pkg/permute/man/get-methods.Rd (rev 0)
+++ pkg/permute/man/get-methods.Rd 2013-06-10 20:00:18 UTC (rev 2505)
@@ -0,0 +1,89 @@
+\name{get-methods}
+\alias{get-methods}
+\alias{getBlocks}
+\alias{getBlocks.default}
+\alias{getBlocks.permControl}
+\alias{getWithin}
+\alias{getWithin.default}
+\alias{getWithin.permControl}
+\alias{getStrata}
+\alias{getStrata.default}
+\alias{getStrata.permControl}
+\alias{getType}
+\alias{getType.default}
+\alias{getType.permControl}
+\alias{getMirror}
+\alias{getMirror.default}
+\alias{getMirror.permControl}
+\alias{getConstant}
+\alias{getConstant.default}
+\alias{getConstant.permControl}
+\alias{getPlots}
+\alias{getPlots.default}
+\alias{getPlots.permControl}
+
+\title{Extractor functions to access components of a permutation design}
+\description{
+ Simple functions to allow abstracted access to components of a
+ permutation design, for example as returned by
+ \code{\link{permControl}}. Whilst many of these are very simple index
+ opertations on a list, using these rather than directly accessing that
+ list allows the internal representation of the permutation design to
+ change without breaking code.
+}
+\usage{
+
+getWithin(object, ...)
+
+\method{getWithin}{permControl}(object, ...)
+
+getPlots(object, ...)
+
+\method{getPlots}{permControl}(object, ...)
+
+getBlocks(object, ...)
+
+\method{getBlocks}{permControl}(object, ...)
+
+getStrata(object, ...)
+
+\method{getStrata}{permControl}(object, which = c("plots", "blocks"),
+drop = TRUE, ...)
+
+getType(object, ...)
+
+\method{getType}{permControl}(object, which = c("plots", "within"), ...)
+
+getMirror(object, ...)
+
+\method{getMirror}{permControl}(object, which = c("plots", "within"), ...)
+
+getConstant(object, ...)
+
+\method{getConstant}{permControl}(object, ...)
+}
+
+\arguments{
+ \item{object}{An R object to dispatch on.}
+ \item{which}{character; which level of restriction to extract
+ information for.}
+ \item{drop}{logical; should un-used factor levels be dropped?}
+ \item{\dots}{Arguments passed on to other methods.}
+}
+\details{
+ TODO
+}
+\value{
+ TODO
+}
+\author{Gavin Simpson}
+\seealso{\code{\link{check}}, a utility function for checking
+ permutation scheme described by \code{\link{permControl}}.
+}
+
+\examples{
+set.seed(1234)
+
+}
+\keyword{ methods }
+\keyword{ utils }
\ No newline at end of file
Modified: pkg/permute/man/numPerms.Rd
===================================================================
--- pkg/permute/man/numPerms.Rd 2013-05-28 15:42:43 UTC (rev 2504)
+++ pkg/permute/man/numPerms.Rd 2013-06-10 20:00:18 UTC (rev 2505)
@@ -64,7 +64,6 @@
\code{\link{permControl}}. Additional \code{\link{nobs}} methods are
provide, see \code{\link{nobs-methods}}.}
\examples{
-\dontrun{ %FIXME update this for blocks
## permutation design --- see ?permControl
ctrl <- permControl() ## defaults to freely exchangeable
@@ -82,8 +81,17 @@
ctrl <- permControl(within = Within(type = "series"))
numPerms(v, control = ctrl)
## number of permutations possible drastically reduced...
-## turn on mirroring
+## ...turn on mirroring
ctrl <- permControl(within = Within(type = "series", mirror = TRUE))
numPerms(v, control = ctrl)
+
+## Try blocking - 2 groups of 5
+bl <- numPerms(v, control = permControl(blocks = gl(2,5)))
+bl
+
+## should be same as
+pl <- numPerms(v, control = permControl(plots =
+ Plots(strata = gl(2,5))))
+pl
+stopifnot(all.equal(bl, pl))
}
-}
Modified: pkg/permute/man/shuffle.Rd
===================================================================
--- pkg/permute/man/shuffle.Rd 2013-05-28 15:42:43 UTC (rev 2504)
+++ pkg/permute/man/shuffle.Rd 2013-06-10 20:00:18 UTC (rev 2505)
@@ -6,18 +6,6 @@
\alias{Plots}
\alias{print.permControl}
\alias{permute}
-\alias{getBlocks}
-\alias{getBlocks.default}
-\alias{getBlocks.permControl}
-\alias{getWithin}
-\alias{getWithin.default}
-\alias{getWithin.permControl}
-\alias{getStrata}
-\alias{getStrata.default}
-\alias{getStrata.permControl}
-\alias{getType}
-\alias{getType.default}
-\alias{getType.permControl}
\title{Unrestricted and restricted permutations}
\description{
@@ -27,7 +15,7 @@
\usage{
shuffle(n, control = permControl())
-permControl(within = Within(), plots = Plots(), blocks = Blocks(),
+permControl(within = Within(), plots = Plots(), blocks = NULL,
nperm = 199, complete = FALSE, maxperm = 9999,
minperm = 99, all.perms = NULL, observed = FALSE)
@@ -38,26 +26,7 @@
Plots(strata = NULL, type = c("free","series","grid","none"),
mirror = FALSE, ncol = NULL, nrow = NULL)
-Blocks(strata = NULL)
-
permute(i, n, control)
-
-getWithin(object, ...)
-
-\method{getWithin}{permControl}(object, ...)
-
-getBlocks(object, ...)
-
-\method{getBlocks}{permControl}(object, ...)
-
-getStrata(object, ...)
-
-\method{getStrata}{permControl}(object, which = c("plots", "blocks"),
-drop = TRUE, ...)
-
-getType(object, ...)
-
-\method{getType}{permControl}(object, which = c("plots", "within"), ...)
}
\arguments{
@@ -74,7 +43,10 @@
\item{within, plots, blocks}{Permutation designs for samples within the
levels of \code{plots} (\code{within}), permutation of \code{plots}
themselves, or for the definition of blocking structures which
- further restrict permutations (\code{blocks}.}
+ further restrict permutations (\code{blocks}. \code{within} and
+ \code{plots} each require a named list as produced by \code{Within}
+ and \code{Plots} respectively. \code{blocks} takes a factor, the
+ levels of which define the blocking structure.}
\item{type}{the type of permutations required. One of \code{"free"},
\code{"series"}, \code{"grid"} or \code{"none"}. See Details.}
\item{maxperm}{the maximum number of permutations to
@@ -93,10 +65,6 @@
\item{ncol, nrow}{numeric; the number of columns and rows of samples
in the spatial grid respectively.}
\item{i}{integer; row of \code{control$all.perms} to return.}
- \item{object}{An R object to dispatch on.}
- \item{which}{character; which level of restriction to extract
- information for.}
- \item{drop}{logical; should un-used factor levels be dropped?}
\item{\dots}{Arguments passed on to other methods.}
}
\details{
@@ -240,6 +208,11 @@
within = Within(type = "free"))
shuffle(20, CTRL)
+## permuting within blocks
+grp <- gl(2, 10) # 2 groups of 10 samples each
+CTRL <- permControl(blocks = grp)
+shuffle(length(grp), control = CTRL)
+
## Simple function using permute() to assess significance
## of a t.test
pt.test <- function(x, group, control) {
More information about the Vegan-commits
mailing list