[Vegan-commits] r2507 - in pkg/permute: . R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jun 11 07:56:55 CEST 2013
Author: gsimpson
Date: 2013-06-11 07:56:54 +0200 (Tue, 11 Jun 2013)
New Revision: 2507
Added:
pkg/permute/R/how.R
pkg/permute/R/print.how.R
pkg/permute/inst/TODO
Modified:
pkg/permute/NAMESPACE
pkg/permute/R/allPerms.R
pkg/permute/R/allStrata.R
pkg/permute/R/getFoo-methods.R
pkg/permute/R/numPerms.R
pkg/permute/R/permControl.R
pkg/permute/inst/ChangeLog
pkg/permute/man/allPerms.Rd
pkg/permute/man/get-methods.Rd
pkg/permute/man/shuffle.Rd
Log:
allPerms updated to new API, bug fixes in numPerms, new get methods for grid designs, start a TODO list, a bit of code clean up, new function how to eventually replace permControl
Modified: pkg/permute/NAMESPACE
===================================================================
--- pkg/permute/NAMESPACE 2013-06-10 20:01:53 UTC (rev 2506)
+++ pkg/permute/NAMESPACE 2013-06-11 05:56:54 UTC (rev 2507)
@@ -4,7 +4,7 @@
`shuffleFree`, `shuffleSeries`, `shuffleGrid`, `shuffleStrata`,
`getBlocks`, `getWithin`, `getStrata`, `getType`, `getMirror`,
`getConstant`, `getPlots`,
- `shuffleSet`, `permuplot`)
+ `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.
@@ -18,6 +18,7 @@
## print methods
S3method(`print`, `allPerms`)
S3method(`print`, `check`)
+S3method(`print`, `how`)
S3method(`print`, `permControl`)
S3method(`print`, `summary.allPerms`)
S3method(`print`, `summary.check`)
Modified: pkg/permute/R/allPerms.R
===================================================================
--- pkg/permute/R/allPerms.R 2013-06-10 20:01:53 UTC (rev 2506)
+++ pkg/permute/R/allPerms.R 2013-06-11 05:56:54 UTC (rev 2507)
@@ -1,10 +1,5 @@
`allPerms` <- function(n, control = permControl(), max = 9999,
observed = FALSE) {
- ## replicate a matrix by going via a list and bind together
- repMat <- function(mat, n) {
- res <- rep(list(mat), n)
- do.call(rbind, res)
- }
## start
v <- n
## expand n if a numeric or integer vector of length 1
@@ -13,160 +8,204 @@
## number of observations in data
n <- nobs(v)
## check permutation scheme and update control
- pcheck <- check(v, control = control, make.all = FALSE)
- ctrl <- pcheck$control
+ ## pcheck <- check(v, control = control, make.all = FALSE)
+ ## ctrl <- pcheck$control
+
## get max number of permutations
- nperms <- pcheck$n
+ nperms <- numPerms(v, control = control)
+
## sanity check - don't let this run away to infinity
## esp with type = "free"
if(nperms > max)
stop("Number of possible permutations too large (> 'max')")
- WI <- getWithin(ctrl)
- STRATA <- getStrata(ctrl)
- type.wi <- WI$type
- if(type.wi != "none") {
- if(is.null(STRATA)) {
- res <- switch(type.wi,
+
+ WI <- getWithin(control)
+ strataP <- getStrata(control, which = "plots")
+ typeW <- getType(control, which = "within")
+ typeP <- getType(control, which = "plot")
+ BLOCKS <- getBlocks(control)
+ dimW <- getDim(control, which = "within")
+ dimP <- getDim(control, which = "plots")
+ mirrorW <- getMirror(control, which = "within")
+ mirrorP <- getMirror(control, which = "plots")
+ constantW <- getConstant(control)
+
+ ## give a BLOCKS if non supplied - i.e. one block
+ if(is.null(BLOCKS))
+ BLOCKS <- factor(rep(1, n))
+
+ ## split v by blocks
+ spl <- split(v, BLOCKS)
+ nb <- length(spl) # number of blocks
+
+ ## result object
+ out <- vector(mode = "list", length = nb)
+
+ ## loop over blocks and return allPerms on each block
+ for (i in seq_along(spl)) {
+ out[[i]] <-
+ doAllPerms(spl[[i]], strataP, typeW, typeP, mirrorW,
+ mirrorP, constantW, dimW, dimP, control)
+ }
+
+ ## bind all the blocks together
+ out <- do.call(rbind, out) ## hmm are any of these the same shape?
+
+ if(!observed) {
+ obs.v <- seq_len(n)
+ obs.row <- apply(out, 1, function(x, obs.v) all(x == obs.v), obs.v)
+ out <- out[!obs.row, ]
+ ## reduce the number of permutations to get rid of the
+ ## observed ordering
+ control$nperm <- control$nperm - 1
+ }
+ class(out) <- "allPerms"
+ attr(out, "observed") <- observed
+ out
+}
+
+`doAllPerms` <- function(obs, strataP, typeW, typeP, mirrorW, mirrorP,
+ constantW, dimW, dimP, control) {
+ ## replicate a matrix by going via a list and bind together
+ repMat <- function(mat, n) {
+ res <- rep(list(mat), n)
+ do.call(rbind, res)
+ }
+
+ n <- length(obs)
+
+ ## permuting within?
+ if (typeW != "none") {
+ if(is.null(strataP)) { ## no plot-level permutations
+ res <- switch(typeW,
free = allFree(n),
- series = allSeries(n, nperms, WI$mirror),
- grid = allGrid(n, nperms, WI$nrow,
- WI$ncol, WI$mirror, WI$constant))
+ series = allSeries(n, nperms, mirrorW),
+ grid = allGrid(n, nperms, dimW[1],
+ dimW[2], mirrorW, constantW))
} else {
- ## permuting within blocks
- tab <- table(STRATA)
- if(WI$constant) {
- ## same permutation in each block
- pg <- unique(tab)
- ctrl.wi <- permControl(within = WI)
- nperms <- numPerms(pg, ctrl.wi)
- ord <- switch(type.wi,
+ ## permuting within plots
+ tab <- table(strataP)
+ pg <- unique(tab)
+ if(constantW) {
+ ## same permutation in each plot
+ ##pg <- unique(tab)
+ controlW <- permControl(within = getWithin(control))
+ nperms <- numPerms(pg, controlW)
+ ord <- switch(typeW,
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)
+ series = allSeries(pg, nperms, mirrorW),
+ grid = allGrid(pg, nperms, dimW[1],
+ dimW[2], mirrorW, constantW))
+ permW <- nrow(ord)
+ sp <- split(obs, strataP)
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,]])
+ for(i in seq_len(permW)) {
+ res[i,] <- sapply(sp,
+ function(x, ord) x[ord[i,]], ord = ord)
+ }
} else {
## different permutations within blocks
- tab <- table(STRATA)
ng <- length(tab)
- pg <- unique(tab)
+ ##pg <- unique(tab)
if(length(pg) > 1) {
## different number of observations per level of strata
- if(type.wi == "grid")
+ if(typeW == "grid")
## FIXME: this should not be needed once all checks are
## in place in check()
stop("Unbalanced grid designs are not supported")
- ctrl.wi <- permControl(within = WI)
- sp <- split(v, STRATA)
+ controlW <- permControl(within = getWithin(control))
+ sp <- split(obs, strataP)
res <- vector(mode = "list", length = ng)
add <- c(0, cumsum(tab)[1:(ng-1)])
for(j in seq_along(tab)) {
- np <- numPerms(tab[j], ctrl.wi)
- ord <- switch(type.wi,
+ np <- numPerms(tab[j], controlW)
+ ord <- switch(typeW,
free = allFree(tab[j]),
- series = allSeries(tab[j], np, WI$mirror))
- perm.wi <- nrow(ord)
+ series = allSeries(tab[j], np, mirrorW))
+ permW <- nrow(ord)
if(j == 1) {
a <- 1
- b <- np / perm.wi
+ b <- np / permW
} else {
- b <- b/perm.wi
- a <- np / (b*perm.wi)
+ b <- b/permW
+ a <- np / (b*permW)
}
res[[j]] <- matrix(rep(repMat(ord+add[j], a),
each = b),
ncol = tab[j])
}
res <- do.call(cbind, res)
- sp <- split(v, STRATA)
+ sp <- split(obs, strataP)
res <- t(apply(res, 1,
- function(x, inds, v) {v[inds] <- inds[x]; v},
- unlist(sp), v))
+ function(x, inds, o) {o[inds] <- inds[x]; o},
+ unlist(sp), obs))
} else {
## same number of observations per level of strata
- ctrl.wi <- permControl(within = WI)
- np <- numPerms(pg, ctrl.wi)
+ controlW <- permControl(within = getWithin(control))
+ np <- numPerms(pg, controlW)
ord <-
- switch(type.wi,
+ switch(typeW,
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)
+ series = allSeries(pg, np, mirrorW),
+ grid = allGrid(pg, np, dimW[1],
+ dimW[2], mirrorW, constantW))
+ permW <- nrow(ord)
add <- seq(from = 0, by = pg, length.out = ng)
res <- vector(mode = "list", length = ng)
a <- 1
- b <- np / perm.wi
+ b <- np / permW
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
+ a <- a*permW
+ b <- b/permW
}
res <- do.call(cbind, res)
- sp <- split(v, STRATA)
+ sp <- split(obs, strataP)
res <- t(apply(res, 1,
- function(x, inds, v) {v[inds] <- inds[x]; v},
- unlist(sp), v))
+ function(x, inds, o) {o[inds] <- inds[x]; o},
+ unlist(sp), obs))
}
}
}
}
- ## Do we need to permute blocks?
- if ((type.b <- control$blocks$type) != "none") {
- ## permuting blocks ONLY
- if(type.wi == "none") {
+ ## Do we need to permute plots?
+ if (!is.null(strataP)) {
+ ## permuting plots ONLY
+ if(typeW == "none") {
res <- allStrata(n, control = control)
} else {
- ## FIXME - this need updating to work with the new code
+ ## FIXME - this need updating to work with the new code
## permuting blocks AND within blocks
- ## need a local CTRL that just permutes blocks
- ctrl.b <- permControl(strata = STRATA,
- within = Within(type = "none"),
- blocks = getBlocks(ctrl))
+ ## need a local CONTROL that just permutes blocks
+ controlP <- permControl(plots = Plots(strata = strataP),
+ within = Within(type = "none"))
## number of permutations for just the block level
- perm.b <- numPerms(n, control = ctrl.b)
+ permP <- numPerms(n, control = controlP)
## get all permutations for the block level
- shuff.b <- allStrata(n, control = ctrl.b)
+ shuffP <- allStrata(n, control = controlP)
## 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),
+ ## permP times - results is a list
+ resP <- rep(list(res), permP)
+ resP <- lapply(seq_along(resP),
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)
+ wi = resP, bl = shuffP)
+ res <- do.call(rbind, resP)
}
}
## 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"
- if(!observed) {
- obs.v <- seq_len(n)
- ##obs.row <- apply(res, 1, function(x, v) {identical(x, v)}, obs.v)
- obs.row <- apply(res, 1, function(x, obs.v) all(x == obs.v), obs.v)
- res <- res[!obs.row, ]
- ## reduce the number of permutations to get rid of the
- ## observed ordering
- control$nperm <- control$nperm - 1
- }
- class(res) <- "allPerms"
- ##attr(res, "control") <- control
- attr(res, "observed") <- observed
- return(res)
+
+ ## return
+ res
}
## enumerate all possible permutations for a more complicated
@@ -183,3 +222,137 @@
## 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-10 20:01:53 UTC (rev 2506)
+++ pkg/permute/R/allStrata.R 2013-06-11 05:56:54 UTC (rev 2507)
@@ -3,23 +3,26 @@
## seq vector of observation indices
v <- seq_len(n)
## number of groups
- lev <- length(levels(control$strata))
- ## compute nperms on number of levels
- nperms <- numPerms(lev, control)
+ strata <- getStrata(control, which = "plots")
+ lev <- length(levels(strata))
+ ## compute nperms on number of levels - for this need Within()
+ ## and type == typeP
+ newControl <-
+ permControl(within = Within(type = getType(control, which = "plots")))
+ nperms <- numPerms(lev, newControl)
## result object
- X <- matrix(nrow = nperms, ncol = length(control$strata))
+ X <- matrix(nrow = nperms, ncol = length(strata))
## store the type
- type <- control$blocks$type
+ type <- getType(control, which = "plots")
+ mirror <- getMirror(control, which = "plots")
perms <- if(type == "free") {
allFree(lev)
} else if(type == "series") {
- mirror <- control$blocks$mirror
allSeries(lev, nperms = nperms, mirror = mirror)
} else if(type == "grid") {
- nr <- control$blocks$nrow
- nc <- control$blocks$ncol
- mirror <- control$blocks$mirror
- constant <- control$blocks$constant
+ nr <- getRow(control, which = "plots")
+ nc <- getCol(control, which = "plots")
+ constant <- getConstant(control)
allGrid(lev, nperms = nperms, nr = nr, nc = nc,
mirror = mirror, constant = constant)
} else {
@@ -28,10 +31,10 @@
## is possible given calling function...
return(v)
}
- sp <- split(v, control$strata)
+ sp <- split(v, strata)
## build permutations by concatenating components of sp
## for each row of level permutations
for(i in seq_len(nrow(perms)))
X[i,] <- unname(do.call(c, sp[perms[i,]]))
- return(X)
+ X
}
Modified: pkg/permute/R/getFoo-methods.R
===================================================================
--- pkg/permute/R/getFoo-methods.R 2013-06-10 20:01:53 UTC (rev 2506)
+++ pkg/permute/R/getFoo-methods.R 2013-06-11 05:56:54 UTC (rev 2507)
@@ -98,13 +98,13 @@
`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
+ 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
@@ -120,3 +120,68 @@
getWithin(object)$constant
}
+## Get the number of rows and colums from grid designs
+`getRow` <- function(object, ...) {
+ UseMethod("getRow")
+}
+
+`getRow.default` <- function(object, ...) {
+ NROW(object)
+}
+
+`getRow.permControl` <- 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")
+}
+
+`getCol.default` <- function(object, ...) {
+ NCOL(object)
+}
+
+`getCol.permControl` <- 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")
+}
+
+`getDim.default` <- function(object, ...) {
+ dim(object)
+}
+
+`getDim.permControl` <- 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)
+}
Added: pkg/permute/R/how.R
===================================================================
--- pkg/permute/R/how.R (rev 0)
+++ pkg/permute/R/how.R 2013-06-11 05:56:54 UTC (rev 2507)
@@ -0,0 +1,18 @@
+`how` <- function(within = Within(),
+ plots = Plots(),
+ blocks = NULL,
+ nperm = 199,
+ complete = FALSE,
+ maxperm = 9999,
+ minperm = 99,
+ all.perms = NULL,
+ observed = FALSE)
+{
+ 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) <- "how"
+ out
+}
Modified: pkg/permute/R/numPerms.R
===================================================================
--- pkg/permute/R/numPerms.R 2013-06-10 20:01:53 UTC (rev 2506)
+++ pkg/permute/R/numPerms.R 2013-06-11 05:56:54 UTC (rev 2507)
@@ -27,6 +27,10 @@
## constant - i.e. same perm within each plot?
constantW <- getConstant(control)
+ ## grid dimensions
+ colW <- getCol(control, which = "within")
+ colP <- getRow(control, which = "plots")
+
## 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
@@ -36,7 +40,7 @@
if(!is.null(PSTRATA)) {
tab <- table(PSTRATA)
same.n <- length(unique(tab))
- if((typeP %in% TYPES || isTRUE(WI$constant)) && same.n > 1) {
+ if((typeP %in% TYPES || 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) {
@@ -47,10 +51,12 @@
## the various designs allowed imply multipliers to number of samples
## for the restricted permutations
+ mult.p <- mult.wi <- 1
+
## within types
if(typeW %in% c("series","grid")) {
mult.wi <- 2
- if(isTRUE(all.equal(typeW, "grid")) && typeW$ncol > 2) {
+ if(isTRUE(all.equal(typeW, "grid")) && !is.null(colW) && colW > 2) {
mult.wi <- 4
} else {
if(isTRUE(all.equal(n, 2)))
@@ -60,7 +66,7 @@
## plot-level types
if(typeP %in% c("series","grid")) {
mult.p <- 2
- if(isTRUE(all.equal(typeP, "grid")) && typeP$ncol > 2) {
+ if(isTRUE(all.equal(typeP, "grid")) && !is.null(colP) && colP > 2) {
mult.p <- 4
} else {
if(isTRUE(all.equal(n, 2)))
@@ -97,8 +103,8 @@
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])
+ ## vector, split by block, this now gives nobs per plot strata
+ tab <- table(PSTRATA)#[obs] # table(PSTRATA[obs])
same.n <- length(unitab <- unique(tab))
## plots
Modified: pkg/permute/R/permControl.R
===================================================================
--- pkg/permute/R/permControl.R 2013-06-10 20:01:53 UTC (rev 2506)
+++ pkg/permute/R/permControl.R 2013-06-11 05:56:54 UTC (rev 2507)
@@ -1,19 +1,3 @@
-## `permControl` <- function(strata = NULL, nperm = 199, complete = FALSE,
-## within = Within(),
-## blocks = Blocks(),
-## maxperm = 9999, minperm = 99,
-## all.perms = NULL,
-## observed = FALSE)
-## {
-## out <- list(strata = strata, nperm = nperm, complete = complete,
-## within = within, blocks = blocks,
-## maxperm = maxperm, minperm = minperm,
-## all.perms = all.perms, observed = observed,
-## name.strata = deparse(substitute(strata)))
-## class(out) <- "permControl"
-## return(out)
-## }
-
`permControl` <- function(within = Within(),
plots = Plots(),
blocks = NULL, #Blocks(),
Added: pkg/permute/R/print.how.R
===================================================================
--- pkg/permute/R/print.how.R (rev 0)
+++ pkg/permute/R/print.how.R 2013-06-11 05:56:54 UTC (rev 2507)
@@ -0,0 +1,54 @@
+`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")
+ } else {
+ msg.strata <- "Permutations are unstratified\n"
+ }
+ 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)
+ cat("\n")
+}
Modified: pkg/permute/inst/ChangeLog
===================================================================
--- pkg/permute/inst/ChangeLog 2013-06-10 20:01:53 UTC (rev 2506)
+++ pkg/permute/inst/ChangeLog 2013-06-11 05:56:54 UTC (rev 2507)
@@ -12,11 +12,22 @@
* get-methods: New extractor functions `getMirror()`, and
`getConstant()` which retrieve the mirroring and constant elements
- of a permutation design.
+ of a permutation design. Also added `getRow()`, `getCol()` and
+ `getDim()`, which extract the row and column dimensions of a
+ grid permutation design, or both.
* numPerms: updated to work with the new API and now handles
blocking. Exmaples now pass checks again.
+ * allPerms: updated to the new API.
+
+ * how: new function, a copy of `permControl()` and will eventually
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/vegan -r 2507
More information about the Vegan-commits
mailing list