[Vegan-commits] r2511 - in pkg/permute: . R inst man tests/Examples vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jun 12 07:12:53 CEST 2013
Author: gsimpson
Date: 2013-06-12 07:12:52 +0200 (Wed, 12 Jun 2013)
New Revision: 2511
Added:
pkg/permute/man/permControl-dprecated.Rd
Modified:
pkg/permute/DESCRIPTION
pkg/permute/NAMESPACE
pkg/permute/R/Plots.R
pkg/permute/R/allPerms.R
pkg/permute/R/allStrata.R
pkg/permute/R/getFoo-methods.R
pkg/permute/R/how.R
pkg/permute/R/numPerms.R
pkg/permute/R/permCheck.R
pkg/permute/R/permControl.R
pkg/permute/R/permuplot.R
pkg/permute/R/print.how.R
pkg/permute/R/print.permControl.R
pkg/permute/R/shuffle.R
pkg/permute/R/shuffle2.R
pkg/permute/R/shuffleSet.R
pkg/permute/R/shuffleSet2.R
pkg/permute/inst/ChangeLog
pkg/permute/man/allPerms.Rd
pkg/permute/man/allUtils.Rd
pkg/permute/man/get-methods.Rd
pkg/permute/man/how.Rd
pkg/permute/man/numPerms.Rd
pkg/permute/man/permCheck.Rd
pkg/permute/man/shuffle-utils.Rd
pkg/permute/man/shuffle.Rd
pkg/permute/man/shuffleSet.Rd
pkg/permute/tests/Examples/permute-Ex.Rout.save
pkg/permute/vignettes/permutations.Rnw
Log:
another big check-in fixing many issues associated with getting allPerms and check working again; deprecate permControl; lots of new helper getFoo methods
Modified: pkg/permute/DESCRIPTION
===================================================================
--- pkg/permute/DESCRIPTION 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/DESCRIPTION 2013-06-12 05:12:52 UTC (rev 2511)
@@ -3,7 +3,7 @@
Version: 0.7-3
Date: $Date$
Author: Gavin L. Simpson
-Maintainer: Gavin L. Simpson <gavin.simpson at ucl.ac.uk>
+Maintainer: Gavin L. Simpson <gavin.simpson at uregina.ca>
Suggests: vegan (>= 2.0-0), testthat (>= 0.5)
Description: The 'permute' package implements a set of restricted permutation
designs for freely exchangeable, line transects (time series),
Modified: pkg/permute/NAMESPACE
===================================================================
--- pkg/permute/NAMESPACE 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/NAMESPACE 2013-06-12 05:12:52 UTC (rev 2511)
@@ -3,8 +3,9 @@
`permControl`, `permute`, `shuffle`, `Within`, `Plots`,
`shuffleFree`, `shuffleSeries`, `shuffleGrid`, `shuffleStrata`,
`getBlocks`, `getWithin`, `getStrata`, `getType`, `getMirror`,
- `getConstant`, `getPlots`,
- `shuffleSet`, `permuplot`, `how`)
+ `getConstant`, `getPlots`, `getRow`, `getCol`, `getDim`,
+ `getNperm`,`getMaxperm`, `getMinperm`, `getComplete`, `shuffleSet`,
+ `permuplot`,`how`)
### Imports: nobs() only exists in R 2.13.0 for import. We define the
### same nobs() generic in permute for export in older R.
@@ -32,16 +33,35 @@
S3method(`nobs`, `data.frame`)
## getFoo methods
S3method(`getBlocks`, `default`)
+S3method(`getBlocks`, `how`)
S3method(`getBlocks`, `permControl`)
S3method(`getPlots`, `default`)
+S3method(`getPlots`, `how`)
S3method(`getPlots`, `permControl`)
S3method(`getWithin`, `default`)
+S3method(`getWithin`, `how`)
S3method(`getWithin`, `permControl`)
S3method(`getStrata`, `default`)
+S3method(`getStrata`, `how`)
S3method(`getStrata`, `permControl`)
S3method(`getType`, `default`)
+S3method(`getType`, `how`)
S3method(`getType`, `permControl`)
S3method(`getMirror`, `default`)
+S3method(`getMirror`, `how`)
S3method(`getMirror`, `permControl`)
S3method(`getConstant`, `default`)
+S3method(`getConstant`, `how`)
S3method(`getConstant`, `permControl`)
+S3method(`getNperm`, `default`)
+S3method(`getNperm`, `how`)
+S3method(`getNperm`, `permControl`)
+S3method(`getMaxperm`, `default`)
+S3method(`getMaxperm`, `how`)
+S3method(`getMaxperm`, `permControl`)
+S3method(`getMinperm`, `default`)
+S3method(`getMinperm`, `how`)
+S3method(`getMinperm`, `permControl`)
+S3method(`getComplete`, `default`)
+S3method(`getComplete`, `how`)
+S3method(`getComplete`, `permControl`)
Modified: pkg/permute/R/Plots.R
===================================================================
--- pkg/permute/R/Plots.R 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/R/Plots.R 2013-06-12 05:12:52 UTC (rev 2511)
@@ -1,8 +1,9 @@
-`Plots` <- function(strata = NULL, type = c("free","series","grid","none"),
+`Plots` <- function(strata = NULL, type = c("none","free","series","grid"),
mirror = FALSE, ncol = NULL, nrow = NULL) {
type <- match.arg(type)
out <- list(strata = strata, type = type, mirror = mirror,
- ncol = ncol, nrow = nrow)
+ ncol = ncol, nrow = nrow,
+ plots.name = deparse(substitute(strata)))
## keep as list for now
##class(out) <- "Plots"
out
Modified: pkg/permute/R/allPerms.R
===================================================================
--- pkg/permute/R/allPerms.R 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/R/allPerms.R 2013-06-12 05:12:52 UTC (rev 2511)
@@ -1,4 +1,4 @@
-`allPerms` <- function(n, control = permControl(), max = 9999,
+`allPerms` <- function(n, control = how(), max = 9999,
observed = FALSE) {
## start
v <- n
@@ -76,7 +76,8 @@
## permuting within?
if (typeW != "none") {
- if(is.null(strataP)) { ## no plot-level permutations
+ if(is.null(strataP)) {
+ ## no plot-level permutations
res <- switch(typeW,
free = allFree(n),
series = allSeries(n, nperms, mirrorW),
@@ -89,7 +90,7 @@
if(constantW) {
## same permutation in each plot
##pg <- unique(tab)
- controlW <- permControl(within = getWithin(control))
+ controlW <- how(within = getWithin(control))
nperms <- numPerms(pg, controlW)
ord <- switch(typeW,
free = allFree(pg),
@@ -113,7 +114,7 @@
## FIXME: this should not be needed once all checks are
## in place in check()
stop("Unbalanced grid designs are not supported")
- controlW <- permControl(within = getWithin(control))
+ controlW <- how(within = getWithin(control))
sp <- split(obs, strataP)
res <- vector(mode = "list", length = ng)
add <- c(0, cumsum(tab)[1:(ng-1)])
@@ -141,7 +142,7 @@
unlist(sp), obs))
} else {
## same number of observations per level of strata
- controlW <- permControl(within = getWithin(control))
+ controlW <- how(within = getWithin(control))
np <- numPerms(pg, controlW)
ord <-
switch(typeW,
@@ -171,7 +172,7 @@
}
}
## Do we need to permute plots?
- if (!is.null(strataP)) {
+ if (!is.null(strataP) && !isTRUE(all.equal(typeP, "none"))) {
## permuting plots ONLY
if(typeW == "none") {
res <- allStrata(n, control = control)
@@ -179,8 +180,11 @@
## FIXME - this need updating to work with the new code
## permuting blocks AND within blocks
## need a local CONTROL that just permutes blocks
- controlP <- permControl(plots = Plots(strata = strataP),
+ controlP <- how(plots = Plots(strata = strataP, type = typeP),
within = Within(type = "none"))
+ ## FIXME - the above should really only need to update
+ ## within as shown, not fiddle with Plots
+
## number of permutations for just the block level
permP <- numPerms(n, control = controlP)
## get all permutations for the block level
@@ -211,9 +215,9 @@
## enumerate all possible permutations for a more complicated
## design
## fac <- gl(2,6)
-##ctrl <- permControl(type = "grid", mirror = FALSE, strata = fac,
+##ctrl <- how(type = "grid", mirror = FALSE, strata = fac,
## constant = TRUE, nrow = 3, ncol = 2)
-## ctrl <- permControl(strata = fac,
+## ctrl <- how(strata = fac,
## within = Within(type = "grid", mirror = FALSE,
## constant = TRUE, nrow = 3, ncol = 2),
## blocks = Blocks(type = "free"))
@@ -222,137 +226,3 @@
## numPerms(Nobs, control = ctrl) ## works just as well
## (tmp <- allPerms(Nobs, control = ctrl, observed = TRUE))
## (tmp2 <- allPerms(Nobs, control = ctrl))
-
-## just in case, keep this for now so I have something to look at before comitting
-
-
- ## if(typeW != "none") {
- ## if(is.null(strataP)) {
- ## res <- switch(type.wi,
- ## free = allFree(n),
- ## series = allSeries(n, nperms, WI$mirror),
- ## grid = allGrid(n, nperms, WI$nrow,
- ## WI$ncol, WI$mirror, WI$constant))
- ## } else {
- ## ## permuting within blocks
- ## tab <- table(STRATA)
- ## if(WI$constant) {
- ## ## same permutation in each block
- ## pg <- unique(tab)
- ## control.wi <- permControl(within = WI)
- ## nperms <- numPerms(pg, control.wi)
- ## ord <- switch(type.wi,
- ## free = allFree(pg),
- ## series = allSeries(pg, nperms, WI$mirror),
- ## grid = allGrid(pg, nperms, WI$nrow,
- ## WI$ncol, WI$mirror,
- ## WI$constant))
- ## perm.wi <- nrow(ord)
- ## sp <- split(v, STRATA)
- ## res <- matrix(nrow = nperms, ncol = n)
- ## for(i in seq_len(perm.wi))
- ## #res[i,] <- t(sapply(sp, function(x) x[ord[i,]]))
- ## res[i,] <- sapply(sp, function(x) x[ord[i,]])
- ## } else {
- ## ## different permutations within blocks
- ## tab <- table(STRATA)
- ## ng <- length(tab)
- ## pg <- unique(tab)
- ## if(length(pg) > 1) {
- ## ## different number of observations per level of strata
- ## if(type.wi == "grid")
- ## ## FIXME: this should not be needed once all checks are
- ## ## in place in check()
- ## stop("Unbalanced grid designs are not supported")
- ## control.wi <- permControl(within = WI)
- ## sp <- split(v, STRATA)
- ## res <- vector(mode = "list", length = ng)
- ## add <- c(0, cumsum(tab)[1:(ng-1)])
- ## for(j in seq_along(tab)) {
- ## np <- numPerms(tab[j], control.wi)
- ## ord <- switch(type.wi,
- ## free = allFree(tab[j]),
- ## series = allSeries(tab[j], np, WI$mirror))
- ## perm.wi <- nrow(ord)
- ## if(j == 1) {
- ## a <- 1
- ## b <- np / perm.wi
- ## } else {
- ## b <- b/perm.wi
- ## a <- np / (b*perm.wi)
- ## }
- ## res[[j]] <- matrix(rep(repMat(ord+add[j], a),
- ## each = b),
- ## ncol = tab[j])
- ## }
- ## res <- do.call(cbind, res)
- ## sp <- split(v, STRATA)
- ## res <- t(apply(res, 1,
- ## function(x, inds, v) {v[inds] <- inds[x]; v},
- ## unlist(sp), v))
- ## } else {
- ## ## same number of observations per level of strata
- ## control.wi <- permControl(within = WI)
- ## np <- numPerms(pg, control.wi)
- ## ord <-
- ## switch(type.wi,
- ## free = allFree(pg),
- ## series = allSeries(pg, np, WI$mirror),
- ## grid = allGrid(pg, np, WI$nrow,
- ## WI$ncol, WI$mirror,
- ## WI$constant))
- ## perm.wi <- nrow(ord)
- ## add <- seq(from = 0, by = pg, length.out = ng)
- ## res <- vector(mode = "list", length = ng)
- ## a <- 1
- ## b <- np / perm.wi
- ## for(i in seq_len(ng)) {
- ## res[[i]] <- matrix(rep(repMat(ord+add[i], a),
- ## each = b),
- ## ncol = pg)
- ## a <- a*perm.wi
- ## b <- b/perm.wi
- ## }
- ## res <- do.call(cbind, res)
- ## sp <- split(v, STRATA)
- ## res <- t(apply(res, 1,
- ## function(x, inds, v) {v[inds] <- inds[x]; v},
- ## unlist(sp), v))
- ## }
- ## }
- ## }
- ## }
- ## ## Do we need to permute blocks?
- ## if ((type.b <- control$blocks$type) != "none") {
- ## ## permuting blocks ONLY
- ## if(type.wi == "none") {
- ## res <- allStrata(n, control = control)
- ## } else {
- ## ## FIXME - this need updating to work with the new code
- ## ## permuting blocks AND within blocks
- ## ## need a local CONTROL that just permutes blocks
- ## control.b <- permControl(strata = STRATA,
- ## within = Within(type = "none"),
- ## blocks = getBlocks(control))
- ## ## number of permutations for just the block level
- ## perm.b <- numPerms(n, control = control.b)
- ## ## get all permutations for the block level
- ## shuff.b <- allStrata(n, control = control.b)
- ## ## copy the set of permutations for within blocks
- ## ## perm.b times - results is a list
- ## res.b <- rep(list(res), perm.b)
- ## res.b <- lapply(seq_along(res.b),
- ## function(i, wi, bl) {
- ## t(apply(wi[[i]], 1,
- ## function(x, bl, i) {
- ## x[bl[i,]]
- ## }, bl = bl, i = i))
- ## },
- ## wi = res.b, bl = shuff.b)
- ## res <- do.call(rbind, res.b)
- ## }
- ## }
- ## ## some times storage.mode of res is numeric, sometimes
- ## ## it is integer, set to "integer" for comparisons using
- ## ## identical to match the observed ordering
- ## storage.mode(res) <- "integer"
Modified: pkg/permute/R/allStrata.R
===================================================================
--- pkg/permute/R/allStrata.R 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/R/allStrata.R 2013-06-12 05:12:52 UTC (rev 2511)
@@ -8,7 +8,7 @@
## compute nperms on number of levels - for this need Within()
## and type == typeP
newControl <-
- permControl(within = Within(type = getType(control, which = "plots")))
+ how(within = Within(type = getType(control, which = "plots")))
nperms <- numPerms(lev, newControl)
## result object
X <- matrix(nrow = nperms, ncol = length(strata))
Modified: pkg/permute/R/getFoo-methods.R
===================================================================
--- pkg/permute/R/getFoo-methods.R 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/R/getFoo-methods.R 2013-06-12 05:12:52 UTC (rev 2511)
@@ -13,6 +13,10 @@
object$blocks
}
+getBlocks.how <- function(object, ...) {
+ object$blocks
+}
+
## Plots
getPlots <- function(object, ...) {
UseMethod("getPlots")
@@ -26,6 +30,10 @@
object$plots
}
+getPlots.how <- function(object, ...) {
+ object$plots
+}
+
## Within plots
getWithin <- function(object, ...) {
UseMethod("getWithin")
@@ -39,6 +47,10 @@
object$within
}
+getWithin.how <- function(object, ...) {
+ object$within
+}
+
## Strata
getStrata <- function(object, ...) {
UseMethod("getStrata")
@@ -49,6 +61,20 @@
}
getStrata.permControl <- function(object,
+ 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
+ stop("Ambiguous `which`")
+ if(isTRUE(drop) && !is.null(strata))
+ strata <- droplevels(strata)
+ strata
+}
+
+getStrata.how <- function(object,
which = c("plots","blocks"),
drop = TRUE, ...) {
which <- match.arg(which)
@@ -83,6 +109,19 @@
stop("Ambiguous `which`")
type
}
+
+getType.how <- function(object,
+ which = c("plots","within"), ...) {
+ which <- match.arg(which)
+ if(isTRUE(all.equal(which, "plots")))
+ type <- getPlots(object)$type
+ else if(isTRUE(all.equal(which, "within")))
+ type <- getWithin(object)$type
+ else
+ stop("Ambiguous `which`")
+ type
+}
+
## suppose we can also have setBlocks() etc...
## to update the control object in place....
@@ -107,6 +146,18 @@
mirror
}
+`getMirror.how` <- 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")
@@ -120,6 +171,10 @@
getWithin(object)$constant
}
+`getConstant.how` <- function(object, ...) {
+ getWithin(object)$constant
+}
+
## Get the number of rows and colums from grid designs
`getRow` <- function(object, ...) {
UseMethod("getRow")
@@ -141,6 +196,18 @@
nrow
}
+`getRow.how` <- function(object, which = c("plots","within"),
+ ...) {
+ which <- match.arg(which)
+ if(isTRUE(all.equal(which, "plots")))
+ nrow <- getPlots(object)$nrow
+ else if(isTRUE(all.equal(which, "within")))
+ nrow <- getWithin(object)$nrow
+ else
+ stop("Ambiguous `which`")
+ nrow
+}
+
`getCol` <- function(object, ...) {
UseMethod("getCol")
}
@@ -161,6 +228,18 @@
ncol
}
+`getCol.how` <- function(object, which = c("plots","within"),
+ ...) {
+ which <- match.arg(which)
+ if(isTRUE(all.equal(which, "plots")))
+ ncol <- getPlots(object)$ncol
+ else if(isTRUE(all.equal(which, "within")))
+ ncol <- getWithin(object)$ncol
+ else
+ stop("Ambiguous `which`")
+ ncol
+}
+
`getDim` <- function(object, ...) {
UseMethod("getDim")
}
@@ -185,3 +264,90 @@
}
c(nr, nc)
}
+
+`getDim.how` <- function(object, which = c("plots","within"),
+ ...) {
+ which <- match.arg(which)
+ if(isTRUE(all.equal(which, "plots"))) {
+ PL <- getPlots(object)
+ nc <- PL$ncol
+ nr <- PL$nrow
+ } else if(isTRUE(all.equal(which, "within"))) {
+ WI <- getWithin(object)
+ nc <- WI$ncol
+ nr <- WI$nrow
+ } else {
+ stop("Ambiguous `which`")
+ }
+ c(nr, nc)
+}
+
+## return the requested number of permutations
+`getNperm` <- function(object, ...) {
+ UseMethod("getNperm")
+}
+
+`getNperm.default` <- function(object, ...) {
+ stop("No default method for `getNperm`")
+}
+
+`getNperm.permControl` <- function(object, ...) {
+ object$nperm
+}
+
+`getNperm.how` <- function(object, ...) {
+ object$nperm
+}
+
+## Returns maximum permutation threshold
+`getMaxperm` <- function(object, ...) {
+ UseMethod("getMaxperm")
+}
+
+`getMaxperm.default` <- function(object, ...) {
+ stop("No default method for `getMaxperm`")
+}
+
+`getMaxperm.permControl` <- function(object, ...) {
+ object$maxperm
+}
+
+`getMaxperm.how` <- function(object, ...) {
+ object$maxperm
+}
+
+## Returns minimum permutation threshold
+`getMinperm` <- function(object, ...) {
+ UseMethod("getMinperm")
+}
+
+`getMinperm.default` <- function(object, ...) {
+ stop("No default method for `getMinperm`")
+}
+
+`getMinperm.permControl` <- function(object, ...) {
+ object$minperm
+}
+
+`getMinperm.how` <- function(object, ...) {
+ object$minperm
+}
+
+## Returns status of complete enumeration
+`getComplete` <- function(object, ...) {
+ UseMethod("getComplete")
+}
+
+`getComplete.default` <- function(object, ...) {
+ stop("No default method for `getComplete`")
+}
+
+`getComplete.permControl` <- function(object, ...) {
+ list(complete = object$complete,
+ minperm = object$minperm)
+}
+
+`getComplete.how` <- function(object, ...) {
+ list(complete = object$complete,
+ minperm = object$minperm)
+}
Modified: pkg/permute/R/how.R
===================================================================
--- pkg/permute/R/how.R 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/R/how.R 2013-06-12 05:12:52 UTC (rev 2511)
@@ -12,7 +12,7 @@
nperm = nperm, complete = complete,
maxperm = maxperm, minperm = minperm,
all.perms = all.perms, observed = observed,
- name.strata = deparse(substitute(strata)))
+ blocks.name = deparse(substitute(blocks)))
class(out) <- "how"
out
}
Modified: pkg/permute/R/numPerms.R
===================================================================
--- pkg/permute/R/numPerms.R 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/R/numPerms.R 2013-06-12 05:12:52 UTC (rev 2511)
@@ -1,4 +1,4 @@
-`numPerms` <- function(object, control = permControl()) {
+`numPerms` <- function(object, control = how()) {
## constant holding types where something is permuted
TYPES <- c("free","grid","series","none")
@@ -40,7 +40,7 @@
if(!is.null(PSTRATA)) {
tab <- table(PSTRATA)
same.n <- length(unique(tab))
- if((typeP %in% TYPES || isTRUE(constantW)) && same.n > 1) {
+ if((typeP != "none" || isTRUE(constantW)) && same.n > 1) {
stop("All levels of strata must have same number of samples for chosen scheme")
}
if(typeP == "grid" && same.n > 1) {
Modified: pkg/permute/R/permCheck.R
===================================================================
--- pkg/permute/R/permCheck.R 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/R/permCheck.R 2013-06-12 05:12:52 UTC (rev 2511)
@@ -1,51 +1,80 @@
-`check` <- function(object, control = permControl(),
- make.all = TRUE)
+`check` <- function(object, control = how(), make.all = TRUE)
{
## if object is numeric or integer and of length 1,
## extend the object
if(length(object) == 1 &&
(is.integer(object) || is.numeric(object)))
object <- seq_len(object)
+
## check the number of observations in object
- nobs <- nobs(object)
+ N <- nobs(object)
+
## sample permutation type
- type <- control$within$type
- ## if strata, check nobs == length of strata
- ## but beware empty levels
- if(!is.null(control$strata)) {
- tab <- table(control$strata)
- if(!identical(as.integer(nobs), as.integer(sum(tab))))
- stop("Number of observations and length of 'strata' do not match.")
+ typeW <- getType(control, which = "within")
+ typeP <- getType(control, which = "plots")
+
+ ## strata at plot & block levels
+ plots <- getStrata(control, which = "plots")
+ blocks <- getStrata(control, which = "blocks")
+
+ ## if strata, check N == length of strata but beware empty levels
+ if(!is.null(plots)) {
+ tab <- table(plots)
+ if(!identical(as.integer(N), as.integer(sum(tab))))
+ stop("Number of observations and length of Plot 'strata' do not match.")
+
## if "grid", check design balanced?
- if((bal <- length(unique(tab))) > 1 && type == "grid")
+ if((bal <- length(unique(tab))) > 1 && typeW == "grid")
stop("Unbalanced 'grid' designs are not supported.")
- ## if grid design, check nrow*ncol is multiple of nobs
- if(type == "grid" &&
- !identical(nobs %% (control$within$ncol *
- control$within$nrow), 0))
- stop("'nrow' * 'ncol' not a multiple of number of observations.")
+
+ ## if grid design, check nrow*ncol is multiple of N
+ if(typeW == "grid" &&
+ !identical(N %% prod(getDim(control, which = "within")), 0))
+ stop("Within 'nrow' * 'ncol' not a multiple of number of observations.")
+
## if constant, check design balanced?
- if(control$within$constant && bal > 1)
+ if(getConstant(control) && bal > 1)
stop("Unbalanced designs not allowed with 'constant = TRUE'.")
+
## if permuting strata, must be balanced
- if(control$blocks$type != "none" && bal > 1)
+ if(typeP != "none" && bal > 1)
stop("Design must be balanced if permuting 'strata'.")
+
+ ## if permuting Plots as a grid check dimensions match levels of
+ ## Plot-level strata
+ if(isTRUE(all.equal(typeP, "grid"))) {
+ levP <- levels(Plots)
+ dimP <- getDim(control, which = "plots")
+ if(!identical(levP, prod(dimP))) {
+ stop("Plot 'nrow' * 'ncol' not a multiple of number of Plots.")
+ }
+ }
}
+
+ ## check length of Blocks is equal to N
+ if(!is.null(blocks)) {
+ if(!isTRUE(all.equal(length(blocks), N)))
+ stop("Number of observations and length of Block 'strata' do not match.")
+ }
+
## check allPerms is of correct form
if(!is.null(control$all.perms) &&
- !identical(class(control$all.perms), "allPerms"))
+ !inherits(control$all.perms, "allPerms"))
stop("'control$all.perms' must be of class 'allPerms'.")
+
## get number of possible permutations
num.pos <- numPerms(object, control)
+
## if number of possible perms < minperm turn on complete enumeration
- if(num.pos < control$minperm) {
+ if(num.pos < getMinperm(control)) {
control$nperm <- control$maxperm <- num.pos
control$complete <- TRUE
}
+
## if complete enumeration, generate all permutations
- if(control$complete && make.all) {
- control$all.perms <- allPerms(nobs, control = control,
- max = control$maxperm,
+ if(getComplete(control)$complete && make.all) {
+ control$all.perms <- allPerms(N, control = control,
+ max = getMaxperm(control),
observed = FALSE)
}
retval <- list(n = num.pos, control = control)
@@ -54,7 +83,7 @@
}
## deprecate check
-`permCheck` <- function(object, control = permControl(),
+`permCheck` <- function(object, control = how(),
make.all = TRUE) {
.Deprecated(new = "check", "permute")
check(object = object, control = control, make.all = make.all)
Modified: pkg/permute/R/permControl.R
===================================================================
--- pkg/permute/R/permControl.R 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/R/permControl.R 2013-06-12 05:12:52 UTC (rev 2511)
@@ -1,16 +1,17 @@
`permControl` <- function(within = Within(),
plots = Plots(),
- blocks = NULL, #Blocks(),
+ blocks = NULL,
nperm = 199, complete = FALSE,
maxperm = 9999, minperm = 99,
all.perms = NULL,
observed = FALSE)
{
+ .Deprecated("how", package = "permute")
out <- list(within = within, plots = plots, blocks = blocks,
nperm = nperm, complete = complete,
maxperm = maxperm, minperm = minperm,
all.perms = all.perms, observed = observed,
- name.strata = deparse(substitute(strata)))
- class(out) <- "permControl"
+ blocks.name = deparse(substitute(blocks)))
+ class(out) <- "how"
out
}
Modified: pkg/permute/R/permuplot.R
===================================================================
--- pkg/permute/R/permuplot.R 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/R/permuplot.R 2013-06-12 05:12:52 UTC (rev 2511)
@@ -1,6 +1,6 @@
## This is totally wrong and needs updating to match the new
## code in permute...
-`permuplot` <- function(n, control = permControl(),
+`permuplot` <- function(n, control = how(),
col = par("col"),
hcol = "red",
shade = "lightgrey",
Modified: pkg/permute/R/print.how.R
===================================================================
--- pkg/permute/R/print.how.R 2013-06-11 17:53:13 UTC (rev 2510)
+++ pkg/permute/R/print.how.R 2013-06-12 05:12:52 UTC (rev 2511)
@@ -1,54 +1,89 @@
-`print.how` <- function(x, ...)
-{
+`print.how` <- function(x, ...) {
+
## only for objects of correct class
stopifnot(class(x) == "how")
- ## set-up the messages we wish to print
- if (!is.null(x$strata)) {
- if(x$blocks$type == "none") {
- msg.perm.strata <- "Strata unpermuted\n"
- } else {
- if(x$blocks$type == "grid") {
- msg.grid.strata <- paste("Strata are a spatial grid of dimension",
- x$blocks$nrow, "*",
- x$blocks$ncol, "\n")
- }
- msg.perm.strata <- paste("Permutation type:", x$blocks$type, "\n")
- msg.mirror.strata <- paste("Mirrored permutations for Strata?:",
- ifelse(x$blocks$mirror, "Yes", "No"), "\n")
- }
- msg.strata <- paste("Permutations are stratified within:", x$name.strata, "\n")
+
+ ## prefix to add to sub-elements
+ pfix <- " "
+
+ cat("\n")
+ writeLines(strwrap("Permutation Design:"))
+ cat("\n")
+
+ ## Blocks
+ writeLines("Blocks:")
+ blocks <- getBlocks(x)
+ if (is.null(blocks)) {
+ writeLines(strwrap("Defined by: none", prefix = pfix))
} else {
- msg.strata <- "Permutations are unstratified\n"
+ writeLines(strwrap(paste("Blocks:", x$blocks.name),
+ prefix = pfix))
}
- msg.perm.sample <- paste("Permutation type:", x$within$type, "\n")
- if(x$within$type == "grid")
- msg.grid.sample <- paste("Data are spatial grid(s) of dimension",
- x$within$nrow, "*", x$within$ncol, "\n")
- msg.nperm <- paste("No. of permutations:", x$nperm,
- ifelse(x$complete, "(complete enumeration)", ""),
- "\n")
- msg.mirror.sample <- paste("Mirrored permutations for Samples?:",
- ifelse(x$within$mirror, "Yes", "No"), "\n")
- msg.constant <- paste("Use same permutation within strata?:",
- ifelse(x$within$constant, "Yes", "No"), "\n")
- ## print out the messages
+
cat("\n")
- cat(msg.nperm)
- cat("\n**** STRATA ****\n")
- if(exists("msg.strata"))
- cat(msg.strata)
- if(exists("msg.perm.strata"))
- cat(msg.perm.strata)
- if(exists("msg.mirror.strata"))
- cat(msg.mirror.strata)
- if(exists("msg.grid.strata"))
- cat(msg.grid.strata)
- cat("\n**** SAMPLES ****\n")
- cat(msg.perm.sample)
- if(exists("msg.grid.sample"))
- cat(msg.grid.sample)
- cat(msg.mirror.sample)
- if(exists("msg.perm.strata"))
- cat(msg.constant)
+
+ ## Plots
+ writeLines("Plots:")
+ plots <- getStrata(x, which = "plots")
+ ptype <- getType(x, which = "plots")
+ if (is.null(plots)) {
+ writeLines(strwrap("Defined by: none", prefix = pfix))
+ } else {
+ writeLines(strwrap(paste("Plots:", plots$plots.name),
+ prefix = pfix))
+ writeLines(strwrap(paste("Permutation type:", ptype),
+ prefix = pfix))
+ mirrorP <- getMirror(x, which = "plots")
+ writeLines(strwrap(paste("Mirrored?:", if(mirrorP) "Yes" else "No"),
+ prefix = pfix))
+ if(isTRUE(all.equal(ptype, "grid"))) {
+ nr <- getRow(x, which = "plots")
+ nr.t <- if(nr > 1) "rows" else "row"
+ nc <- getCol(x, which = "plots")
+ nc.t <- if(nc > 1) "cols" else "col"
+ writeLines(strwrap(paste("Grid dimensions:", nr, nr.t, " ",
+ nc, nc.t),
+ prefix = pfix))
+ }
+ }
+
cat("\n")
+
+ ## Within plots
+ writeLines("Within Plots:")
+ wtype <- getType(x, which = "within")
+ writeLines(strwrap(paste("Permutation type:", wtype), prefix = pfix))
+ mirrorW <- getMirror(x, which = "within")
+ constantW <- getConstant(x)
+ txt <- "Different permutation within each Plot?:"
+ if(isTRUE(ptype %in% c("series", "grid"))) {
+ writeLines(strwrap(paste("Mirrored?:", if(mirrorW) "Yes" else "No"),
+ prefix = pfix))
+ writeLines(strwrap(paste(txt, if(constantW) "No" else "Yes"),
+ prefix = pfix))
+ }
+ if(isTRUE(all.equal(wtype, "grid"))) {
+ nr <- getRow(x, which = "within")
+ nr.t <- if(nr > 1) "rows" else "row"
+ nc <- getCol(x, which = "within")
+ nc.t <- if(nc > 1) "cols" else "col"
+ writeLines(strwrap(paste("Grid dimensions:", nr, nr.t, " ",
+ nc, nc.t),
+ prefix = pfix))
+ }
+
+ cat("\n")
+
+ ## Meta data
+ writeLines("Permutation details:")
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/vegan -r 2511
More information about the Vegan-commits
mailing list