From noreply at r-forge.r-project.org Mon Jun 10 22:00:19 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 10 Jun 2013 22:00:19 +0200 (CEST) Subject: [Vegan-commits] r2505 - in pkg/permute: . R inst man Message-ID: <20130610200019.795571800FB@r-forge.r-project.org> 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 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) { From noreply at r-forge.r-project.org Mon Jun 10 22:01:54 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 10 Jun 2013 22:01:54 +0200 (CEST) Subject: [Vegan-commits] r2506 - pkg/permute/R Message-ID: <20130610200154.19D7F180488@r-forge.r-project.org> Author: gsimpson Date: 2013-06-10 22:01:53 +0200 (Mon, 10 Jun 2013) New Revision: 2506 Modified: pkg/permute/R/allFree.R Log: clean up Modified: pkg/permute/R/allFree.R =================================================================== --- pkg/permute/R/allFree.R 2013-06-10 20:00:18 UTC (rev 2505) +++ pkg/permute/R/allFree.R 2013-06-10 20:01:53 UTC (rev 2506) @@ -1,15 +1,3 @@ -## `allFree` <- function(n, v = 1:n) -## { -## if( n == 1 ) { -## matrix(v, 1, 1) -## } else { -## X <- NULL -## for(i in 1:n) -## X <- rbind(X, cbind(v[i], Recall(n-1, v[-i]))) -## X -## } -## } - ## Modified version of allFree() provided by Doug Bates ## via personal email on 19 Jan 2012 `allFree` <- function(n, v = seq_len(n)) { From noreply at r-forge.r-project.org Tue Jun 11 07:56:55 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 11 Jun 2013 07:56:55 +0200 (CEST) Subject: [Vegan-commits] r2507 - in pkg/permute: . R inst man Message-ID: <20130611055655.1B4801852B0@r-forge.r-project.org> 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 From noreply at r-forge.r-project.org Tue Jun 11 19:35:21 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 11 Jun 2013 19:35:21 +0200 (CEST) Subject: [Vegan-commits] r2508 - pkg/permute/man Message-ID: <20130611173521.B7E821858A4@r-forge.r-project.org> Author: gsimpson Date: 2013-06-11 19:35:21 +0200 (Tue, 11 Jun 2013) New Revision: 2508 Added: pkg/permute/man/how.Rd Modified: pkg/permute/man/shuffle.Rd Log: split out how/permControl documentation into own file Added: pkg/permute/man/how.Rd =================================================================== --- pkg/permute/man/how.Rd (rev 0) +++ pkg/permute/man/how.Rd 2013-06-11 17:35:21 UTC (rev 2508) @@ -0,0 +1,111 @@ +\name{how} +\alias{how} +\alias{print.how} +\alias{permControl} +\alias{print.permControl} +\alias{Blocks} +\alias{Within} +\alias{Plots} + +\title{How to define a permutation design?} + +\description{ + Utility functions to describe unrestricted and restricted permutation + designs for time series, line transects, spatial grids and blocking + factors. +} + +\usage{ +how(within = Within(), plots = Plots(), blocks = NULL, + nperm = 199, complete = FALSE, maxperm = 9999, + minperm = 99, all.perms = NULL, observed = FALSE) + +permControl(within = Within(), plots = Plots(), blocks = NULL, + nperm = 199, complete = FALSE, maxperm = 9999, + minperm = 99, all.perms = NULL, observed = FALSE) + +Within(type = c("free","series","grid","none"), + constant = FALSE, mirror = FALSE, + ncol = NULL, nrow = NULL) + +Plots(strata = NULL, type = c("free","series","grid","none"), + mirror = FALSE, ncol = NULL, nrow = NULL) +} + +\arguments{ + \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}). \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{nperm}{the number of permutations.} + \item{complete}{logical; should complete enumeration of all + permutations be performed?} + \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 + perform. Currently unused.} + \item{minperm}{the lower limit to the number of possible permutations + at which complete enumeration is performed. See argument + \code{complete} and Details, below.} + \item{all.perms}{an object of class \code{allPerms}, the result of a + call to \code{\link{allPerms}}.} + \item{observed}{logical; should the observed permutation be returned + as part of the set of all permutations?} + \item{constant}{logical; should the same permutation be used within + each level of strata? If \code{FALSE} a separate, possibly restricted, + permutation is produced for each level of \code{strata}.} + \item{mirror}{logical; should mirroring of sequences be allowed?} + \item{ncol, nrow}{numeric; the number of columns and rows of samples + in the spatial grid respectively.} + \item{strata}{An integer vector or factor specifying the strata for + permutation.} +} +\details{ + \code{shuffle} can generate permutations for a wide range of + restricted permutation schemes. A small selection of the available + combinations of options is provided in the Examples section below. + + Argument \code{mirror} determines whether grid or series permutations + can be mirrored. Consider the sequence 1,2,3,4. The relationship + between consecutive observations is preserved if we reverse the + sequence to 4,3,2,1. If there is no inherent direction in your + experimental design, mirrored permutations can be considered + part of the Null model, and as such increase the number of possible + permutations. The default is to not use mirroring so you must + explicitly turn this on using \code{mirror = TRUE} in + \code{how}. + + To permute plots rather than the observations within plots (the + levels of \code{strata}), use \code{Within(type = "none")} and + \code{Plots(type = foo)}, where \code{foo} is how you want the plots + to be permuted. However, note that the number of observations within + each plot \strong{must} be equal! + + For some experiments, such as BACI designs, one might wish to use the + same permutation within each plot. This is controlled by + argument \code{constant}. If \code{constant = TRUE} then the same + permutation will be generated for each level of \code{strata}. The + default is \code{constant = FALSE}. +} +\value{ + For \code{how} and \code{permControl} a list with components for each + of the possible arguments. +} +\references{ + \code{shuffle()} is modelled after the permutation schemes of Canoco + 3.1 (ter Braak, 1990); see also Besag & Clifford (1989). + + Besag, J. and Clifford, P. (1989) Generalized Monte Carlo significance + tests. \emph{Biometrika} \strong{76}; 633--642. + + ter Braak, C. J. F. (1990). \emph{Update notes: CANOCO version + 3.1}. Wageningen: Agricultural Mathematics Group. (UR). +} +\author{Gavin Simpson} +\seealso{\code{\link{shuffle}} for permuting from a design, + \code{\link{check}}, a utility function for checking permutation + schemedesign described by \code{\link{how}}.} +\keyword{ utils } \ No newline at end of file Modified: pkg/permute/man/shuffle.Rd =================================================================== --- pkg/permute/man/shuffle.Rd 2013-06-11 05:56:54 UTC (rev 2507) +++ pkg/permute/man/shuffle.Rd 2013-06-11 17:35:21 UTC (rev 2508) @@ -1,13 +1,6 @@ \name{shuffle} \alias{shuffle} -\alias{permControl} -\alias{Blocks} -\alias{Within} -\alias{Plots} -\alias{print.permControl} \alias{permute} -\alias{how} -\alias{print.how} \title{Unrestricted and restricted permutations} \description{ @@ -17,21 +10,6 @@ \usage{ shuffle(n, control = permControl()) -permControl(within = Within(), plots = Plots(), blocks = NULL, - nperm = 199, complete = FALSE, maxperm = 9999, - minperm = 99, all.perms = NULL, observed = FALSE) - -how(within = Within(), plots = Plots(), blocks = NULL, - nperm = 199, complete = FALSE, maxperm = 9999, - minperm = 99, all.perms = NULL, observed = FALSE) - -Within(type = c("free","series","grid","none"), - constant = FALSE, mirror = FALSE, - ncol = NULL, nrow = NULL) - -Plots(strata = NULL, type = c("free","series","grid","none"), - mirror = FALSE, ncol = NULL, nrow = NULL) - permute(i, n, control) } @@ -39,39 +17,8 @@ \item{n}{numeric; the length of the returned vector of permuted values. Usually the number of observations under consideration.} \item{control}{a list of control values describing properties of the - permutation design, as returned by a call to \code{permControl}.} - \item{strata}{An integer vector or factor specifying the strata for - permutation. If supplied, observations are permuted only within the - specified strata.} - \item{nperm}{the number of permutations.} - \item{complete}{logical; should complete enumeration of all - permutations be performed?} - \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}. \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 - perform. Currently unused.} - \item{minperm}{the lower limit to the number of possible permutations - at which complete enumeration is performed. See argument - \code{complete} and Details, below.} - \item{all.perms}{an object of class \code{allPerms}, the result of a - call to \code{\link{allPerms}}.} - \item{observed}{logical; should the observed permutation be returned - as part of the set of all permutations?} - \item{constant}{logical; should the same permutation be used within - each level of strata? If \code{FALSE} a separate, possibly restricted, - permutation is produced for each level of \code{strata}.} - \item{mirror}{logical; should mirroring of sequences be allowed?} - \item{ncol, nrow}{numeric; the number of columns and rows of samples - in the spatial grid respectively.} + permutation design, as returned by a call to \code{how}.} \item{i}{integer; row of \code{control$all.perms} to return.} - \item{\dots}{Arguments passed on to other methods.} } \details{ \code{shuffle} can generate permutations for a wide range of From noreply at r-forge.r-project.org Tue Jun 11 19:51:40 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 11 Jun 2013 19:51:40 +0200 (CEST) Subject: [Vegan-commits] r2509 - pkg/permute/man Message-ID: <20130611175140.6D3931851F6@r-forge.r-project.org> Author: gsimpson Date: 2013-06-11 19:51:40 +0200 (Tue, 11 Jun 2013) New Revision: 2509 Modified: pkg/permute/man/shuffle.Rd Log: cut some more to remove duplicated info in shuffle.Rd Modified: pkg/permute/man/shuffle.Rd =================================================================== --- pkg/permute/man/shuffle.Rd 2013-06-11 17:35:21 UTC (rev 2508) +++ pkg/permute/man/shuffle.Rd 2013-06-11 17:51:40 UTC (rev 2509) @@ -25,27 +25,6 @@ restricted permutation schemes. A small selection of the available combinations of options is provided in the Examples section below. - Argument \code{mirror} determines whether grid or series permutations - can be mirrored. Consider the sequence 1,2,3,4. The relationship - between consecutive observations is preserved if we reverse the - sequence to 4,3,2,1. If there is no inherent direction in your - experimental design, mirrored permutations can be considered - part of the Null model, and as such increase the number of possible - permutations. The default is to not use mirroring so you must - explicitly turn this on using \code{mirror = TRUE} in - \code{permControl}. - - To permute \code{strata} rather than the observations within the - levels of \code{strata}, use \code{permute.strata = TRUE}. However, note - that the number of observations within each level of strata - \strong{must} be equal! - - For some experiments, such as BACI designs, one might wish to use the - same permutation within each level of strata. This is controlled by - argument \code{constant}. If \code{constant = TRUE} then the same - permutation will be generated for each level of \code{strata}. The - default is \code{constant = FALSE}. - \code{permute} is a higher level utility function for use in a loop within a function implementing a permutation test. The main purpose of \code{permute} is to return the correct permutation in each iteration From noreply at r-forge.r-project.org Tue Jun 11 19:53:13 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 11 Jun 2013 19:53:13 +0200 (CEST) Subject: [Vegan-commits] r2510 - pkg/permute/R Message-ID: <20130611175313.5CE891851F6@r-forge.r-project.org> Author: gsimpson Date: 2013-06-11 19:53:13 +0200 (Tue, 11 Jun 2013) New Revision: 2510 Modified: pkg/permute/R/permCheck.R Log: typo in comment Modified: pkg/permute/R/permCheck.R =================================================================== --- pkg/permute/R/permCheck.R 2013-06-11 17:51:40 UTC (rev 2509) +++ pkg/permute/R/permCheck.R 2013-06-11 17:53:13 UTC (rev 2510) @@ -53,7 +53,7 @@ retval } -## depricate check +## deprecate check `permCheck` <- function(object, control = permControl(), make.all = TRUE) { .Deprecated(new = "check", "permute") From noreply at r-forge.r-project.org Wed Jun 12 07:12:53 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 07:12:53 +0200 (CEST) Subject: [Vegan-commits] r2511 - in pkg/permute: . R inst man tests/Examples vignettes Message-ID: <20130612051253.49B14185874@r-forge.r-project.org> 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 +Maintainer: Gavin L. Simpson 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 From noreply at r-forge.r-project.org Wed Jun 12 07:22:29 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 07:22:29 +0200 (CEST) Subject: [Vegan-commits] r2512 - in pkg/permute: . inst Message-ID: <20130612052229.D98BA185215@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 07:22:29 +0200 (Wed, 12 Jun 2013) New Revision: 2512 Modified: pkg/permute/DESCRIPTION pkg/permute/inst/ChangeLog Log: bump to 0.7-4; baby steps commit-wise now Modified: pkg/permute/DESCRIPTION =================================================================== --- pkg/permute/DESCRIPTION 2013-06-12 05:12:52 UTC (rev 2511) +++ pkg/permute/DESCRIPTION 2013-06-12 05:22:29 UTC (rev 2512) @@ -1,18 +1,11 @@ Package: permute Title: Functions for generating restricted permutations of data -Version: 0.7-3 +Version: 0.7-4 Date: $Date$ Author: Gavin L. Simpson Maintainer: Gavin L. Simpson 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), - and spatial grid designs plus permutation of blocks (groups of - samples). 'permute' also allows split-plot designs, in which the - whole-plots or split-plots or both can be freely-exchangeable or - one of the restricted designs. The 'permute' package is modelled - after the permutation schemes of Canoco 3.1 (and later) by Cajo - ter Braak. +Description: The 'permute' package implements a set of restricted permutation designs for freely exchangeable, line transects (time series), and spatial grid designs plus permutation of blocks (groups of samples). 'permute' also allows split-plot designs, in which the whole-plots or split-plots or both can be freely-exchangeable or one of the restricted designs. The 'permute' package is modelled after the permutation schemes of Canoco 3.1 (and later) by Cajo ter Braak. License: GPL-2 ByteCompile: true URL: http://vegan.r-forge.r-project.org/ Modified: pkg/permute/inst/ChangeLog =================================================================== --- pkg/permute/inst/ChangeLog 2013-06-12 05:12:52 UTC (rev 2511) +++ pkg/permute/inst/ChangeLog 2013-06-12 05:22:29 UTC (rev 2512) @@ -2,6 +2,10 @@ permute ChangeLog +Version 0.7-4 + + * + Version 0.7-3 * Tweak to 0.7-2 API changes: argument `blocks` no longer takes From noreply at r-forge.r-project.org Wed Jun 12 17:50:07 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 17:50:07 +0200 (CEST) Subject: [Vegan-commits] r2513 - in pkg/permute: inst man Message-ID: <20130612155007.CA94C18577F@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 17:50:07 +0200 (Wed, 12 Jun 2013) New Revision: 2513 Added: pkg/permute/inst/TODO.md pkg/permute/man/check.Rd pkg/permute/man/permControl-deprecated.Rd pkg/permute/man/permute-deprecated.Rd Removed: pkg/permute/inst/TODO pkg/permute/man/permCheck.Rd pkg/permute/man/permControl-dprecated.Rd Modified: pkg/permute/inst/ChangeLog Log: complete the deprecation of permControl, permCheck Modified: pkg/permute/inst/ChangeLog =================================================================== --- pkg/permute/inst/ChangeLog 2013-06-12 05:22:29 UTC (rev 2512) +++ pkg/permute/inst/ChangeLog 2013-06-12 15:50:07 UTC (rev 2513) @@ -4,7 +4,10 @@ Version 0.7-4 - * + * Deprecated functions: Completed the deprecation of `permCheck()` + and `permControl()`. These functions will be made defunct following + the release of version 0.8-0, with a view to complete removal from + version 0.9-0 onwards. Version 0.7-3 Deleted: pkg/permute/inst/TODO =================================================================== --- pkg/permute/inst/TODO 2013-06-12 05:22:29 UTC (rev 2512) +++ pkg/permute/inst/TODO 2013-06-12 15:50:07 UTC (rev 2513) @@ -1,25 +0,0 @@ -# TODO List - -A TODO list for **permute** - or things I know are broken or needed. - - * `summary.allPerms` - is not printing the permutation scheme - - * `print.permControl` - this needs to be updated to new API, and I don't - like the `*** Foo ***` headings I used before. - - * Need a way to update the permutation scheme, e.g. when a control - object already exists and want to tweak it. Example is in `?allPerms` - where I turn mirroring on via - - ctrl$within$mirror <- TRUE - - But how? Best idea currently is an `update.permControl` method. The - generic is in namespace `stats`. - - * `permControl` - deprecate this in favour of `how` as in "how to - permute"? - - * `permuplot` - this may be fundamentally bust - it only worked in the - original API and never got updated. Now the API is 2 versions further - on! It is also more complex than the original - not sure it'll be - easy without a lot of work to visualise all possible schemes. \ No newline at end of file Copied: pkg/permute/inst/TODO.md (from rev 2507, pkg/permute/inst/TODO) =================================================================== --- pkg/permute/inst/TODO.md (rev 0) +++ pkg/permute/inst/TODO.md 2013-06-12 15:50:07 UTC (rev 2513) @@ -0,0 +1,29 @@ +# TODO List + +A TODO list for **permute** - or things I know are broken or needed. + + * `summary.allPerms` - is not printing the permutation scheme + + * `print.permControl` - this needs to be updated to new API, and I don't + like the `*** Foo ***` headings I used before. *Done in 0.7-3* + + * Need a way to update the permutation scheme, e.g. when a control + object already exists and want to tweak it. Example is in `?allPerms` + where I turn mirroring on via + + ctrl$within$mirror <- TRUE + + But how? Best idea currently is an `update.permControl` method. The + generic is in namespace `stats`. Or a `modify()` function, perhaps + coupled with specific replacement functions for certain components. + + * `permControl` - deprecate this in favour of `how` as in "how to + permute"? *DONE Completed in 0.7-4* + + * `permuplot` - this may be fundamentally bust - it only worked in the + original API and never got updated. Now the API is 2 versions further + on! It is also more complex than the original - not sure it'll be + easy without a lot of work to visualise all possible schemes. + + * `check` insists on returning all permutations *without* the observed + on. \ No newline at end of file Copied: pkg/permute/man/check.Rd (from rev 2511, pkg/permute/man/permCheck.Rd) =================================================================== --- pkg/permute/man/check.Rd (rev 0) +++ pkg/permute/man/check.Rd 2013-06-12 15:50:07 UTC (rev 2513) @@ -0,0 +1,267 @@ +\name{check} +\alias{check} +\alias{permCheck} % for the deprecated function +\alias{permCheck-deprecated} % for the deprecated function +\alias{print.check} +\alias{print.summary.check} +\alias{summary.check} +\alias{permuplot} + +\title{Utility functions for permutation schemes} +\description{ + \code{check} provides checking of permutation schemes for + validity. \code{permuplot} produces a graphical representation of the + selected permutation design. +} +\usage{ +check(object, control = how(), make.all = TRUE) + +\method{summary}{check}(object, \dots) + +permuplot(n, control = how(), col = par("col"), + hcol = "red", shade = "lightgrey", xlim = NULL, ylim = NULL, + inset = 0.1, main = NULL, sub = NULL, ann = par("ann"), + cex = par("cex"), \dots) +} + +\arguments{ + \item{object}{an R object. See Details for a + complete description, especially for \code{numPerms}. For + \code{\link{summary.check}} an object of class + \code{"check"}. For \code{\link{summary.allPerms}} an object of + class \code{"allPerms"}.} + \item{control}{a list of control values describing properties of the + permutation design, as returned by a call to + \code{\link{how}}.} + \item{make.all}{logical; should \code{check} generate all + possible permutations? Useful if want to check permutation design + but not produce the matrix of all permutations.} + \item{n}{the number of observations or an 'object' from which the + number of observations can be determined via \code{getNumObs}.} + \item{col, xlim, ylim, main, sub, ann, cex}{Graphical parameters.} + \item{hcol}{Colour to use for highlighting observations and the border + colour of the polygons drawn when \code{type = "strata"}.} + \item{shade}{The polygon shading colour (passed to argument \code{col} + of function \code{\link{polygon}}) when \code{type = "strata"}.} + \item{inset}{Proportion of range of x and y coordinates to add to the + plot x and y limits. Used to create a bit of extra space around the + margin of each plot.} + \item{\dots}{arguments to other methods. For \code{permuplot} + graphical parameters can be passed to plotting functions, though + note that not all parameters will be accepted gracefully at the + moment.} +} +\details{ + \code{check} and \code{permuplot} are utility functions for working + with the new permutation schemes available in \code{\link{shuffle}}. + + \code{check} is used to check the current permutation schemes + against the object to which it will be applied. It calculates the + maximum number of possible permutations for the number of observations + in \code{object} and the permutation scheme described by + \code{control}. The returned object contains component \code{control}, + an object of class \code{"how"} suitably modified if + \code{check} identifies a problem. + + The main problem is requesting more permutations than possible with + the number of observations and the permutation design. In such cases, + \code{nperm} is reduced to equal the number of possible permutations, + and complete enumeration of all permutations is turned on + (\code{control$complete} is set to \code{TRUE}). + + Alternatively, if the number of possible permutations is low, and less + than \code{control$minperm}, it is better to enumerate all possible + permutations, and as such complete enumeration of all permutations is + turned on (\code{control$complete} is set to \code{TRUE}). + + \code{permuplot} is a graphical utility function, which produces a + graphical representation of a permutation design. It takes the number + of observations and an object returned by \code{\link{how}} as + arguments and produces a plot on the currently active device. If + strata are present in the design, the plotting region is split into + sufficient plotting regions (one for each stratum), and the design in + each stratum plotted. + + Free permutation designs are represented by plotting the observation + number at random x and y coordinates. Series designs (time series or + line transects) are represented by plotting the observation numbers + comprising the series in a circle and the start of the permuted series + is highlighted using colour \code{hcol}. Grid designs are drawn on a + regular grid and the top left observation in the original grid is + highlighted using colour \code{hcol}. Note the ordering used is R's + standard ordering for matrices - columns are filled first. +} +\value{ + For \code{check} a list containing the maximum number of + permutations possible and an object of class + \code{"\link{how}"}. + + For \code{permuplot}, a plot on the currently active device. +} +\author{Gavin L. Simpson} +\seealso{\code{\link{shuffle}} and \code{\link{how}}.} + +\examples{ + +## use example data from ?pyrifos in package vegan +require(vegan) +example(pyrifos) + +## Demonstrate the maximum number of permutations for the pyrifos data +## under a series of permutation schemes + +## no restrictions - lots of perms +CONTROL <- how(within = Within(type = "free")) +(check1 <- check(pyrifos, CONTROL)) +##summary(check1) + +## no strata but data are series with no mirroring, so 132 permutations +CONTROL <- how(within = Within(type = "series", mirror = FALSE)) +check(pyrifos, CONTROL) + +## no strata but data are series with mirroring, so 264 permutations +CONTROL <- how(within = Within(type = "series", mirror = TRUE)) +check(pyrifos, control = CONTROL) + +## unrestricted within strata +check(pyrifos, control = how(plots = Plots(strata = ditch), + within = Within(type = "free"))) + +## time series within strata, no mirroring +check(pyrifos, + control = how(plots = Plots(strata = ditch), + within = Within(type = "series", mirror = FALSE))) + +## time series within strata, with mirroring +check(pyrifos, + control = how(plots = Plots(strata = ditch), + within = Within(type = "series", mirror = TRUE))) + +\dontrun{ % FIXME these fail in allStrata needing 235.5 Gb RAM!! +## time series within strata, no mirroring, same permutation +## within strata +check(pyrifos, + control = how(plots = Plots(strata = ditch), + within = Within(type = "series", constant = TRUE))) + +## time series within strata, with mirroring, same permutation +## within strata +check(pyrifos, + control = how(plots = Plots(strata = ditch), + within = Within(type = "series", mirror = TRUE, + constant = TRUE))) + +## permute strata +check(pyrifos, how(plots = Plots(strata = ditch, type = "free"), + within = Within(type = "none"))) +} + +## this should also also for arbitrary vectors +vec1 <- check(1:100) +vec2 <- check(1:100, how()) +all.equal(vec1, vec2) +vec3 <- check(1:100, how(within = Within(type = "series"))) +all.equal(100, vec3$n) +vec4 <- check(1:100, how(within = Within(type= "series", mirror = TRUE))) +all.equal(vec4$n, 200) + +## enumerate all possible permutations +fac <- gl(2,6) +ctrl <- how(plots = Plots(strata = fac), + within = Within(type = "grid", mirror = FALSE, + constant = TRUE, nrow = 3, ncol = 2)) +check(1:12, ctrl) + +numPerms(1:12, control = ctrl) +(tmp <- allPerms(12, control = ctrl, observed = TRUE)) +(tmp2 <- allPerms(12, control = ctrl)) + +## turn on mirroring %%FIXME needs a proper method to do this +ctrl$within$mirror <- TRUE +numPerms(1:12, control = ctrl) +(tmp3 <- allPerms(12, control = ctrl, observed = TRUE)) +(tmp4 <- allPerms(12, control = ctrl)) +## prints out details of the permutation scheme as +## well as the matrix of permutations +summary(tmp) %% FIXME these don't print the scheme +summary(tmp2) + +## different numbers of observations per level of strata +fac <- factor(rep(1:3, times = c(3,2,2))) +## free permutations in levels of strata +numPerms(7, how(within = Within(type = "free"), + plots = Plots(strata = fac, type = "none"))) +%% FIXME - need all these updating to new API in how... +%% Fixed one, above, but there may still be problems with some of +%% the code below: +\dontrun{ +allPerms(7, how(type = "free", strata = fac)) +## series permutations in levels of strata +numPerms(7, how(type = "series", strata = fac)) +allPerms(7, how(type = "series", strata = fac)) + +## allPerms can work with a vector +vec <- c(3,4,5) +allPerms(vec) + +## Tests for permuplot +n <- 25 +## standard permutation designs +permuplot(n, how(type = "free")) +permuplot(n, how(type = "series")) +permuplot(n, how(type = "grid", nrow = 5, ncol = 5)) + +## restricted perms with mirroring +permuplot(n, how(type = "series", mirror = TRUE)) +permuplot(n, how(type = "grid", nrow = 5, ncol = 5, + mirror = TRUE)) + +## perms within strata +fac <- gl(6, 20) +control <- how(type = "free", strata = fac) +permuplot(120, control = control, cex = 0.8) +control <- how(type = "series", strata = fac) +permuplot(120, control = control, cex = 0.8) +fac <- gl(6, 25) +control <- how(type = "grid", strata = fac, + nrow = 5, ncol = 5) +permuplot(150, control = control, cex = 0.8) + +## perms within strata with mirroring +fac <- gl(6, 20) +control <- how(type = "series", strata = fac, + mirror = TRUE) +permuplot(120, control = control, cex = 0.8) +fac <- gl(6, 25) +control <- how(type = "grid", strata = fac, + nrow = 5, ncol = 5, mirror = TRUE) +permuplot(150, control = control, cex = 0.8) + +## same perms within strata +fac <- gl(6, 20) +control <- how(type = "free", strata = fac, + constant = TRUE) +permuplot(120, control = control, cex = 0.8) +control <- how(type = "series", strata = fac, + constant = TRUE) +permuplot(120, control = control, cex = 0.8) +fac <- gl(6, 25) +control <- how(type = "grid", strata = fac, + nrow = 5, ncol = 5, constant = TRUE) +permuplot(150, control = control, cex = 0.8) + +## same perms within strata with mirroring +fac <- gl(6, 20) +control <- how(type = "series", strata = fac, + mirror = TRUE, constant = TRUE) +permuplot(120, control = control, cex = 0.8) +fac <- gl(6, 25) +control <- how(type = "grid", strata = fac, + nrow = 5, ncol = 5, mirror = TRUE, + constant = TRUE) +permuplot(150, control = control, cex = 0.8) +} +} +\keyword{ utilities } +\keyword{ design } +\keyword{ methods } Deleted: pkg/permute/man/permCheck.Rd =================================================================== --- pkg/permute/man/permCheck.Rd 2013-06-12 05:22:29 UTC (rev 2512) +++ pkg/permute/man/permCheck.Rd 2013-06-12 15:50:07 UTC (rev 2513) @@ -1,274 +0,0 @@ -\name{check} -\alias{check} -\alias{permCheck} % for the deprecated function -\alias{print.check} -\alias{print.summary.check} -\alias{summary.check} -\alias{permuplot} - -\title{Utility functions for permutation schemes} -\description{ - \code{check} provides checking of permutation schemes for - validity. \code{permuplot} produces a graphical representation of the - selected permutation design. -} -\usage{ -check(object, control = how(), make.all = TRUE) - -\method{summary}{check}(object, \dots) - -permuplot(n, control = how(), col = par("col"), - hcol = "red", shade = "lightgrey", xlim = NULL, ylim = NULL, - inset = 0.1, main = NULL, sub = NULL, ann = par("ann"), - cex = par("cex"), \dots) -} - -\arguments{ - \item{object}{an R object. See Details for a - complete description, especially for \code{numPerms}. For - \code{\link{summary.check}} an object of class - \code{"check"}. For \code{\link{summary.allPerms}} an object of - class \code{"allPerms"}.} - \item{control}{a list of control values describing properties of the - permutation design, as returned by a call to - \code{\link{how}}.} - \item{make.all}{logical; should \code{check} generate all - possible permutations? Useful if want to check permutation design - but not produce the matrix of all permutations.} - \item{n}{the number of observations or an 'object' from which the - number of observations can be determined via \code{getNumObs}.} - \item{col, xlim, ylim, main, sub, ann, cex}{Graphical parameters.} - \item{hcol}{Colour to use for highlighting observations and the border - colour of the polygons drawn when \code{type = "strata"}.} - \item{shade}{The polygon shading colour (passed to argument \code{col} - of function \code{\link{polygon}}) when \code{type = "strata"}.} - \item{inset}{Proportion of range of x and y coordinates to add to the - plot x and y limits. Used to create a bit of extra space around the - margin of each plot.} - \item{\dots}{arguments to other methods. For \code{permuplot} - graphical parameters can be passed to plotting functions, though - note that not all parameters will be accepted gracefully at the - moment.} -} -\details{ - \code{check} and \code{permuplot} are utility functions for working - with the new permutation schemes available in \code{\link{shuffle}}. - - \code{check} is used to check the current permutation schemes - against the object to which it will be applied. It calculates the - maximum number of possible permutations for the number of observations - in \code{object} and the permutation scheme described by - \code{control}. The returned object contains component \code{control}, - an object of class \code{"how"} suitably modified if - \code{check} identifies a problem. - - The main problem is requesting more permutations than possible with - the number of observations and the permutation design. In such cases, - \code{nperm} is reduced to equal the number of possible permutations, - and complete enumeration of all permutations is turned on - (\code{control$complete} is set to \code{TRUE}). - - Alternatively, if the number of possible permutations is low, and less - than \code{control$minperm}, it is better to enumerate all possible - permutations, and as such complete enumeration of all permutations is - turned on (\code{control$complete} is set to \code{TRUE}). - - % Function \code{getNumObs} is a simple generic function to return the - % number of observations in a range of R objects. The default method - % will work for any object for which a \code{\link[vegan]{scores}} - % method exists. This includes matrices and data frames, as well as - % specific methods for numeric or integer vectors. - - \code{permuplot} is a graphical utility function, which produces a - graphical representation of a permutation design. It takes the number - of observations and an object returned by \code{\link{how}} as - arguments and produces a plot on the currently active device. If - strata are present in the design, the plotting region is split into - sufficient plotting regions (one for each stratum), and the design in - each stratum plotted. - - Free permutation designs are represented by plotting the observation - number at random x and y coordinates. Series designs (time series or - line transects) are represented by plotting the observation numbers - comprising the series in a circle and the start of the permuted series - is highlighted using colour \code{hcol}. Grid designs are drawn on a - regular grid and the top left observation in the original grid is - highlighted using colour \code{hcol}. Note the ordering used is R's - standard ordering for matrices - columns are filled first. -} -\value{ - For \code{check} a list containing the maximum number of - permutations possible and an object of class - \code{"\link{how}"}. - - For \code{permuplot}, a plot on the currently active device. -} -%\references{ -%} -\author{Gavin Simpson} -\seealso{\code{\link{shuffle}} and \code{\link{how}}.} - -\examples{ - -## use example data from ?pyrifos in package vegan -require(vegan) -example(pyrifos) - -## Demonstrate the maximum number of permutations for the pyrifos data -## under a series of permutation schemes - -## no restrictions - lots of perms -CONTROL <- how(within = Within(type = "free")) -(check1 <- check(pyrifos, CONTROL)) -##summary(check1) - -## no strata but data are series with no mirroring, so 132 permutations -CONTROL <- how(within = Within(type = "series", mirror = FALSE)) -check(pyrifos, CONTROL) - -## no strata but data are series with mirroring, so 264 permutations -CONTROL <- how(within = Within(type = "series", mirror = TRUE)) -check(pyrifos, control = CONTROL) - -## unrestricted within strata -check(pyrifos, control = how(plots = Plots(strata = ditch), - within = Within(type = "free"))) - -## time series within strata, no mirroring -check(pyrifos, - control = how(plots = Plots(strata = ditch), - within = Within(type = "series", mirror = FALSE))) - -## time series within strata, with mirroring -check(pyrifos, - control = how(plots = Plots(strata = ditch), - within = Within(type = "series", mirror = TRUE))) - -\dontrun{ % FIXME these fail in allStrata needing 235.5 Gb RAM!! -## time series within strata, no mirroring, same permutation -## within strata -check(pyrifos, - control = how(plots = Plots(strata = ditch), - within = Within(type = "series", constant = TRUE))) - -## time series within strata, with mirroring, same permutation -## within strata -check(pyrifos, - control = how(plots = Plots(strata = ditch), - within = Within(type = "series", mirror = TRUE, - constant = TRUE))) - -## permute strata -check(pyrifos, how(plots = Plots(strata = ditch, type = "free"), - within = Within(type = "none"))) -} - -## this should also also for arbitrary vectors -vec1 <- check(1:100) -vec2 <- check(1:100, how()) -all.equal(vec1, vec2) -vec3 <- check(1:100, how(within = Within(type = "series"))) -all.equal(100, vec3$n) -vec4 <- check(1:100, how(within = Within(type= "series", mirror = TRUE))) -all.equal(vec4$n, 200) - -## enumerate all possible permutations -fac <- gl(2,6) -ctrl <- how(plots = Plots(strata = fac), - within = Within(type = "grid", mirror = FALSE, - constant = TRUE, nrow = 3, ncol = 2)) -check(1:12, ctrl) - -numPerms(1:12, control = ctrl) -(tmp <- allPerms(12, control = ctrl, observed = TRUE)) -(tmp2 <- allPerms(12, control = ctrl)) - -## turn on mirroring %%FIXME needs a proper method to do this -ctrl$within$mirror <- TRUE -numPerms(1:12, control = ctrl) -(tmp3 <- allPerms(12, control = ctrl, observed = TRUE)) -(tmp4 <- allPerms(12, control = ctrl)) -## prints out details of the permutation scheme as -## well as the matrix of permutations -summary(tmp) %% FIXME these don't print the scheme -summary(tmp2) - -## different numbers of observations per level of strata -fac <- factor(rep(1:3, times = c(3,2,2))) -## free permutations in levels of strata -numPerms(7, how(within = Within(type = "free"), - plots = Plots(strata = fac, type = "none"))) -%% FIXME - need all these updating to new API in how... -%% Fixed one, above, but there may still be problems with some of -%% the code below: -\dontrun{ -allPerms(7, how(type = "free", strata = fac)) -## series permutations in levels of strata -numPerms(7, how(type = "series", strata = fac)) -allPerms(7, how(type = "series", strata = fac)) - -## allPerms can work with a vector -vec <- c(3,4,5) -allPerms(vec) - -## Tests for permuplot -n <- 25 -## standard permutation designs -permuplot(n, how(type = "free")) -permuplot(n, how(type = "series")) -permuplot(n, how(type = "grid", nrow = 5, ncol = 5)) - -## restricted perms with mirroring -permuplot(n, how(type = "series", mirror = TRUE)) -permuplot(n, how(type = "grid", nrow = 5, ncol = 5, - mirror = TRUE)) - -## perms within strata -fac <- gl(6, 20) -control <- how(type = "free", strata = fac) -permuplot(120, control = control, cex = 0.8) -control <- how(type = "series", strata = fac) -permuplot(120, control = control, cex = 0.8) -fac <- gl(6, 25) -control <- how(type = "grid", strata = fac, - nrow = 5, ncol = 5) -permuplot(150, control = control, cex = 0.8) - -## perms within strata with mirroring -fac <- gl(6, 20) -control <- how(type = "series", strata = fac, - mirror = TRUE) -permuplot(120, control = control, cex = 0.8) -fac <- gl(6, 25) -control <- how(type = "grid", strata = fac, - nrow = 5, ncol = 5, mirror = TRUE) -permuplot(150, control = control, cex = 0.8) - -## same perms within strata -fac <- gl(6, 20) -control <- how(type = "free", strata = fac, - constant = TRUE) -permuplot(120, control = control, cex = 0.8) -control <- how(type = "series", strata = fac, - constant = TRUE) -permuplot(120, control = control, cex = 0.8) -fac <- gl(6, 25) -control <- how(type = "grid", strata = fac, - nrow = 5, ncol = 5, constant = TRUE) -permuplot(150, control = control, cex = 0.8) - -## same perms within strata with mirroring -fac <- gl(6, 20) -control <- how(type = "series", strata = fac, - mirror = TRUE, constant = TRUE) -permuplot(120, control = control, cex = 0.8) -fac <- gl(6, 25) -control <- how(type = "grid", strata = fac, - nrow = 5, ncol = 5, mirror = TRUE, - constant = TRUE) -permuplot(150, control = control, cex = 0.8) -} -} -\keyword{ utilities } -\keyword{ design } -\keyword{ methods } Copied: pkg/permute/man/permControl-deprecated.Rd (from rev 2511, pkg/permute/man/permControl-dprecated.Rd) =================================================================== --- pkg/permute/man/permControl-deprecated.Rd (rev 0) +++ pkg/permute/man/permControl-deprecated.Rd 2013-06-12 15:50:07 UTC (rev 2513) @@ -0,0 +1,82 @@ +\name{permControl-deprecated} +\alias{permControl} +\alias{print.permControl} +\alias{print.permControl-deprecated} + +\title{How to define a permutation design?} + +\description{ + Utility functions to describe unrestricted and restricted permutation + designs for time series, line transects, spatial grids and blocking + factors. +} + +\usage{ +permControl(within = Within(), plots = Plots(), blocks = NULL, + nperm = 199, complete = FALSE, maxperm = 9999, + minperm = 99, all.perms = NULL, observed = FALSE) +} + +\arguments{ + \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}). \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{nperm}{the number of permutations.} + \item{complete}{logical; should complete enumeration of all + permutations be performed?} + \item{maxperm}{the maximum number of permutations to + perform. Currently unused.} + \item{minperm}{the lower limit to the number of possible permutations + at which complete enumeration is performed. See argument + \code{complete} and Details, below.} + \item{all.perms}{an object of class \code{allPerms}, the result of a + call to \code{\link{allPerms}}.} + \item{observed}{logical; should the observed permutation be returned + as part of the set of all permutations?} +} +\details{ + Argument \code{mirror} determines whether grid or series permutations + can be mirrored. Consider the sequence 1,2,3,4. The relationship + between consecutive observations is preserved if we reverse the + sequence to 4,3,2,1. If there is no inherent direction in your + experimental design, mirrored permutations can be considered + part of the Null model, and as such increase the number of possible + permutations. The default is to not use mirroring so you must + explicitly turn this on using \code{mirror = TRUE} in + \code{permControl}. + + To permute plots rather than the observations within plots (the + levels of \code{strata}), use \code{Within(type = "none")} and + \code{Plots(type = foo)}, where \code{foo} is how you want the plots + to be permuted. However, note that the number of observations within + each plot \strong{must} be equal! + + For some experiments, such as BACI designs, one might wish to use the + same permutation within each plot. This is controlled by + argument \code{constant}. If \code{constant = TRUE} then the same + permutation will be generated for each level of \code{strata}. The + default is \code{constant = FALSE}. +} +\value{ + For \code{permControl} a list with components for each + of the possible arguments. +} +\references{ + \code{shuffle()} is modelled after the permutation schemes of Canoco + 3.1 (ter Braak, 1990); see also Besag & Clifford (1989). + + Besag, J. and Clifford, P. (1989) Generalized Monte Carlo significance + tests. \emph{Biometrika} \strong{76}; 633--642. + + ter Braak, C. J. F. (1990). \emph{Update notes: CANOCO version + 3.1}. Wageningen: Agricultural Mathematics Group. (UR). +} +\author{Gavin L. Simpson} +\seealso{\code{\link{shuffle}} for permuting from a design, + \code{\link{check}}, a utility function for checking permutation + schemedesign described by \code{\link{how}}.} +\keyword{ utils } \ No newline at end of file Deleted: pkg/permute/man/permControl-dprecated.Rd =================================================================== --- pkg/permute/man/permControl-dprecated.Rd 2013-06-12 05:22:29 UTC (rev 2512) +++ pkg/permute/man/permControl-dprecated.Rd 2013-06-12 15:50:07 UTC (rev 2513) @@ -1,81 +0,0 @@ -\name{permControl-deprecated} -\alias{permControl} -\alias{print.permControl} - -\title{How to define a permutation design?} - -\description{ - Utility functions to describe unrestricted and restricted permutation - designs for time series, line transects, spatial grids and blocking - factors. -} - -\usage{ -permControl(within = Within(), plots = Plots(), blocks = NULL, - nperm = 199, complete = FALSE, maxperm = 9999, - minperm = 99, all.perms = NULL, observed = FALSE) -} - -\arguments{ - \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}). \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{nperm}{the number of permutations.} - \item{complete}{logical; should complete enumeration of all - permutations be performed?} - \item{maxperm}{the maximum number of permutations to - perform. Currently unused.} - \item{minperm}{the lower limit to the number of possible permutations - at which complete enumeration is performed. See argument - \code{complete} and Details, below.} - \item{all.perms}{an object of class \code{allPerms}, the result of a - call to \code{\link{allPerms}}.} - \item{observed}{logical; should the observed permutation be returned - as part of the set of all permutations?} -} -\details{ - Argument \code{mirror} determines whether grid or series permutations - can be mirrored. Consider the sequence 1,2,3,4. The relationship - between consecutive observations is preserved if we reverse the - sequence to 4,3,2,1. If there is no inherent direction in your - experimental design, mirrored permutations can be considered - part of the Null model, and as such increase the number of possible - permutations. The default is to not use mirroring so you must - explicitly turn this on using \code{mirror = TRUE} in - \code{permControl}. - - To permute plots rather than the observations within plots (the - levels of \code{strata}), use \code{Within(type = "none")} and - \code{Plots(type = foo)}, where \code{foo} is how you want the plots - to be permuted. However, note that the number of observations within - each plot \strong{must} be equal! - - For some experiments, such as BACI designs, one might wish to use the - same permutation within each plot. This is controlled by - argument \code{constant}. If \code{constant = TRUE} then the same - permutation will be generated for each level of \code{strata}. The - default is \code{constant = FALSE}. -} -\value{ - For \code{permControl} a list with components for each - of the possible arguments. -} -\references{ - \code{shuffle()} is modelled after the permutation schemes of Canoco - 3.1 (ter Braak, 1990); see also Besag & Clifford (1989). - - Besag, J. and Clifford, P. (1989) Generalized Monte Carlo significance - tests. \emph{Biometrika} \strong{76}; 633--642. - - ter Braak, C. J. F. (1990). \emph{Update notes: CANOCO version - 3.1}. Wageningen: Agricultural Mathematics Group. (UR). -} -\author{Gavin Simpson} -\seealso{\code{\link{shuffle}} for permuting from a design, - \code{\link{check}}, a utility function for checking permutation - schemedesign described by \code{\link{how}}.} -\keyword{ utils } \ No newline at end of file Added: pkg/permute/man/permute-deprecated.Rd =================================================================== --- pkg/permute/man/permute-deprecated.Rd (rev 0) +++ pkg/permute/man/permute-deprecated.Rd 2013-06-12 15:50:07 UTC (rev 2513) @@ -0,0 +1,25 @@ +\name{permute-deprecated} + +\title{Deprecated functions in package permute} + +\description{ [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vegan -r 2513 From noreply at r-forge.r-project.org Wed Jun 12 19:41:58 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 19:41:58 +0200 (CEST) Subject: [Vegan-commits] r2514 - in pkg/permute: R man Message-ID: <20130612174158.8D1C118453F@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 19:41:58 +0200 (Wed, 12 Jun 2013) New Revision: 2514 Added: pkg/permute/R/permute-deprecated.R pkg/permute/R/print.check.R pkg/permute/R/print.summary.check.R pkg/permute/R/summary.check.R pkg/permute/man/permCheck-deprecated.Rd Removed: pkg/permute/R/permControl.R pkg/permute/R/print.permCheck.R pkg/permute/R/print.permControl.R pkg/permute/R/print.summary.permCheck.R pkg/permute/R/summary.permCheck.R Modified: pkg/permute/man/check.Rd Log: clean up sources following deprecation and follow best practice Deleted: pkg/permute/R/permControl.R =================================================================== --- pkg/permute/R/permControl.R 2013-06-12 15:50:07 UTC (rev 2513) +++ pkg/permute/R/permControl.R 2013-06-12 17:41:58 UTC (rev 2514) @@ -1,17 +0,0 @@ -`permControl` <- function(within = Within(), - plots = Plots(), - 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, - blocks.name = deparse(substitute(blocks))) - class(out) <- "how" - out -} Added: pkg/permute/R/permute-deprecated.R =================================================================== --- pkg/permute/R/permute-deprecated.R (rev 0) +++ pkg/permute/R/permute-deprecated.R 2013-06-12 17:41:58 UTC (rev 2514) @@ -0,0 +1,43 @@ +`permControl` <- function(within = Within(), + plots = Plots(), + 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, + blocks.name = deparse(substitute(blocks))) + class(out) <- "how" + out +} + +`print.permControl` <- function(x, ...) +{ + .Deprecated("print.how", package = "permute") + class(x) <- "how" + print(x) +} + + +`print.permCheck` <- function(x, ...) +{ + print(x$n) +} + +`print.summary.permCheck` <- function(x, ...) +{ + cat(paste("Number of possible permutations:", x$n, "\n")) + print(x$control) + invisible(x) +} + +`summary.permCheck` <- function(object, ...) +{ + class(object) <- "summary.permCheck" + object +} Copied: pkg/permute/R/print.check.R (from rev 2496, pkg/permute/R/print.permCheck.R) =================================================================== --- pkg/permute/R/print.check.R (rev 0) +++ pkg/permute/R/print.check.R 2013-06-12 17:41:58 UTC (rev 2514) @@ -0,0 +1,4 @@ +`print.check` <- function(x, ...) +{ + print(x$n) +} Deleted: pkg/permute/R/print.permCheck.R =================================================================== --- pkg/permute/R/print.permCheck.R 2013-06-12 15:50:07 UTC (rev 2513) +++ pkg/permute/R/print.permCheck.R 2013-06-12 17:41:58 UTC (rev 2514) @@ -1,4 +0,0 @@ -`print.check` <- function(x, ...) -{ - print(x$n) -} Deleted: pkg/permute/R/print.permControl.R =================================================================== --- pkg/permute/R/print.permControl.R 2013-06-12 15:50:07 UTC (rev 2513) +++ pkg/permute/R/print.permControl.R 2013-06-12 17:41:58 UTC (rev 2514) @@ -1,6 +0,0 @@ -`print.permControl` <- function(x, ...) -{ - .Deprecated("print.how", package = "permute") - class(x) <- "how" - print(x) -} Copied: pkg/permute/R/print.summary.check.R (from rev 2496, pkg/permute/R/print.summary.permCheck.R) =================================================================== --- pkg/permute/R/print.summary.check.R (rev 0) +++ pkg/permute/R/print.summary.check.R 2013-06-12 17:41:58 UTC (rev 2514) @@ -0,0 +1,6 @@ +`print.summary.check` <- function(x, ...) +{ + cat(paste("Number of possible permutations:", x$n, "\n")) + print(x$control) + invisible(x) +} Deleted: pkg/permute/R/print.summary.permCheck.R =================================================================== --- pkg/permute/R/print.summary.permCheck.R 2013-06-12 15:50:07 UTC (rev 2513) +++ pkg/permute/R/print.summary.permCheck.R 2013-06-12 17:41:58 UTC (rev 2514) @@ -1,6 +0,0 @@ -`print.summary.check` <- function(x, ...) -{ - cat(paste("Number of possible permutations:", x$n, "\n")) - print(x$control) - invisible(x) -} Copied: pkg/permute/R/summary.check.R (from rev 2496, pkg/permute/R/summary.permCheck.R) =================================================================== --- pkg/permute/R/summary.check.R (rev 0) +++ pkg/permute/R/summary.check.R 2013-06-12 17:41:58 UTC (rev 2514) @@ -0,0 +1,5 @@ +`summary.check` <- function(object, ...) +{ + class(object) <- "summary.check" + object +} Deleted: pkg/permute/R/summary.permCheck.R =================================================================== --- pkg/permute/R/summary.permCheck.R 2013-06-12 15:50:07 UTC (rev 2513) +++ pkg/permute/R/summary.permCheck.R 2013-06-12 17:41:58 UTC (rev 2514) @@ -1,5 +0,0 @@ -`summary.check` <- function(object, ...) -{ - class(object) <- "summary.check" - object -} Modified: pkg/permute/man/check.Rd =================================================================== --- pkg/permute/man/check.Rd 2013-06-12 15:50:07 UTC (rev 2513) +++ pkg/permute/man/check.Rd 2013-06-12 17:41:58 UTC (rev 2514) @@ -1,7 +1,5 @@ \name{check} \alias{check} -\alias{permCheck} % for the deprecated function -\alias{permCheck-deprecated} % for the deprecated function \alias{print.check} \alias{print.summary.check} \alias{summary.check} @@ -28,12 +26,11 @@ \item{object}{an R object. See Details for a complete description, especially for \code{numPerms}. For \code{\link{summary.check}} an object of class - \code{"check"}. For \code{\link{summary.allPerms}} an object of - class \code{"allPerms"}.} + \code{"check"}.} \item{control}{a list of control values describing properties of the permutation design, as returned by a call to \code{\link{how}}.} - \item{make.all}{logical; should \code{check} generate all + \item{make.all}{logical; should \code{permCheck} generate all possible permutations? Useful if want to check permutation design but not produce the matrix of all permutations.} \item{n}{the number of observations or an 'object' from which the @@ -93,16 +90,11 @@ } \value{ For \code{check} a list containing the maximum number of - permutations possible and an object of class - \code{"\link{how}"}. - - For \code{permuplot}, a plot on the currently active device. + permutations possible and an object of class \code{"\link{how}"}. } \author{Gavin L. Simpson} -\seealso{\code{\link{shuffle}} and \code{\link{how}}.} +\seealso{\code{\link{shuffle}} and \code{\link{how}}.}\examples{ -\examples{ - ## use example data from ?pyrifos in package vegan require(vegan) example(pyrifos) @@ -137,7 +129,6 @@ control = how(plots = Plots(strata = ditch), within = Within(type = "series", mirror = TRUE))) -\dontrun{ % FIXME these fail in allStrata needing 235.5 Gb RAM!! ## time series within strata, no mirroring, same permutation ## within strata check(pyrifos, @@ -151,6 +142,7 @@ within = Within(type = "series", mirror = TRUE, constant = TRUE))) +\dontrun{ % FIXME these fail in allStrata needing 235.5 Gb RAM!! ## permute strata check(pyrifos, how(plots = Plots(strata = ditch, type = "free"), within = Within(type = "none"))) @@ -195,7 +187,8 @@ %% Fixed one, above, but there may still be problems with some of %% the code below: \dontrun{ -allPerms(7, how(type = "free", strata = fac)) +allPerms(7, how(within = Within(type = "free"), + plots = Plots(strata = fac))) ## series permutations in levels of strata numPerms(7, how(type = "series", strata = fac)) allPerms(7, how(type = "series", strata = fac)) Added: pkg/permute/man/permCheck-deprecated.Rd =================================================================== --- pkg/permute/man/permCheck-deprecated.Rd (rev 0) +++ pkg/permute/man/permCheck-deprecated.Rd 2013-06-12 17:41:58 UTC (rev 2514) @@ -0,0 +1,69 @@ +\name{permCheck-deprecated} +\alias{permCheck} % for the deprecated function +\alias{permCheck-deprecated} % for the deprecated function +\alias{print.permCheck} +\alias{print.summary.permCheck} +\alias{summary.permCheck} + +\title{Utility functions for permutation schemes} +\description{ + \code{permCheck} provides checking of permutation schemes for + validity. \code{permuplot} produces a graphical representation of the + selected permutation design. +} +\usage{ +permCheck(object, control = how(), make.all = TRUE) + +\method{summary}{permCheck}(object, \dots) +} + +\arguments{ + \item{object}{an R object. See Details for a + complete description, especially for \code{numPerms}. For + \code{\link{summary.permCheck}} an object of class + \code{"permCheck"}.} + \item{control}{a list of control values describing properties of the + permutation design, as returned by a call to + \code{\link{how}}.} + \item{make.all}{logical; should \code{permCheck} generate all + possible permutations? Useful if want to check permutation design + but not produce the matrix of all permutations.} + \item{\dots}{arguments to other methods. For \code{permuplot} + graphical parameters can be passed to plotting functions, though + note that not all parameters will be accepted gracefully at the + moment.} +} +\details{ + \code{permCheck} is a utility functions for working + with the new permutation schemes available in \code{\link{shuffle}}. + + \code{permCheck} is used to check the current permutation schemes + against the object to which it will be applied. It calculates the + maximum number of possible permutations for the number of observations + in \code{object} and the permutation scheme described by + \code{control}. The returned object contains component \code{control}, + an object of class \code{"how"} suitably modified if + \code{permCheck} identifies a problem. + + The main problem is requesting more permutations than possible with + the number of observations and the permutation design. In such cases, + \code{nperm} is reduced to equal the number of possible permutations, + and complete enumeration of all permutations is turned on + (\code{control$complete} is set to \code{TRUE}). + + Alternatively, if the number of possible permutations is low, and less + than \code{control$minperm}, it is better to enumerate all possible + permutations, and as such complete enumeration of all permutations is + turned on (\code{control$complete} is set to \code{TRUE}). +} +\value{ + For \code{permCheck} a list containing the maximum number of + permutations possible and an object of class + \code{"\link{how}"}. + + For \code{permuplot}, a plot on the currently active device. +} +\author{Gavin L. Simpson} +\seealso{\code{\link{shuffle}} and \code{\link{how}}.} +\keyword{ utilities } +\keyword{ methods } From noreply at r-forge.r-project.org Wed Jun 12 19:43:13 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 19:43:13 +0200 (CEST) Subject: [Vegan-commits] r2515 - pkg/permute/R Message-ID: <20130612174313.3023B18453F@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 19:43:12 +0200 (Wed, 12 Jun 2013) New Revision: 2515 Modified: pkg/permute/R/allPerms.R Log: fix bug when different numbers of samples per Plot Modified: pkg/permute/R/allPerms.R =================================================================== --- pkg/permute/R/allPerms.R 2013-06-12 17:41:58 UTC (rev 2514) +++ pkg/permute/R/allPerms.R 2013-06-12 17:43:12 UTC (rev 2515) @@ -106,6 +106,8 @@ } } else { ## different permutations within blocks + nperms <- numPerms(sum(tab), control) + ng <- length(tab) ##pg <- unique(tab) if(length(pg) > 1) { @@ -126,10 +128,10 @@ permW <- nrow(ord) if(j == 1) { a <- 1 - b <- np / permW + b <- nperms / np } else { - b <- b/permW - a <- np / (b*permW) + b <- b / np + a <- nperms / (b * np) } res[[j]] <- matrix(rep(repMat(ord+add[j], a), each = b), From noreply at r-forge.r-project.org Wed Jun 12 19:50:23 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 19:50:23 +0200 (CEST) Subject: [Vegan-commits] r2516 - pkg/permute/man Message-ID: <20130612175023.920421856AB@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 19:50:23 +0200 (Wed, 12 Jun 2013) New Revision: 2516 Modified: pkg/permute/man/check.Rd Log: check examples work all bar one, and that is a problem with allPerms shuffling strata Modified: pkg/permute/man/check.Rd =================================================================== --- pkg/permute/man/check.Rd 2013-06-12 17:43:12 UTC (rev 2515) +++ pkg/permute/man/check.Rd 2013-06-12 17:50:23 UTC (rev 2516) @@ -183,78 +183,18 @@ ## free permutations in levels of strata numPerms(7, how(within = Within(type = "free"), plots = Plots(strata = fac, type = "none"))) -%% FIXME - need all these updating to new API in how... -%% Fixed one, above, but there may still be problems with some of -%% the code below: -\dontrun{ allPerms(7, how(within = Within(type = "free"), plots = Plots(strata = fac))) ## series permutations in levels of strata -numPerms(7, how(type = "series", strata = fac)) -allPerms(7, how(type = "series", strata = fac)) +ctrl <- how(within = Within(type = "series"), plots = Plots(strata = fac)) +numPerms(7, control = ctrl) +allPerms(7, control = ctrl) -## allPerms can work with a vector -vec <- c(3,4,5) -allPerms(vec) +%% FIXME - need all these updating to new API in how... +%% moved permuplot examples out of package until I can fix it +%% properly -## Tests for permuplot -n <- 25 -## standard permutation designs -permuplot(n, how(type = "free")) -permuplot(n, how(type = "series")) -permuplot(n, how(type = "grid", nrow = 5, ncol = 5)) - -## restricted perms with mirroring -permuplot(n, how(type = "series", mirror = TRUE)) -permuplot(n, how(type = "grid", nrow = 5, ncol = 5, - mirror = TRUE)) - -## perms within strata -fac <- gl(6, 20) -control <- how(type = "free", strata = fac) -permuplot(120, control = control, cex = 0.8) -control <- how(type = "series", strata = fac) -permuplot(120, control = control, cex = 0.8) -fac <- gl(6, 25) -control <- how(type = "grid", strata = fac, - nrow = 5, ncol = 5) -permuplot(150, control = control, cex = 0.8) - -## perms within strata with mirroring -fac <- gl(6, 20) -control <- how(type = "series", strata = fac, - mirror = TRUE) -permuplot(120, control = control, cex = 0.8) -fac <- gl(6, 25) -control <- how(type = "grid", strata = fac, - nrow = 5, ncol = 5, mirror = TRUE) -permuplot(150, control = control, cex = 0.8) - -## same perms within strata -fac <- gl(6, 20) -control <- how(type = "free", strata = fac, - constant = TRUE) -permuplot(120, control = control, cex = 0.8) -control <- how(type = "series", strata = fac, - constant = TRUE) -permuplot(120, control = control, cex = 0.8) -fac <- gl(6, 25) -control <- how(type = "grid", strata = fac, - nrow = 5, ncol = 5, constant = TRUE) -permuplot(150, control = control, cex = 0.8) - -## same perms within strata with mirroring -fac <- gl(6, 20) -control <- how(type = "series", strata = fac, - mirror = TRUE, constant = TRUE) -permuplot(120, control = control, cex = 0.8) -fac <- gl(6, 25) -control <- how(type = "grid", strata = fac, - nrow = 5, ncol = 5, mirror = TRUE, - constant = TRUE) -permuplot(150, control = control, cex = 0.8) } -} \keyword{ utilities } \keyword{ design } \keyword{ methods } From noreply at r-forge.r-project.org Wed Jun 12 21:18:59 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 21:18:59 +0200 (CEST) Subject: [Vegan-commits] r2517 - pkg/permute/man Message-ID: <20130612191859.1EB6A185896@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 21:18:58 +0200 (Wed, 12 Jun 2013) New Revision: 2517 Modified: pkg/permute/man/how.Rd Log: add an example - essentially test that print.how works Modified: pkg/permute/man/how.Rd =================================================================== --- pkg/permute/man/how.Rd 2013-06-12 17:50:23 UTC (rev 2516) +++ pkg/permute/man/how.Rd 2013-06-12 19:18:58 UTC (rev 2517) @@ -101,4 +101,11 @@ \seealso{\code{\link{shuffle}} for permuting from a design, \code{\link{check}}, a utility function for checking permutation design described by \code{how}.} +\examples{ +plts <- gl(4,10) +blks <- gl(2,20) +how(within = Within(type = "series", mirror = TRUE), + plots = Plots(strata = plts, type = "series"), + blocks = blks) +} \keyword{ utils } \ No newline at end of file From noreply at r-forge.r-project.org Wed Jun 12 21:21:12 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 21:21:12 +0200 (CEST) Subject: [Vegan-commits] r2518 - pkg/permute/R Message-ID: <20130612192112.46A9F185896@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 21:21:12 +0200 (Wed, 12 Jun 2013) New Revision: 2518 Modified: pkg/permute/R/print.how.R Log: bug fix in where it looks for the deparsed, substituted name of Plot-level strata Modified: pkg/permute/R/print.how.R =================================================================== --- pkg/permute/R/print.how.R 2013-06-12 19:18:58 UTC (rev 2517) +++ pkg/permute/R/print.how.R 2013-06-12 19:21:12 UTC (rev 2518) @@ -24,9 +24,10 @@ ## Plots writeLines("Plots:") - plots <- getStrata(x, which = "plots") + plotStr <- getStrata(x, which = "plots") + plots <- getPlots(x) ptype <- getType(x, which = "plots") - if (is.null(plots)) { + if (is.null(plotStr)) { writeLines(strwrap("Defined by: none", prefix = pfix)) } else { writeLines(strwrap(paste("Plots:", plots$plots.name), From noreply at r-forge.r-project.org Wed Jun 12 21:22:09 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 21:22:09 +0200 (CEST) Subject: [Vegan-commits] r2519 - in pkg/permute: R man Message-ID: <20130612192209.0D94B185896@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 21:22:08 +0200 (Wed, 12 Jun 2013) New Revision: 2519 Modified: pkg/permute/R/allPerms.R pkg/permute/R/numPerms.R pkg/permute/man/check.Rd Log: final example not working in check.Rd now works after some bug fixes and tweaks Modified: pkg/permute/R/allPerms.R =================================================================== --- pkg/permute/R/allPerms.R 2013-06-12 19:21:12 UTC (rev 2518) +++ pkg/permute/R/allPerms.R 2013-06-12 19:22:08 UTC (rev 2519) @@ -8,7 +8,7 @@ ## number of observations in data n <- nobs(v) ## check permutation scheme and update control - ## pcheck <- check(v, control = control, make.all = FALSE) + pcheck <- check(v, control = control, make.all = FALSE) ## ctrl <- pcheck$control ## get max number of permutations Modified: pkg/permute/R/numPerms.R =================================================================== --- pkg/permute/R/numPerms.R 2013-06-12 19:21:12 UTC (rev 2518) +++ pkg/permute/R/numPerms.R 2013-06-12 19:22:08 UTC (rev 2519) @@ -160,4 +160,7 @@ n } } + + ## return + num.p * num.wi } Modified: pkg/permute/man/check.Rd =================================================================== --- pkg/permute/man/check.Rd 2013-06-12 19:21:12 UTC (rev 2518) +++ pkg/permute/man/check.Rd 2013-06-12 19:22:08 UTC (rev 2519) @@ -141,12 +141,9 @@ control = how(plots = Plots(strata = ditch), within = Within(type = "series", mirror = TRUE, constant = TRUE))) - -\dontrun{ % FIXME these fail in allStrata needing 235.5 Gb RAM!! ## permute strata check(pyrifos, how(plots = Plots(strata = ditch, type = "free"), within = Within(type = "none"))) -} ## this should also also for arbitrary vectors vec1 <- check(1:100) From noreply at r-forge.r-project.org Wed Jun 12 21:27:11 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 21:27:11 +0200 (CEST) Subject: [Vegan-commits] r2520 - pkg/permute/man Message-ID: <20130612192711.BC12B185896@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 21:27:11 +0200 (Wed, 12 Jun 2013) New Revision: 2520 Modified: pkg/permute/man/check.Rd Log: minor tweak to indentation in example Modified: pkg/permute/man/check.Rd =================================================================== --- pkg/permute/man/check.Rd 2013-06-12 19:22:08 UTC (rev 2519) +++ pkg/permute/man/check.Rd 2013-06-12 19:27:11 UTC (rev 2520) @@ -121,8 +121,8 @@ ## time series within strata, no mirroring check(pyrifos, - control = how(plots = Plots(strata = ditch), - within = Within(type = "series", mirror = FALSE))) + control = how(plots = Plots(strata = ditch), + within = Within(type = "series", mirror = FALSE))) ## time series within strata, with mirroring check(pyrifos, From noreply at r-forge.r-project.org Wed Jun 12 21:53:41 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 21:53:41 +0200 (CEST) Subject: [Vegan-commits] r2521 - pkg/permute/R Message-ID: <20130612195341.3DE3A184B6E@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 21:53:40 +0200 (Wed, 12 Jun 2013) New Revision: 2521 Added: pkg/permute/R/check.R Modified: pkg/permute/R/permCheck.R Log: check now checks if number requested perms exceeds maximum possible; also a tidy up Added: pkg/permute/R/check.R =================================================================== --- pkg/permute/R/check.R (rev 0) +++ pkg/permute/R/check.R 2013-06-12 19:53:40 UTC (rev 2521) @@ -0,0 +1,90 @@ +`check` <- function(object, control = how(), make.all = TRUE, + observed = FALSE) +{ + ## 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 + N <- nobs(object) + + ## sample permutation type + 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 && typeW == "grid") + stop("Unbalanced 'grid' designs are not supported.") + + ## 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(getConstant(control) && bal > 1) + stop("Unbalanced designs not allowed with 'constant = TRUE'.") + + ## if permuting strata, must be balanced + 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) && + !inherits(control$all.perms, "allPerms")) + stop("'control$all.perms' must be of class 'allPerms'.") + + ## get number of possible permutations + num.pos <- numPerms(object, control) + + ## check if number requested permutations exceeds max possible + if(getNperm(control) > num.pos) { + control$nperm <- control$maxperm <- num.pos + control$complete <- TRUE + } + + ## if number of possible perms < minperm turn on complete enumeration + if(num.pos < getMinperm(control)) { + control$nperm <- control$maxperm <- num.pos + control$complete <- TRUE + } + + ## if complete enumeration, generate all permutations + if(getComplete(control)$complete && make.all) { + control$all.perms <- allPerms(N, control = control, + max = getMaxperm(control), + observed = observed) + } + retval <- list(n = num.pos, control = control) + class(retval) <- "check" + retval +} Modified: pkg/permute/R/permCheck.R =================================================================== --- pkg/permute/R/permCheck.R 2013-06-12 19:27:11 UTC (rev 2520) +++ pkg/permute/R/permCheck.R 2013-06-12 19:53:40 UTC (rev 2521) @@ -1,87 +1,3 @@ -`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 - N <- nobs(object) - - ## sample permutation type - 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 && typeW == "grid") - stop("Unbalanced 'grid' designs are not supported.") - - ## 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(getConstant(control) && bal > 1) - stop("Unbalanced designs not allowed with 'constant = TRUE'.") - - ## if permuting strata, must be balanced - 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) && - !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 < getMinperm(control)) { - control$nperm <- control$maxperm <- num.pos - control$complete <- TRUE - } - - ## if complete enumeration, generate all permutations - 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) - class(retval) <- "check" - retval -} - ## deprecate check `permCheck` <- function(object, control = how(), make.all = TRUE) { From noreply at r-forge.r-project.org Wed Jun 12 22:12:04 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 22:12:04 +0200 (CEST) Subject: [Vegan-commits] r2522 - in pkg/permute: R man Message-ID: <20130612201204.C586F184CEF@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 22:12:04 +0200 (Wed, 12 Jun 2013) New Revision: 2522 Modified: pkg/permute/R/shuffleSet2.R pkg/permute/man/shuffleSet.Rd Log: shuffleSet now checks the permutation design and uses all.perms if present/needed Modified: pkg/permute/R/shuffleSet2.R =================================================================== --- pkg/permute/R/shuffleSet2.R 2013-06-12 19:53:40 UTC (rev 2521) +++ pkg/permute/R/shuffleSet2.R 2013-06-12 20:12:04 UTC (rev 2522) @@ -1,143 +1,166 @@ ## new version of shuffleSet() that allows for blocking -`shuffleSet` <- function(n, nset = 1, control = how()) { - ## get blocking, if any - Block <- getStrata(control, which = "blocks") - if(is.null(Block)) - Block <- factor(rep(1, n)) +`shuffleSet` <- function(n, nset, control = how()) { + ## handle missing nset - take from control if can + if(missing(nset)) { + np <- getNperm(control) + if(is.null(np)) ## something wrong, default back to 1 + nset <- 1 + else + nset <- np + } + + sn <- seq_len(n) ## sequence of samples in order of input - sn <- seq_len(n) ## sequence of samples in order of input + ## need to check number of permutations won't blow up + pcheck <- check(sn, control = control, make.all = TRUE) + ## control possibly now updated + control <- pcheck$control - ## split sn on basis of Block - spln <- split(sn, Block) - nb <- length(spln) ## number of blocks - - ## result list - out <- vector(mode = "list", length = nb) - - ## loop over spln and shuffle in each split - for(i in seq_len(nb)) { - out[[i]] <- doShuffleSet(spln[[i]], nset = nset, control) - } - out <- do.call(cbind, out) ## undo the original splitting - out + if(is.null(control$all.perms)) { + ## get blocking, if any + Block <- getStrata(control, which = "blocks") + if(is.null(Block)) + Block <- factor(rep(1, n)) + + ## split sn on basis of Block + spln <- split(sn, Block) + nb <- length(spln) ## number of blocks + + ## result list + out <- vector(mode = "list", length = nb) + + ## loop over spln and shuffle in each split + for(i in seq_len(nb)) { + out[[i]] <- doShuffleSet(spln[[i]], nset = nset, control) + } + out <- do.call(cbind, out) ## undo the original splitting + } else { + ## if we have all.perms now then we must have generated it + ## during checking or user passed it with control + ## Use that instead of a ranodm set + out <- control$all.perms + } + out } `doShuffleSet` <- function(ind, nset = 1, control) { - ## collect strata at Plot level - Pstrata <- getStrata(control, which = "plots", drop = TRUE) - plotCTRL <- getPlots(control) - typeP <- getType(control, which = "plots") - - ## collect the within control object - withinCTRL <- getWithin(control) - typeW <- getType(control, which = "within") - - n <- length(ind) - sn <- seq_len(n) - - ## result object - Set <- matrix(nrow = nset, ncol = n) - - ## if no strata at Plot level permute all samples using stated scheme - if(is.null(Pstrata)) { - ## If no strata at plot then permute all samples using stated scheme - Args <- switch(typeW, - "free" = list(x = n, size = n), - "series" = list(x = seq_len(n), mirror = withinCTRL$mirror), - "grid" = list(nrow = withinCTRL$nrow, ncol = withinCTRL$ncol, - mirror = withinCTRL$mirror)) - FUN <- switch(typeW, - "free" = shuffleFree, - "series" = shuffleSeries, - "grid" = shuffleGrid) - if(withinCTRL$type == "none") { - Set[] <- rep(sn, each = nset) - } else { - for(i in seq_len(nset)) { - Set[i,] <- do.call(FUN, Args) - } - } - } else { - ## If strata at Plot level present, either permute samples, Plots or both - - ## permute strata at Plot level? - if(isTRUE(all.equal(typeP, "none"))) { - Set[] <- rep(sn, each = nset) - } else { - for(i in seq_len(nset)) { - Set[i,] <- do.call(shuffleStrata, - list(strata = Pstrata, - type = typeP, - mirror = plotCTRL$mirror, - flip = NULL, ## runif(1L) < 0.5 ?? - nrow = plotCTRL$nrow, - ncol = plotCTRL$ncol)) - } - } - - tmp <- Set + ## collect strata at Plot level + Pstrata <- getStrata(control, which = "plots", drop = TRUE) + plotCTRL <- getPlots(control) + typeP <- getType(control, which = "plots") - ## permute the samples within Plot strata - if(!isTRUE(all.equal(typeW, "none"))) { - for(i in seq_len(nset)) { - tab <- table(Pstrata[ind][Set[i,]]) - ## the levels of the Plot strata - levs <- names(tab) - - ## same permutation within each level of the Plot strata? - if(withinCTRL$constant) { - if(isTRUE(all.equal(typeW, "free"))) { - n <- unique(tab)[1L] - same.rand <- shuffleFree(n, n) - } else if(isTRUE(all.equal(typeW, "series"))) { - start <- shuffleFree(n / length(levs), 1L) - flip <- runif(1L) < 0.5 ## FIXME this should be moved out of the loop - } else if(isTRUE(all.equal(typeW, "grid"))) { - start.row <- shuffleFree(withinCTRL$nrow, 1L) - start.col <- shuffleFree(withinCTRL$ncol, 1L) - flip <- runif(2L) < 0.5 ## FIXME this should be moved out of the loop - } + ## collect the within control object + withinCTRL <- getWithin(control) + typeW <- getType(control, which = "within") + + n <- length(ind) + sn <- seq_len(n) + + ## result object + Set <- matrix(nrow = nset, ncol = n) + + ## if no strata at Plot level permute all samples using stated scheme + if(is.null(Pstrata)) { + ## If no strata at plot then permute all samples using stated scheme + Args <- switch(typeW, + "free" = list(x = n, size = n), + "series" = list(x = seq_len(n), + mirror = withinCTRL$mirror), + "grid" = list(nrow = withinCTRL$nrow, + ncol = withinCTRL$ncol, + mirror = withinCTRL$mirror)) + FUN <- switch(typeW, + "free" = shuffleFree, + "series" = shuffleSeries, + "grid" = shuffleGrid) + if(withinCTRL$type == "none") { + Set[] <- rep(sn, each = nset) } else { - start <- start.row <- start.col <- flip <- NULL + for(i in seq_len(nset)) { + Set[i,] <- do.call(FUN, Args) + } } - - ## for each level of strata, permute - for(lv in levs) { - ## must re-order strata here on basis of Ser as they - ## may have been permuted above - MATCH <- Pstrata[ind][Set[i,]] == lv - gr <- Set[i,][MATCH] - if((n.gr <- length(gr)) > 1) { - if(withinCTRL$constant && isTRUE(all.equal(typeW, "free"))) { - tmp[i,][which(MATCH)] <- gr[same.rand] - } else { - Args <- - switch(typeW, - "free" = list(x = n.gr, size = n.gr), - "series" = list(x = seq_len(n.gr), - mirror = withinCTRL$mirror, - start = start, - flip = flip), - "grid" = list(nrow = withinCTRL$nrow, - ncol = withinCTRL$ncol, - mirror = withinCTRL$mirror, - start.row = start.row, - start.col = start.col, - flip = flip)) - FUN <- - switch(typeW, - "free" = shuffleFree, - "series" = shuffleSeries, - "grid" = shuffleGrid) - tmp[i,][which(MATCH)] <- gr[do.call(FUN, Args)] + } else { + ## If strata at Plot level present, either permute samples, Plots or both + + ## permute strata at Plot level? + if(isTRUE(all.equal(typeP, "none"))) { + Set[] <- rep(sn, each = nset) + } else { + for(i in seq_len(nset)) { + Set[i,] <- do.call(shuffleStrata, + list(strata = Pstrata, + type = typeP, + mirror = plotCTRL$mirror, + flip = NULL, ## runif(1L) < 0.5 ?? + nrow = plotCTRL$nrow, + ncol = plotCTRL$ncol)) } - } } - } - Set <- tmp + + tmp <- Set + + ## permute the samples within Plot strata + if(!isTRUE(all.equal(typeW, "none"))) { + for(i in seq_len(nset)) { + tab <- table(Pstrata[ind][Set[i,]]) + ## the levels of the Plot strata + levs <- names(tab) + + ## same permutation within each level of the Plot strata? + if(withinCTRL$constant) { + if(isTRUE(all.equal(typeW, "free"))) { + n <- unique(tab)[1L] + same.rand <- shuffleFree(n, n) + } else if(isTRUE(all.equal(typeW, "series"))) { + start <- shuffleFree(n / length(levs), 1L) + flip <- runif(1L) < 0.5 ## FIXME this should be moved out of the loop + } else if(isTRUE(all.equal(typeW, "grid"))) { + start.row <- shuffleFree(withinCTRL$nrow, 1L) + start.col <- shuffleFree(withinCTRL$ncol, 1L) + flip <- runif(2L) < 0.5 ## FIXME this should be moved out of the loop + } + } else { + start <- start.row <- start.col <- flip <- NULL + } + + ## for each level of strata, permute + for(lv in levs) { + ## must re-order strata here on basis of Ser as they + ## may have been permuted above + MATCH <- Pstrata[ind][Set[i,]] == lv + gr <- Set[i,][MATCH] + if((n.gr <- length(gr)) > 1) { + if(withinCTRL$constant && isTRUE(all.equal(typeW, "free"))) { + tmp[i,][which(MATCH)] <- gr[same.rand] + } else { + Args <- + switch(typeW, + "free" = list(x = n.gr, size = n.gr), + "series" = list(x = seq_len(n.gr), + mirror = withinCTRL$mirror, + start = start, + flip = flip), + "grid" = list(nrow = withinCTRL$nrow, + ncol = withinCTRL$ncol, + mirror = withinCTRL$mirror, + start.row = start.row, + start.col = start.col, + flip = flip)) + FUN <- + switch(typeW, + "free" = shuffleFree, + "series" = shuffleSeries, + "grid" = shuffleGrid) + tmp[i,][which(MATCH)] <- gr[do.call(FUN, Args)] + } + } + } + } + Set <- tmp + } } - } - out <- Set ## have to copy or next line fails - out[] <- ind[Set] - out + out <- Set ## have to copy or next line fails + out[] <- ind[Set] + out } Modified: pkg/permute/man/shuffleSet.Rd =================================================================== --- pkg/permute/man/shuffleSet.Rd 2013-06-12 19:53:40 UTC (rev 2521) +++ pkg/permute/man/shuffleSet.Rd 2013-06-12 20:12:04 UTC (rev 2522) @@ -11,7 +11,7 @@ set of permutations. } \usage{ -shuffleSet(n, nset = 1, control = how()) +shuffleSet(n, nset, control = how()) } %- maybe also 'usage' for other objects documented here. \arguments{ @@ -19,7 +19,9 @@ numeric; the number of observations in the sample set. } \item{nset}{ - numeric; the number of permutations to generate for the set + numeric; the number of permutations to generate for the set. Can be + missing, the default, in which case \code{nset} is determined from + \code{control}. } \item{control}{ an object of class \code{"how"} describing a valid From noreply at r-forge.r-project.org Wed Jun 12 22:12:33 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 22:12:33 +0200 (CEST) Subject: [Vegan-commits] r2523 - pkg/permute Message-ID: <20130612201233.90BC4184CEF@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 22:12:33 +0200 (Wed, 12 Jun 2013) New Revision: 2523 Modified: pkg/permute/NAMESPACE Log: missed registering quite a few get methods Modified: pkg/permute/NAMESPACE =================================================================== --- pkg/permute/NAMESPACE 2013-06-12 20:12:04 UTC (rev 2522) +++ pkg/permute/NAMESPACE 2013-06-12 20:12:33 UTC (rev 2523) @@ -65,3 +65,12 @@ S3method(`getComplete`, `default`) S3method(`getComplete`, `how`) S3method(`getComplete`, `permControl`) +S3method(`getRow`, `default`) +S3method(`getRow`, `how`) +S3method(`getRow`, `permControl`) +S3method(`getCol`, `default`) +S3method(`getCol`, `how`) +S3method(`getCol`, `permControl`) +S3method(`getDim`, `default`) +S3method(`getDim`, `how`) +S3method(`getDim`, `permControl`) From noreply at r-forge.r-project.org Wed Jun 12 22:13:19 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 22:13:19 +0200 (CEST) Subject: [Vegan-commits] r2524 - pkg/permute/R Message-ID: <20130612201319.CEB36184CEF@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 22:13:19 +0200 (Wed, 12 Jun 2013) New Revision: 2524 Modified: pkg/permute/R/allPerms.R Log: allPerms needs to pass nperms on to doAllPerms Modified: pkg/permute/R/allPerms.R =================================================================== --- pkg/permute/R/allPerms.R 2013-06-12 20:12:33 UTC (rev 2523) +++ pkg/permute/R/allPerms.R 2013-06-12 20:13:19 UTC (rev 2524) @@ -45,7 +45,8 @@ for (i in seq_along(spl)) { out[[i]] <- doAllPerms(spl[[i]], strataP, typeW, typeP, mirrorW, - mirrorP, constantW, dimW, dimP, control) + mirrorP, constantW, dimW, dimP, control, + nperms = nperms) } ## bind all the blocks together @@ -65,7 +66,7 @@ } `doAllPerms` <- function(obs, strataP, typeW, typeP, mirrorW, mirrorP, - constantW, dimW, dimP, control) { + constantW, dimW, dimP, control, nperms) { ## replicate a matrix by going via a list and bind together repMat <- function(mat, n) { res <- rep(list(mat), n) From noreply at r-forge.r-project.org Wed Jun 12 22:13:59 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 22:13:59 +0200 (CEST) Subject: [Vegan-commits] r2525 - pkg/permute/man Message-ID: <20130612201359.F00FF184CEF@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 22:13:59 +0200 (Wed, 12 Jun 2013) New Revision: 2525 Modified: pkg/permute/man/check.Rd Log: document new argument observed Modified: pkg/permute/man/check.Rd =================================================================== --- pkg/permute/man/check.Rd 2013-06-12 20:13:19 UTC (rev 2524) +++ pkg/permute/man/check.Rd 2013-06-12 20:13:59 UTC (rev 2525) @@ -12,7 +12,7 @@ selected permutation design. } \usage{ -check(object, control = how(), make.all = TRUE) +check(object, control = how(), make.all = TRUE, observed = FALSE) \method{summary}{check}(object, \dots) @@ -33,6 +33,8 @@ \item{make.all}{logical; should \code{permCheck} generate all possible permutations? Useful if want to check permutation design but not produce the matrix of all permutations.} + \item{observed}{logical; if making all possible permutations, should + the set include the observed permutation too?} \item{n}{the number of observations or an 'object' from which the number of observations can be determined via \code{getNumObs}.} \item{col, xlim, ylim, main, sub, ann, cex}{Graphical parameters.} From noreply at r-forge.r-project.org Wed Jun 12 22:22:05 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 22:22:05 +0200 (CEST) Subject: [Vegan-commits] r2526 - pkg/permute/man Message-ID: <20130612202205.24A621852AE@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 22:22:04 +0200 (Wed, 12 Jun 2013) New Revision: 2526 Modified: pkg/permute/man/shuffleSet.Rd Log: Details section was out of date Modified: pkg/permute/man/shuffleSet.Rd =================================================================== --- pkg/permute/man/shuffleSet.Rd 2013-06-12 20:13:59 UTC (rev 2525) +++ pkg/permute/man/shuffleSet.Rd 2013-06-12 20:22:04 UTC (rev 2526) @@ -29,8 +29,7 @@ } } \details{ - Currently, only the simple case of permutations not in the presence of - blocks (strata) is implemented. + TODO } \value{ Returns a matrix of permutations, where each row is a separate From noreply at r-forge.r-project.org Wed Jun 12 22:57:40 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Jun 2013 22:57:40 +0200 (CEST) Subject: [Vegan-commits] r2527 - in pkg/vegan: . R inst man Message-ID: <20130612205740.196BD185715@r-forge.r-project.org> Author: gsimpson Date: 2013-06-12 22:57:39 +0200 (Wed, 12 Jun 2013) New Revision: 2527 Modified: pkg/vegan/DESCRIPTION pkg/vegan/R/permutest.betadisper.R pkg/vegan/inst/ChangeLog pkg/vegan/man/betadisper.Rd pkg/vegan/man/permutest.betadisper.Rd Log: bump to 2.1-31, add dependency on permute >= 0.7-4, update betadisper, permutest betadisper to now final permute API Modified: pkg/vegan/DESCRIPTION =================================================================== --- pkg/vegan/DESCRIPTION 2013-06-12 20:22:04 UTC (rev 2526) +++ pkg/vegan/DESCRIPTION 2013-06-12 20:57:39 UTC (rev 2527) @@ -1,12 +1,12 @@ Package: vegan Title: Community Ecology Package -Version: 2.1-30 -Date: May 5, 2013 +Version: 2.1-31 +Date: June 12, 2013 Author: Jari Oksanen, F. Guillaume Blanchet, Roeland Kindt, Pierre Legendre, Peter R. Minchin, R. B. O'Hara, Gavin L. Simpson, Peter Solymos, M. Henry H. Stevens, Helene Wagner Maintainer: Jari Oksanen -Depends: permute, R (>= 2.12.0) +Depends: permute (>= 0.7-4), R (>= 2.12.0) Imports: lattice Suggests: MASS, mgcv, lattice, cluster, parallel, scatterplot3d, rgl, tcltk Description: Ordination methods, diversity analysis and other Modified: pkg/vegan/R/permutest.betadisper.R =================================================================== --- pkg/vegan/R/permutest.betadisper.R 2013-06-12 20:22:04 UTC (rev 2526) +++ pkg/vegan/R/permutest.betadisper.R 2013-06-12 20:57:39 UTC (rev 2527) @@ -1,5 +1,5 @@ `permutest.betadisper` <- function(x, pairwise = FALSE, - control = permControl(nperm = 999), ...) + control = how(nperm = 999), ...) { t.statistic <- function(x, y) { m <- length(x) @@ -11,6 +11,7 @@ pooled <- sqrt(((m-1)*xvar + (n-1)*yvar) / (m+n-2)) (xbar - ybar) / (pooled * sqrt(1/m + 1/n)) } + if(!inherits(x, "betadisper")) stop("Only for class \"betadisper\"") ## will issue error if only a single group @@ -20,42 +21,61 @@ mod.Q <- mod$qr p <- mod.Q$rank resids <- qr.resid(mod.Q, x$distances) - res <- numeric(length = control$nperm + 1) + + ## extract groups + group <- x$group + + ## get set of permutations - shuffleSet checks design + perms <- shuffleSet(length(group), control = control) + + ## number of permutations being performed, possibly adjusted after + ## checking in shuffleSet + nperm <- nrow(perms) + + ## set-up objects to hold permuted results + res <- numeric(length = nperm + 1) res[1] <- summary(mod)$fstatistic[1] + ## pairwise comparisons if(pairwise) { ## unique pairings combin <- combn(levels(x$group), 2) n.pairs <- ncol(combin) - t.stats <- matrix(0, ncol = n.pairs, nrow = control$nperm + 1) - t.stats[1,] <- apply(combn(levels(x$group), 2), 2, function(z) { - t.statistic(x$distances[x$group == z[1]], - x$distances[x$group == z[2]])}) + t.stats <- matrix(0, ncol = n.pairs, nrow = nperm + 1) + t.stats[1,] <- apply(combn(levels(group), 2), 2, function(z) { + t.statistic(x$distances[group == z[1]], + x$distances[group == z[2]])}) } - for(i in seq(along = res[-1])) { - perm <- shuffle(nobs, control = control) - perm.resid <- resids[perm] - f <- qr.fitted(mod.Q, perm.resid) + + ## begin loop over shuffleSet perms + for(i in seq_len(nperm)) { + perm <- perms[i,] ## take current permutation from set + perm.resid <- resids[perm] ## permute residuals + f <- qr.fitted(mod.Q, perm.resid) ## create new data mss <- sum((f - mean(f))^2) r <- qr.resid(mod.Q, perm.resid) rss <- sum(r^2) rdf <- nobs - p resvar <- rss / rdf res[i+1] <- (mss / (p - 1)) / resvar + ## pairwise comparisons if(pairwise) { for(j in seq_len(n.pairs)) { - grp1 <- x$distance[perm][x$group == combin[1, j]] - grp2 <- x$distance[perm][x$group == combin[2, j]] + grp1 <- x$distance[perm][group == combin[1, j]] + grp2 <- x$distance[perm][group == combin[2, j]] t.stats[i+1, j] <- t.statistic(grp1, grp2) } } } + + ## compute permutation p-value pval <- sum(res >= res[1]) / length(res) + if(pairwise) { df <- apply(combin, 2, function(z) { - length(x$distances[x$group == z[1]]) + - length(x$distance[x$group == z[2]]) - 2}) + length(x$distances[group == z[1]]) + + length(x$distance[group == z[2]]) - 2}) pairwise <- list(observed = 2 * pt(-abs(t.stats[1,]), df), permuted = apply(t.stats, 2, function(z) sum(abs(z) >= abs(z[1]))/length(z))) @@ -64,12 +84,13 @@ } else { pairwise <- NULL } - retval <- cbind(mod.aov[, 1:4], c(control$nperm, NA), c(pval, NA)) + + retval <- cbind(mod.aov[, 1:4], c(nperm, NA), c(pval, NA)) dimnames(retval) <- list(c("Groups", "Residuals"), c("Df", "Sum Sq", "Mean Sq", "F", "N.Perm", "Pr(>F)")) retval <- list(tab = retval, pairwise = pairwise, - groups = levels(x$group), control = control) + groups = levels(group), control = control) class(retval) <- "permutest.betadisper" retval } Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-06-12 20:22:04 UTC (rev 2526) +++ pkg/vegan/inst/ChangeLog 2013-06-12 20:57:39 UTC (rev 2527) @@ -2,6 +2,14 @@ VEGAN DEVEL VERSIONS at http://r-forge.r-project.org/ +Version 2.1-31 + + * Dependencies: Vegan now depends on a version equal to 0.7-4 or + later. + + * betadisper, permutest.betadisper: Modified to use the new + permute package API (from version 0.7-3 onwards). + Version 2.1-30 (opened May 5, 2013) * bioenv: can now use Mahalanobis, Manhattan and Gower distances Modified: pkg/vegan/man/betadisper.Rd =================================================================== --- pkg/vegan/man/betadisper.Rd 2013-06-12 20:22:04 UTC (rev 2526) +++ pkg/vegan/man/betadisper.Rd 2013-06-12 20:57:39 UTC (rev 2527) @@ -279,7 +279,7 @@ dis[c(2, 20)] <- NA mod2 <- betadisper(dis, groups) ## warnings mod2 -permutest(mod2, control = permControl(nperm = 100)) +permutest(mod2, control = how(nperm = 100)) anova(mod2) plot(mod2) boxplot(mod2) @@ -288,7 +288,7 @@ ## Using group centroids mod3 <- betadisper(dis, groups, type = "centroid") mod3 -permutest(mod3, control = permControl(nperm = 100)) +permutest(mod3, control = how(nperm = 100)) anova(mod3) plot(mod3) boxplot(mod3) Modified: pkg/vegan/man/permutest.betadisper.Rd =================================================================== --- pkg/vegan/man/permutest.betadisper.Rd 2013-06-12 20:22:04 UTC (rev 2526) +++ pkg/vegan/man/permutest.betadisper.Rd 2013-06-12 20:57:39 UTC (rev 2527) @@ -10,7 +10,7 @@ } \usage{ \method{permutest}{betadisper}(x, pairwise = FALSE, - control = permControl(nperm = 999), \dots) + control = how(nperm = 999), \dots) } %- maybe also 'usage' for other objects documented here. \arguments{ @@ -18,8 +18,7 @@ call to \code{betadisper}.} \item{pairwise}{logical; perform pairwise comparisons of group means?} \item{control}{a list of control values for the permutations - to replace the default values returned by the function - \code{\link{permControl}}} + as returned by the function \code{\link[permute]{how}}} \item{\dots}{Arguments passed to other methods.} } \details{ @@ -49,7 +48,7 @@ pairwise comparisons of group mean distances (dispersions or variances).} \item{groups}{character; the levels of the grouping factor.} \item{control}{a list, the result of a call to - \code{\link{permControl}}.} + \code{\link{how}}.} } \references{ Anderson, M.J. (2006) Distance-based tests for homogeneity of From noreply at r-forge.r-project.org Sat Jun 15 18:55:49 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 15 Jun 2013 18:55:49 +0200 (CEST) Subject: [Vegan-commits] r2528 - in pkg/vegan: R inst man tests Message-ID: <20130615165549.309A81851C6@r-forge.r-project.org> Author: gsimpson Date: 2013-06-15 18:55:48 +0200 (Sat, 15 Jun 2013) New Revision: 2528 Modified: pkg/vegan/R/print.protest.R pkg/vegan/R/protest.R pkg/vegan/inst/ChangeLog pkg/vegan/man/procrustes.Rd pkg/vegan/tests/vegan-tests.R Log: port protest to the new permute API Modified: pkg/vegan/R/print.protest.R =================================================================== --- pkg/vegan/R/print.protest.R 2013-06-12 20:57:39 UTC (rev 2527) +++ pkg/vegan/R/print.protest.R 2013-06-15 16:55:48 UTC (rev 2528) @@ -10,8 +10,7 @@ cat("Significance: ") cat(format.pval(x$signif),"\n") cat("Based on", x$permutations, "permutations") - if (!is.null(x$strata)) - cat(", stratified within", x$strata) + print(x$control) cat(".\n\n") invisible(x) } Modified: pkg/vegan/R/protest.R =================================================================== --- pkg/vegan/R/protest.R 2013-06-12 20:57:39 UTC (rev 2527) +++ pkg/vegan/R/protest.R 2013-06-15 16:55:48 UTC (rev 2528) @@ -1,5 +1,6 @@ `protest` <- - function (X, Y, scores = "sites", permutations = 999, strata, ...) + function (X, Y, scores = "sites", control = how(nperm = 999), + permutations = NULL, ...) { X <- scores(X, display = scores, ...) Y <- scores(Y, display = scores, ...) @@ -23,36 +24,28 @@ ## procrustes() for each permutation. The following gives the ## Procrustes r directly. procr <- function(X, Y) sum(svd(crossprod(X, Y), nv=0, nu=0)$d) - - if (length(permutations) == 1) { - if (permutations > 0) { - arg <- if (missing(strata)) NULL else strata - permat <- t(replicate(permutations, - permuted.index(N, strata = arg))) - } + + ## If permutations is NULL, work with control + if(is.null(permutations)) { + #np <- getNperm(control) + permutations <- shuffleSet(N, control = control) } else { - permat <- as.matrix(permutations) - if (ncol(permat) != N) + permutations <- as.matrix(permutations) + if (ncol(permutations) != N) stop(gettextf("'permutations' have %d columns, but data have %d observations", - ncol(permat), N)) - permutations <- nrow(permutations) + ncol(permutations), N)) } - perm <- sapply(1:permutations, - function(i, ...) procr(X, Y[permat[i,],])) - Pval <- (sum(perm >= sol$t0) + 1)/(permutations + 1) - if (!missing(strata)) { - strata <- deparse(substitute(strata)) - s.val <- strata - } - else { - strata <- NULL - s.val <- NULL - } + np <- nrow(permutations) + + perm <- sapply(seq_len(np), + function(i, ...) procr(X, Y[permutations[i,],])) + + Pval <- (sum(perm >= sol$t0) + 1)/(np + 1) + sol$t <- perm sol$signif <- Pval - sol$permutations <- permutations - sol$strata <- strata - sol$stratum.values <- s.val + sol$permutations <- np + sol$control <- control sol$call <- match.call() class(sol) <- c("protest", "procrustes") sol Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-06-12 20:57:39 UTC (rev 2527) +++ pkg/vegan/inst/ChangeLog 2013-06-15 16:55:48 UTC (rev 2528) @@ -10,6 +10,13 @@ * betadisper, permutest.betadisper: Modified to use the new permute package API (from version 0.7-3 onwards). + * protest: modified to use the new permute API. Gains argument + `control` which describes the design. As a result, `strata` + argument has been removed and `permutations` argument can only + be used to supply your own matrix of permutations. The number of + permutations and other features of the design are set via `control` + and function `how()` from permute. + Version 2.1-30 (opened May 5, 2013) * bioenv: can now use Mahalanobis, Manhattan and Gower distances Modified: pkg/vegan/man/procrustes.Rd =================================================================== --- pkg/vegan/man/procrustes.Rd 2013-06-12 20:57:39 UTC (rev 2527) +++ pkg/vegan/man/procrustes.Rd 2013-06-15 16:55:48 UTC (rev 2528) @@ -28,7 +28,8 @@ \method{residuals}{procrustes}(object, ...) \method{fitted}{procrustes}(object, truemean = TRUE, ...) \method{predict}{procrustes}(object, newdata, truemean = TRUE, ...) -protest(X, Y, scores = "sites", permutations = 999, strata, ...) +protest(X, Y, scores = "sites", control = how(nperm = 999), + permutations = NULL, ...) } \arguments{ @@ -64,12 +65,10 @@ \code{truemean = FALSE}.} \item{newdata}{Matrix of coordinates to be rotated and translated to the target.} - \item{permutations}{Number of permutations or a permutation matrix - where each row gives the permuted indices. These are used to asses the - signficance of the symmetric Procrustes statistic.} - \item{strata}{An integer vector or factor specifying the strata for - permutation. If supplied, observations are permuted only within the - specified strata.} + \item{control}{a list defining the permutation design, from a call to + \code{\link{how}}.} + \item{permutations}{A permutation matrix where each row gives the + permuted indices. If this is supplied, \code{cotrol} is ignored.} \item{ar.col}{Arrow colour.} \item{len}{Width of the arrow head.} \item{labels}{Character vector of text labels. Rownames of the result @@ -167,8 +166,8 @@ function.} \item{signif}{`Significance' of \code{t}} \item{permutations}{Number of permutations.} - \item{strata}{The name of the stratifying variable.} - \item{stratum.values}{Values of the stratifying variable.} + \item{control}{the list passed to argument \code{control} describing + the permutation design.} } \references{ Mardia, K.V., Kent, J.T. and Bibby, @@ -187,7 +186,9 @@ \seealso{\code{\link{monoMDS}}, for obtaining objects for \code{procrustes}, and \code{\link{mantel}} for an -alternative to \code{protest} without need of dimension reduction.} +alternative to \code{protest} without need of dimension reduction. See +\code{\link[permute]{how}} for details on specifying the type of +permutation required.} \examples{ data(varespec) Modified: pkg/vegan/tests/vegan-tests.R =================================================================== --- pkg/vegan/tests/vegan-tests.R 2013-06-12 20:57:39 UTC (rev 2527) +++ pkg/vegan/tests/vegan-tests.R 2013-06-15 16:55:48 UTC (rev 2528) @@ -153,13 +153,13 @@ ### end envfit & plot.envfit ### protest (& Procrustes analysis): Stability of the permutations and -### other results. +### other results. data(mite) mod <- rda(mite) x <- scores(mod, display = "si", choices=1:6) set.seed(4711) xp <- x[sample(nrow(x)),] -pro <- protest(x, xp, permutations = 99) +pro <- protest(x, xp, control = how(nperm = 99)) pro pro$t rm(x, xp, pro) From noreply at r-forge.r-project.org Mon Jun 17 15:44:09 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 17 Jun 2013 15:44:09 +0200 (CEST) Subject: [Vegan-commits] r2529 - in pkg: . ordiconsensus ordiconsensus/R ordiconsensus/data ordiconsensus/man Message-ID: <20130617134409.D725418577F@r-forge.r-project.org> Author: gblanchet Date: 2013-06-17 15:44:09 +0200 (Mon, 17 Jun 2013) New Revision: 2529 Added: pkg/ordiconsensus/ pkg/ordiconsensus/DESCRIPTION pkg/ordiconsensus/NAMESPACE pkg/ordiconsensus/R/ pkg/ordiconsensus/R/RV.R pkg/ordiconsensus/R/coeffCompare.R pkg/ordiconsensus/R/consensusRDA.R pkg/ordiconsensus/data/ pkg/ordiconsensus/data/beetle.expl.rda pkg/ordiconsensus/data/beetle.rda pkg/ordiconsensus/man/ pkg/ordiconsensus/man/RV.Rd pkg/ordiconsensus/man/beetle.Rd pkg/ordiconsensus/man/coeffCompare.Rd pkg/ordiconsensus/man/consensusRDA.Rd pkg/ordiconsensus/man/ordiconsensus-package.Rd Log: added the package ordiconsensus Added: pkg/ordiconsensus/DESCRIPTION =================================================================== --- pkg/ordiconsensus/DESCRIPTION (rev 0) +++ pkg/ordiconsensus/DESCRIPTION 2013-06-17 13:44:09 UTC (rev 2529) @@ -0,0 +1,11 @@ +Package: ordiconsensus +Type: Package +Title: Consensus of canonical ordinations through the canonical redundancy analysis +Version: 0.3-1 +Date: 2012-11-09 +Author: F. Guillaume Blanchet +Maintainer: F. Guillaume Blanchet +Description: This package include function to calculate a consensus of canonical redundancy analyses performed using different association coefficients +Depends: vegan +Suggests: FactoMineR +License: Unlimited Added: pkg/ordiconsensus/NAMESPACE =================================================================== --- pkg/ordiconsensus/NAMESPACE (rev 0) +++ pkg/ordiconsensus/NAMESPACE 2013-06-17 13:44:09 UTC (rev 2529) @@ -0,0 +1,8 @@ +### Export + +export(coeffCompare,consensusRDA,RV) + +### Import + +import(stats) +import(vegan) Added: pkg/ordiconsensus/R/RV.R =================================================================== --- pkg/ordiconsensus/R/RV.R (rev 0) +++ pkg/ordiconsensus/R/RV.R 2013-06-17 13:44:09 UTC (rev 2529) @@ -0,0 +1,16 @@ +RV <- +function(X, Y) { + #CC# General checks + if (nrow(X) != nrow(Y)) stop("'X' needs to have the same number of rows as 'Y'") + if (nrow(X) == 1) stop("Impossible to calculate RV using 1 object") + + Y <- scale(Y, scale = FALSE) + X <- scale(X, scale = FALSE) + + XXt <- tcrossprod(X) + YYt <- tcrossprod(Y) + + rv <- sum(diag(XXt %*% YYt))/(sum(diag(XXt %*% XXt)) * sum(diag(YYt %*% YYt)))^0.5 + + return(rv) +} Added: pkg/ordiconsensus/R/coeffCompare.R =================================================================== --- pkg/ordiconsensus/R/coeffCompare.R (rev 0) +++ pkg/ordiconsensus/R/coeffCompare.R 2013-06-17 13:44:09 UTC (rev 2529) @@ -0,0 +1,122 @@ +coeffCompare <- +function(ordires, ordisigniaxis,pval=0.05){ +### +### Compare a series of association coefficient calculated through an RDA +### +### Arguments : +### +### ordires : A list of "cca rda" object from the vegan package gathering a series of RDA performed with different association coefficients on the same data. +### ordisigniaxis : A list of anova.cca object where each axis was tested for each RDA in ordires or a vector defining the number of significant axes in the RDA. See details +### pval : Numeric. P-value threshold to select the number of axes to use. This argument is only active if a list of anova.cca object is given for the argument ordisigniaxis, otherwise it is not considered. +### +### +### Details : +### +### For the argument ordisigniaxis, if a vector of number of significant axes is given, for each RDA, it is assumed that the significant axes are selected in sequential order from the first axis. +### +### Value : +### +### RVmat : A matrix of RV coefficients calculated for all pairs of association coefficients +### mst : minimum spanning tree calculated on (1-RVmat) +### +### F. Guillaume Blanchet - February 2012. (Modified November 2012, June 2013) +################################################################################ + #---------------- + #CC# Basic object + #---------------- + #CC# Number of sites + nsites<-nrow(scores(ordires[[1]],display="sites")) + #CC# Number of juges (association coefficients) + njuges<-length(ordires) + + #------------------ + #CC# General checks + #------------------ + #### Check if ordires contains only RDAs + allRDA<-sapply(ordires,function(x) any(class(x)=="rda")) + if(!all(allRDA)){ + stop("One or more canonical ordination in 'ordires' is not an RDA") + } + + #### Check if ordires and ordisigniaxis have the same number of components + if(length(ordisigniaxis)!=length(ordires)){ + stop("'ordires' is not the same length as 'ordisigniaxis'") + } + + ordisigniClass<-sapply(ordisigniaxis,function(x) class(x)) + + #### Check if the capscale objects have the right number of species + anycapscale<-which(sapply(ordires,function(x) any(class(x)=="capscale"))) + if(length(anycapscale) > 0){ + nspcapscale<-numeric() + counter<-1 + for(i in anycapscale){ + nspcapscale[counter]<-nrow(scores(ordires[[i]],display="sp")) + counter<-counter+1 + } + if(any(nspcapscale==nsites)){ + stop("One or more of the analysis performed with capscale() did not include a site by species community matrix") + } + } + + #### If ordisigniaxis is a list + if(is.list(ordisigniaxis)){ + #### Check P-values + if(pval < 0 | pval > 1){ + stop("'pval' must range between 0 and 1") + } + + allsigni<-sapply(ordisigniaxis,function(x) any(class(x)=="anova.cca")) + if(!all(allsigni)){ + stop("One or more canonical ordination test in 'ordisigniaxis' is not an 'anova.cca' object") + } + + anovaname<-unique(unlist(strsplit(sapply(ordisigniaxis,function(x) rownames(x)[1]),"1"))) + if(!all(anovaname == "RDA" | anovaname == "CAP")){ + stop("anova.cca by axis should be either 'RDA' or 'CAP'") + } + + #CC# Extract the number of signicant axes to use for each canonical ordinations + ordisigniaxis<-sapply(ordisigniaxis,function(x) length(which(x[,5]<=pval))) + #### If ordisigniaxis is a vector + }else{ + if(is.vector(ordisigniaxis)){ + if(!is.numeric(ordisigniaxis)){ + stop("'ordisigniaxis' should be numeric") + } + }else{ + stop("'ordisigniaxis' should either be a list of anova.cca objects or a vector of number of significant axes") + } + } + + #### If there are no significant axes + if(any(ordisigniaxis < 1)){ + stop("One or more analysis does not have any significant axis remove it and start again") + } + + #------------------------------------------------------------- + #CC# Extract all the significant axes of matrix Z in scaling 1 + #------------------------------------------------------------- + Zsigni<-vector("list",length=njuges) + + for(i in 1:njuges){ + Zsigni[[i]]<-scores(ordires[[i]],display="lc",choices=1:ordisigniaxis[i],scaling=1) + } + + #CC# Coefficient RVf between the different association ceofficients + RVassoCoeff<-matrix(NA,nrow=njuges,ncol=njuges) + + for(i in 1:njuges){ + for(j in 1:njuges){ + RVassoCoeff[i,j]<-RV(Zsigni[[i]],Zsigni[[j]]) + } + } + + #CC# Construct a minimum spanning tree + mst<-spantree(as.dist(1-RVassoCoeff)) + + #CC# results + res<-list(RVmat=RVassoCoeff,mst=mst) + class(res)<-"coeffCompare" + return(res) +} Added: pkg/ordiconsensus/R/consensusRDA.R =================================================================== --- pkg/ordiconsensus/R/consensusRDA.R (rev 0) +++ pkg/ordiconsensus/R/consensusRDA.R 2013-06-17 13:44:09 UTC (rev 2529) @@ -0,0 +1,162 @@ +consensusRDA <- +function(ordires, ordisigniaxis,resp.var,expl.var,pval=0.05,scaling=2){ +### +### Calculates a consensus results for a series of canonical ordinations performed with different association coefficients on the same data. This function is only available for ordinations performed with canonical redundancy analysis (RDA) or variant of RDA such as distance-based RDA and transformation-based RDA +### +### Arguments : +### +### ordires : A list of "cca rda" object from the vegan package gathering a series of RDA performed with different association coefficients on the same data. +### ordisigniaxis : A list of anova.cca object where each axis was tested for each RDA in ordires or a vector defining the number of significant axes in the RDA. See details. +### resp.var : Matrix of response variables +### expl.var : Matrix of explanatory variables +### pval : Numeric. P-value threshold to select the number of axes to use. This argument is only active if a list of anova.cca object is given for the argument ordisigniaxis, otherwise it is not considered. +### scaling : Type of scaling used to project the results. Default is 1 (distance). +### +### +### Details +### +### For the argument ordisigniaxis, if a vector of number of significant axes is given, for each RDA, it is assumed that the significant axes are selected in sequential order from the first axis. +### +### Although it is possible to apply a scaling 3 to the RDA (it is available in the vegan package), this scaling should only be used for canonical correspondence analysis (CCA), it does not make any sense to use in the RDA framework. +### +### F. Guillaume Blanchet - February 2012 (Modified November 2012, June 2013) +################################################################################ + #---------------- + #CC# Basic object + #---------------- + #CC# Number of sites + nsites<-nrow(resp.var) + #CC# Number of species + nsp<-ncol(resp.var) + #CC# Number of juges (association coefficients) + njuges<-length(ordires) + + #------------------ + #CC# General checks + #------------------ + #### Check if there are completely collinear explanatory variables and count the number of non-collinear variables + expl.var.tmp<-expl.var + deter<-det(cor(expl.var)) + + #CC# threshold + tresh<-10^-8 + + while(deter<= tresh){ + expl.var.tmp<-expl.var.tmp[,-1] + deter<-det(cor(expl.var.tmp)) + } + nNoncolldesc<-ncol(expl.var.tmp) + + #### Check if ordires contains only RDAs + allRDA<-sapply(ordires,function(x) any(class(x)=="rda")) + if(!all(allRDA)){ + stop("One or more canonical ordination in 'ordires' is not an RDA") + } + + #### Check if ordires and ordisigniaxis have the same number of components + if(length(ordisigniaxis)!=length(ordires)){ + stop("'ordires' is not the same length as 'ordisigniaxis'") + } + + ordisigniClass<-sapply(ordisigniaxis,function(x) class(x)) + + #### Check if the capscale objects have the right number of species + anycapscale<-which(sapply(ordires,function(x) any(class(x)=="capscale"))) + if(length(anycapscale) > 0){ + nspcapscale<-numeric() + counter<-1 + for(i in anycapscale){ + nspcapscale[counter]<-nrow(scores(ordires[[i]],display="sp")) + counter<-counter+1 + } + if(any(nspcapscale==nsites)){ + stop("One or more of the analysis performed with capscale() did not include a site by species community matrix") + } + } + + #### If ordisigniaxis is a list + if(is.list(ordisigniaxis)){ + #### Check P-values + if(pval < 0 | pval > 1){ + stop("'pval' must range between 0 and 1") + } + + allsigni<-sapply(ordisigniaxis,function(x) any(class(x)=="anova.cca")) + if(!all(allsigni)){ + stop("One or more canonical ordination test in 'ordisigniaxis' is not an 'anova.cca' object") + } + + anovaname<-unique(unlist(strsplit(sapply(ordisigniaxis,function(x) rownames(x)[1]),"1"))) + if(!all(anovaname == "RDA" | anovaname == "CAP")){ + stop("anova.cca by axis should be either 'RDA' or 'CAP'") + } + + #CC# Extract the number of signicant axes to use for each canonical ordinations + ordisigniaxis<-sapply(ordisigniaxis,function(x) length(which(x[,5]<=pval))) + #### If ordisigniaxis is a vector + }else{ + if(is.vector(ordisigniaxis)){ + if(!is.numeric(ordisigniaxis)){ + stop("'ordisigniaxis' should be numeric") + } + }else{ + stop("'ordisigniaxis' should either be a list of anova.cca objects or a vector of number of significant axes") + } + } + + #### If there are no significant axes + if(any(ordisigniaxis < 1)){ + stop("One or more analysis does not have any significant axis remove it and start again") + } + + #### Make sure that X is a matrix + expl.var<-as.matrix(expl.var) + + #------------------------------------------------------------- + #CC# Extract all the significant axes of matrix Z in scaling 1 + #------------------------------------------------------------- + Zsigni<-vector("list",length=njuges) + Zsignimat<-matrix(NA,ncol=0,nrow=nsites) + + for(i in 1:njuges){ + Zsigni[[i]]<-scores(ordires[[i]],display="lc",choices=1:ordisigniaxis[i],scaling=1) + Zsignimat<-cbind(Zsignimat,Zsigni[[i]]) + } + + #------------------------------------------------- + #CC# Perform an RDA between Zsignimat and expl.var + #------------------------------------------------- + Zrda<-rda(Zsignimat,expl.var) + ZrdaEigen<-eigenvals(Zrda)[1:nNoncolldesc] + naxes<-length(ZrdaEigen) + + #CC# Extract the Z consensus results from RDA + Zconsensus<-scores(Zrda,choice=1:nNoncolldesc,display="lc",scaling=1) + + #CC# Extract the C consensus results from RDA + Cconsensus<-scores(Zrda,choice=1:nNoncolldesc,display="bp",scaling=1) + + #### This is the procedure proposed by Legendre and Legendre (2012, Subsection 9.3.3) + #### It is also the procedure proposed by Oksanen et al. in vegan and described in Blanchet et al. (submitted) + Uconsensus<-t(scale(resp.var,scale=FALSE))%*%Zconsensus%*%diag(ZrdaEigen^(-0.5))/sqrt(nsites-1) + + #---------------------- + #CC# Ordination Scaling + #---------------------- + if(scaling==2){ + #------------- + #CC# Consensus + #------------- + #CC# Sites + Zconsensus<-sweep(Zconsensus,2,sqrt(ZrdaEigen/sum(ZrdaEigen)),"/") + + #CC# Species + Uconsensus<-sweep(Uconsensus,2,sqrt(ZrdaEigen/sum(ZrdaEigen)),"*") + + #### No scaling is performed on descriptors + } + + res<-list(values=ZrdaEigen,siteConsensus=Zconsensus,spConsensus=Uconsensus,descConsensus=Cconsensus) + + return(res) +} Added: pkg/ordiconsensus/data/beetle.expl.rda =================================================================== (Binary files differ) Property changes on: pkg/ordiconsensus/data/beetle.expl.rda ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: pkg/ordiconsensus/data/beetle.rda =================================================================== (Binary files differ) Property changes on: pkg/ordiconsensus/data/beetle.rda ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: pkg/ordiconsensus/man/RV.Rd =================================================================== --- pkg/ordiconsensus/man/RV.Rd (rev 0) +++ pkg/ordiconsensus/man/RV.Rd 2013-06-17 13:44:09 UTC (rev 2529) @@ -0,0 +1,41 @@ +\name{RV} +\alias{RV} + +\title{ +RV coefficient +} +\description{ +Calculates an RV coefficient. +} +\usage{ +RV(X, Y) +} + +\arguments{ + \item{X}{A matrix with the same number of rows as \code{Y}} + \item{Y}{A matrix with the same number of rows as \code{X}} +} +\details{ + \code{RV} calculates the RV coefficient between two matrices.The RV coefficient is a multivariate generalization of the Pearson's correlation. The package \pkg{FactoMineR} offers a much more complete version of the RV coefficient (\code{\link[FactoMineR]{coeffRV}}). This function was designed to calculate only the RV coefficient making it much faster than \code{\link[FactoMineR]{coeffRV}}. +} +\value{ +The RV coefficient. A numeric value ranging between 0 and 1 +} +\references{ +Escouffier, Y. (1973) \emph{Le traitement des variables vectorielles}. Biometrics \bold{29}:751--760.\cr +} +\author{ +F. Guillaume Blanchet +} + +\seealso{ +\code{\link[FactoMineR]{coeffRV}} +} +\examples{ +data(beetle) +data(beetle.expl) + +RV(beetle,beetle.expl) + +} +\keyword{ multivariate } Added: pkg/ordiconsensus/man/beetle.Rd =================================================================== --- pkg/ordiconsensus/man/beetle.Rd (rev 0) +++ pkg/ordiconsensus/man/beetle.Rd 2013-06-17 13:44:09 UTC (rev 2529) @@ -0,0 +1,88 @@ +\name{beetle} +\alias{beetle} +\alias{beetle.expl} +\docType{data} +\title{ +Carabid beetle data with explanatory variables +} +\description{ +Carabid beetle data collected at 192 sites by Colin Bergeron in the summer of 2003 in Northwestern Alberta, Canada. See Bergeron et al. (2011, 2012) and Blanchet et al. (2013) for details. +} +\usage{ +data(beetle) +data(beetle.expl) +} +\format{ + The \code{beetle} data set is a data frame that contains the data on the following 37 carabid species: + \describe{ + \item{\code{Agongrat}}{\emph{Agonum gratiosum}} + \item{\code{Agonplac}}{\emph{Agonum placidum}} + \item{\code{Agonretr}}{\emph{Agonum retractum}} + \item{\code{Agonsord}}{\emph{Agonum sordens}} + \item{\code{Agonsupe}}{\emph{Agonum superioris}} + \item{\code{Amarlitt}}{\emph{Amara littoralis}} + \item{\code{Amarluni}}{\emph{Amara lunicollis}} + \item{\code{Badiobtu}}{\emph{Badister obtusus}} + \item{\code{Bembgrap}}{\emph{Bembidion grapii}} + \item{\code{Bembrupi}}{\emph{Bembidion rupicola}} + \item{\code{Calaadve}}{\emph{Calathus advena}} + \item{\code{Calaingr}}{\emph{Calathus ingratus}} + \item{\code{Calofrig}}{\emph{Calosoma frigidum}} + \item{\code{Caracham}}{\emph{Carabus chamissonis}} + \item{\code{Dichcogn}}{\emph{Dicheirotrichus cognatus}} + \item{\code{Elapamer}}{\emph{Elaphrus americanus}} + \item{\code{Elaplapp}}{\emph{Elaphrus lapponicus}} + \item{\code{Harpfulv}}{\emph{Harpalus fulvilabris}} + \item{\code{Loripili}}{\emph{Loricera pilicornis}} + \item{\code{Miscarct}}{\emph{Miscodera arctica}} + \item{\code{Nebrgyll}}{\emph{Nebria gyllenhali}} + \item{\code{Notibore}}{\emph{Notiophilus borealis}} + \item{\code{Notidire}}{\emph{Notiophilus directus}} + \item{\code{Patrfove}}{\emph{Patrobus foveocollis}} + \item{\code{Patrsept}}{\emph{Patrobus septentrionis}} + \item{\code{Platdece}}{\emph{Platynus decentis}} + \item{\code{Platmann}}{\emph{Platynus mannerheimii}} + \item{\code{Pteradst}}{\emph{Pterostichus adstrictus}} + \item{\code{Pterbrev}}{\emph{Pterostichus brevicornis}} + \item{\code{Pterpens}}{\emph{Pterostichus pensylvanicus}} + \item{\code{Pterpunc}}{\emph{Pterostichus punctatissimus}} + \item{\code{Pterripa}}{\emph{Pterostichus riparius}} + \item{\code{Seriquad}}{\emph{Sericoda quadripunctata}} + \item{\code{Sterhaem}}{\emph{Stereocerus haematopus}} + \item{\code{Synuimpu}}{\emph{Synuchus impunctatus}} + \item{\code{Trecapic}}{\emph{Trechus apicalis}} + \item{\code{Trecchal}}{\emph{Trechus chalybeus}} + +The \code{beetle.expl} data set is a data frame that contains the relative basal area of the 25 trees closest to the center of each sampling site. The relative basal area is presented by tree species. + + \item{\code{Pt}}{Aspen (\emph{Populus tremuloides})} + \item{\code{Bp}}{White birch (\emph{Betula papyrifera})} + \item{\code{Ab}}{Balsam fir (\emph{Abie balsamea})} + \item{\code{Ll}}{Tamarack (\emph{Larix laricina})} + \item{\code{Pb}}{Balsam poplar (\emph{Populus balsamifera})} + \item{\code{Pc}}{Lodgepole pine (\emph{Pinus contorta})} + \item{\code{Pm}}{Black spruce (\emph{Picea mariana})} + \item{\code{Pg}}{White spruce (\emph{Picea glauca})} + } +} +\details{ +The \code{beetle} data has been previously transformed so that the ecological illustration presented in Blanchet et al. (in press) can be easily reproduced. The abundance of carabids was divided by the number of days each trap (there were three traps per sites) was active in the field. +} +\source{ +All questions about these data (including if there are interest for using this data in publications) should be adressed to Colin Bergeron (cb1[at]ualberta.ca). +} +\references{ +Bergeron J.A.C., J.R. Spence, and W.J.A. Volney. 2011. Landscape patterns of species-level associations between ground-beetles (Coleoptera: Carabidae) and overstory trees in boreal forests of western Canada (Coleoptera: Carabidae). In Erwin, TL (Ed), \emph{Proceedings of a Symposium honoring the careers of Ross and Joyce Bell and their contributions to scientific work}, Burlington, VT, 12-15 June 2010. \emph{ZooKeys} \strong{147}: 577--600. + +Bergeron J.A.C., F.G. Blanchet, J.R. Spence, and W.J.A. Volney. 2012. Ecosystem classification and inventory maps as surrogates for ground beetle assemblages in boreal forest. \emph{Journal of Plant Ecology} \strong{5}:97--108. + +Blanchet, F.G., J.A.C. Bergeron, J.R. Spence, and F. He. 2013. Landscape effects of disturbance, habitat heterogeneity and spatial autocorrelation for a ground beetle (Carabidae) assemblage in mature boreal forest. \emph{Ecography} \strong{36}:636--647. + +Blanchet, F.G., P. Legendre, J.A.C. Bergeron, J.R. Spence, and F. He. \emph{in press}. Consensus RDA across dissimilarity coefficients for canonical ordination of community composition data. \emph{Ecological Monographs}. + +} +\examples{ +data(beetle) +data(beetle.expl) +} +\keyword{datasets} Added: pkg/ordiconsensus/man/coeffCompare.Rd =================================================================== --- pkg/ordiconsensus/man/coeffCompare.Rd (rev 0) +++ pkg/ordiconsensus/man/coeffCompare.Rd 2013-06-17 13:44:09 UTC (rev 2529) @@ -0,0 +1,99 @@ +\name{coeffCompare} +\alias{coeffCompare} + +\title{ Compare dissimilarities used within the RDA framework} +\description{ + This function compares association coefficients used through the RDA framework with a minimum spanning tree. It was designed to compare how information explained by one dissimilarity coefficient diverge from the information explained by another. The comparison is made simultaneously on the site scores, the species scores and the canonical coefficients. +} +\usage{ +coeffCompare(ordires, ordisigniaxis, pval = 0.05) +} + +\arguments{ + \item{ordires}{ + A list of \code{\link[vegan]{rda}} or \code{\link[vegan]{capscale}} result object that includes a series of RDA or distance-based RDA (dbRDA) performed with different association coefficients on the same data. +} + \item{ordisigniaxis}{ + A list of \code{\link[vegan]{anova.cca}} object where each axis was tested for each RDA (or dbRDA) in \code{ordires}. This argument can also be a vector defining the number of significant axes in the RDA. See details. +} + \item{pval}{ + Numeric. P-value threshold to select the number of axes to use. This argument is only active if a list of \code{\link[vegan]{anova.cca}} object is given for the argument \code{ordisigniaxis}, otherwise it is not considered. Default is 0.05. +} +} +\details{ +For the argument \code{ordisigniaxis}, if a vector of number of significant axes is given, it is assumed that the significant axes are selected in sequential order from the first axis. +The comparison made here rely on the RV coefficient \code{\link{RV}}, a multivariate generalization of the Pearson's correlation where matrix with the same number of rows are compared. +\code{coeffCompare} should be used prior to using \code{\link{consensusRDA}} because it informs the user about the different association coefficients considered interesting to perform a consensus RDA. An association coefficient presenting results too different from the others should not be included in the consensus RDA, it should be considered apart or discarded. +} +\value{ +\item{RVmat}{A matrix of RV coefficients calculated from the sites scores matrices of RDA for all pairs of association coefficients} +\item{mst}{minimum spanning tree calculated on (1-siteRVmat)} +} +\author{ +F. Guillaume Blanchet +} + +\seealso{ +\code{\link{RV}}, \code{\link{consensusRDA}} +} +\examples{ +################################################################### +### This example reproduces Figure 7b of Blanchet et al. (in press) +################################################################### +data(beetle) +data(beetle.expl) + +### Construct results object +ndis<-10 +ordiRes<-vector("list",length=ndis) + +#--------------------------------------------- +### Perform the various constrained ordination +#--------------------------------------------- +### RDA species profile +sp<-beetle/apply(beetle,1,sum) +ordiRes[[1]]<-rda(sp~.,data=beetle.expl) + +### RDA chord +chord<-beetle/sqrt(apply(beetle^2,1,sum)) +ordiRes[[2]]<-rda(chord~.,data=beetle.expl) + +### RDA Hellinger +hell<-decostand(beetle,method="hellinger") +ordiRes[[3]]<-rda(hell~.,data=beetle.expl) + +### RDA chi2 +chisq<-decostand(beetle,method="chi.square") +ordiRes[[4]]<-rda(chisq~.,data=beetle.expl) + +### db-RDA Bray-Curtis +ordiRes[[5]]<-capscale(sqrt(vegdist(beetle,method="bray"))~.,data=beetle.expl,comm=beetle) + +### db-RDA square-root Bray-Curtis +ordiRes[[6]]<-capscale(sqrt(vegdist(beetle^0.5,method="bray"))~.,data=beetle.expl,comm=beetle) + +### db-RDA fourth-root Bray-Curtis +ordiRes[[7]]<-capscale(sqrt(vegdist(beetle^0.25,method="bray"))~.,data=beetle.expl,comm=beetle) + +### db-RDA modified Gower log 2 +ordiRes[[8]]<-capscale(vegdist(decostand(beetle, "log",logbase=2), "altGower")~.,data=beetle.expl,comm=beetle) ### Warning message stem from log transformation of 0 + +### db-RDA modified Gower log 5 +ordiRes[[9]]<-capscale(vegdist(decostand(beetle, "log",logbase=5), "altGower")~.,data=beetle.expl,comm=beetle) ### Warning message stem from log transformation of 0 + +### db-RDA modified Gower log 10 +ordiRes[[10]]<-capscale(vegdist(decostand(beetle, "log",logbase=10), "altGower")~.,data=beetle.expl,comm=beetle) ### Warning message stem from log transformation of 0 + +### Compare association coefficients +AssoComp<-coeffCompare(ordiRes,rep(7,ndis)) + +#--------------------------------------------- +### Draw a graphic to visualize the comparison +#--------------------------------------------- +### Name of association coefficient compared +name<-c("Species profiles","Chord","Hellinger","Chi2","Bray-Curtis","(Bray-Curtis)^0.5","(Bray-Curtis)^0.25","mGowerlog2","mGowerlog5","mGowerlog10") + +plot(AssoComp$mst,type="t",labels=name,xlab="",ylab="",main="MST Sites scores") + +} +\keyword{ multivariate } Added: pkg/ordiconsensus/man/consensusRDA.Rd =================================================================== --- pkg/ordiconsensus/man/consensusRDA.Rd (rev 0) +++ pkg/ordiconsensus/man/consensusRDA.Rd 2013-06-17 13:44:09 UTC (rev 2529) @@ -0,0 +1,115 @@ +\name{consensusRDA} +\alias{consensusRDA} +\title{ +Calculates a consensus RDA +} +\description{ +Calculates a consensus RDA. That is a consensus of a series of RDA performed on the same data using different association coefficients. +} +\usage{ +consensusRDA(ordires, ordisigniaxis, resp.var, expl.var, pval = 0.05, scaling = 2) +} +%- maybe also 'usage' for other objects documented here. +\arguments{ + \item{ordires}{ + A list of \code{\link[vegan]{rda}} or \code{\link[vegan]{capscale}} result object that includes a series of RDA or distance-based RDA (dbRDA) performed with different association coefficients on the same data. +} + \item{ordisigniaxis}{ + A list of \code{\link[vegan]{anova.cca}} object where each axis was tested for each RDA (or dbRDA) in \code{ordires}. This argument can also be a vector defining the number of significant axes in the RDA. See details. +} + \item{resp.var}{ + A matrix of the response variables (species) used to construct all the RDA (or dbRDA) in \code{ordires}. +} + \item{expl.var}{ + A matrix of the explanatory variables used to construct all the RDA (or dbRDA) in \code{ordires}. +} + \item{pval}{ + Numeric. P-value threshold to select the number of axes to use. This argument is only active if a list of \code{\link[vegan]{anova.cca}} object is given for the argument \code{ordisigniaxis}, otherwise it is not considered. Default is 0.05. +} + \item{scaling}{ + Type of scaling used to project the results. A distance scaling (scaling 1) or a correlation scaling (scaling 2) can be used. Default is scaling 1. See details for more information. +} +} +\details{ +For the argument \code{ordisigniaxis}, if a vector of number of significant axes is given for each RDA, it is assumed that the significant axes are selected in sequential order from the first axis. +Although it is possible for the scaling to be 3 (it is available in the vegan package), this scaling should only be used for canonical correspondence analysis (CCA), it does not make any sense to use in the RDA framework. +} +\value{ + \item{value}{A vector of eigenvalues associated to the axes of the consensus RDA} + \item{siteConsensus}{A matrix of consensus sites scores} + \item{spConsensus}{A matrix of consensus species scores} + \item{descConsensus}{A matrix of consensus canonical coefficient} +} +\author{ +F. Guillaume Blanchet +} + +\examples{ +########################################################################### +### This example reproduces Figure 7c of Blanchet et al. (in press) +### +### However, for illustration purposes RDA axes were tested using anova.cca +### This only has minor influence on the triplot. +########################################################################### +data(beetle) +data(beetle.expl) + +### Construct results object +ndis<-9 +ordiRes<-vector("list",length=ndis) + +### RDA species profile +sp<-beetle/apply(beetle,1,sum) +ordiRes[[1]]<-rda(sp~.,data=beetle.expl) + +### RDA chord +chord<-beetle/sqrt(apply(beetle^2,1,sum)) +ordiRes[[2]]<-rda(chord~.,data=beetle.expl) + +### RDA Hellinger +hell<-decostand(beetle,method="hellinger") +ordiRes[[3]]<-rda(hell~.,data=beetle.expl) + +### db-RDA Bray-Curtis +ordiRes[[4]]<-capscale(sqrt(vegdist(beetle,method="bray"))~.,data=beetle.expl,comm=beetle) + +### db-RDA square-root Bray-Curtis +ordiRes[[5]]<-capscale(sqrt(vegdist(beetle^0.5,method="bray"))~.,data=beetle.expl,comm=beetle^0.5) + +### db-RDA fourth-root Bray-Curtis +ordiRes[[6]]<-capscale(sqrt(vegdist(beetle^0.25,method="bray"))~.,data=beetle.expl,comm=beetle^0.25) + +### db-RDA modified Gower log 2 +ordiRes[[7]]<-capscale(vegdist(decostand(beetle, "log",logbase=2), "altGower")~.,data=beetle.expl,comm=decostand(beetle, "log",logbase=2)) ### Warning message stem from log transformation of 0 + +### db-RDA modified Gower log 5 +ordiRes[[8]]<-capscale(vegdist(decostand(beetle, "log",logbase=5), "altGower")~.,data=beetle.expl,comm=decostand(beetle, "log",logbase=5)) ### Warning message stem from log transformation of 0 + +### db-RDA modified Gower log 10 +ordiRes[[9]]<-capscale(vegdist(decostand(beetle, "log",logbase=10), "altGower")~.,data=beetle.expl,comm=decostand(beetle, "log",logbase=10)) ### Warning message stem from log transformation of 0 + +#---------------- +### Test RDA axis +#---------------- +ordiResTest<-vector("list",length=ndis) + +for(i in 1:ndis){ + ordiResTest[[i]]<-anova.cca(ordiRes[[i]],by="axis",cutoff=0.1) +} + +### Consensus RDA +consRDA<-consensusRDA(ordiRes,ordiResTest,beetle,beetle.expl) +summary(consRDA) + +axisLabels<-c(paste("Axis 1 - ",round(consRDA$values[1]/sum(consRDA$values),4)*100,"%",sep=""),paste("Axis 2 - ",round(consRDA$values[2]/sum(consRDA$values),4)*100,"%",sep="")) +plot(consRDA$siteConsensus[,1:2],pch=19,xlab=axisLabels[1],ylab=axisLabels[2],las=1) +abline(h=0,v=0,lty=3) + +arrows(0,0,consRDA$spConsensus[,1]*10,consRDA$spConsensus[,2]*10,col="red",length=0.1,angle=12) +text(consRDA$spConsensus[,1:2]*10,labels=rownames(consRDA$spConsensus),col="red") + +arrows(0,0,consRDA$descConsensus[,1]*0.4,consRDA$descConsensus[,2]*0.4,col="blue",length=0.1,angle=12) +text(consRDA$descConsensus[,1:2]*0.4,labels=rownames(consRDA$descConsensus),col="blue") +} + +\keyword{ multivariate } Added: pkg/ordiconsensus/man/ordiconsensus-package.Rd =================================================================== --- pkg/ordiconsensus/man/ordiconsensus-package.Rd (rev 0) +++ pkg/ordiconsensus/man/ordiconsensus-package.Rd 2013-06-17 13:44:09 UTC (rev 2529) @@ -0,0 +1,27 @@ +\name{ordiconsensus-package} +\alias{ordiconsensus-package} +\alias{ordiconsensus} +\docType{package} +\title{ +Consensus RDA package +} +\description{ +Package to perform a consensus RDA, a method that finds the consensus among different RDA (or distance-based RDA) performed using different dissimilarity coefficients (e.g. Hellinger, Chord, Bray-Curtis) +} +\details{ +\tabular{ll}{ +Package: \tab ordiconsensus\cr +Type: \tab Package\cr +Version: \tab 0.3-1\cr +Date: \tab 2012-11-12\cr +License: \tab Unlimited\cr +} +This package includes different functions to perform a consensus RDA. It follows the work of Blanchet et al. (In press) +} +\author{ +F. Guillaume Blanchet + +Maintainer: F. Guillaume Blanchet + +} +\keyword{ multivariate } From noreply at r-forge.r-project.org Tue Jun 18 15:56:30 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 18 Jun 2013 15:56:30 +0200 (CEST) Subject: [Vegan-commits] r2530 - in pkg/ordiconsensus: . R man Message-ID: <20130618135630.5F3321813B9@r-forge.r-project.org> Author: gblanchet Date: 2013-06-18 15:56:29 +0200 (Tue, 18 Jun 2013) New Revision: 2530 Added: pkg/ordiconsensus/R/SADbin.R pkg/ordiconsensus/man/SADbin.Rd Modified: pkg/ordiconsensus/DESCRIPTION pkg/ordiconsensus/NAMESPACE pkg/ordiconsensus/man/consensusRDA.Rd pkg/ordiconsensus/man/ordiconsensus-package.Rd Log: small correction and add SADbin Modified: pkg/ordiconsensus/DESCRIPTION =================================================================== --- pkg/ordiconsensus/DESCRIPTION 2013-06-17 13:44:09 UTC (rev 2529) +++ pkg/ordiconsensus/DESCRIPTION 2013-06-18 13:56:29 UTC (rev 2530) @@ -1,7 +1,7 @@ Package: ordiconsensus Type: Package Title: Consensus of canonical ordinations through the canonical redundancy analysis -Version: 0.3-1 +Version: 0.3-2 Date: 2012-11-09 Author: F. Guillaume Blanchet Maintainer: F. Guillaume Blanchet Modified: pkg/ordiconsensus/NAMESPACE =================================================================== --- pkg/ordiconsensus/NAMESPACE 2013-06-17 13:44:09 UTC (rev 2529) +++ pkg/ordiconsensus/NAMESPACE 2013-06-18 13:56:29 UTC (rev 2530) @@ -1,6 +1,6 @@ ### Export -export(coeffCompare,consensusRDA,RV) +export(coeffCompare,consensusRDA,RV,SADbin) ### Import Added: pkg/ordiconsensus/R/SADbin.R =================================================================== --- pkg/ordiconsensus/R/SADbin.R (rev 0) +++ pkg/ordiconsensus/R/SADbin.R 2013-06-18 13:56:29 UTC (rev 2530) @@ -0,0 +1,103 @@ +SADbin <- +function(data,method=c("log","modlog","modhalflog"),base=2){ +### Function that does method 1 of binning from Gray et al. (2006) +### +### Arguments: +### +### data: species abundant data +### method: binning method following Gray et al. (2006). Either "log", "modlog", or "modhalflog" +### base: base of the log to be used. +### +### copyleft - Guillaume Blanchet - August 2008 +################################################################## + method<-match.arg(method) + + "%w/o%" <- function(x,y) x[!x %in% y] #-- x without y + #CC# Find the number of class to be used + spmax<-max(data) + + #CC# Number of bins + nbin<-ceiling(log(spmax+1,base=base))+1 + + #CC# Find the levels of abundance of species + lev<-as.numeric(levels(as.factor(data))) + nlev<-nlevels(as.factor(data)) + + #CC# Number of species per level + nsp.lev<-vector(length=nlev) + data.lev<-vector(length=length(data)) + + for(i in 1:nlev){ + search<-which(data==lev[i]) + nsp.lev[i]<-length(search) + data.lev[search]<-lev[i] + } + + #### Find the number of species in each bins (and which species goes in which bins) + #CC# Starting the species which give an integer with a log_base + sp.div<-base^(1:(nbin-1)) + sp.div<-c(1,sp.div) + + bin.mat<-matrix(0,ncol=nbin,nrow=length(data)) + + bin.sp.div<-vector(length=nbin) + for(i in 1:nbin){ + if(length(which(lev==sp.div[i]))!=0){ + bin.sp.div[i]<-nsp.lev[which(lev==sp.div[i])] + bin.mat[which(data.lev==sp.div[i]),i]<-1 + } + } + + if(method=="modhalflog"){ + bin.sp.div2<-bin.sp.div/2 + bin.sp.div.good<-c(0,bin.sp.div2)+c(bin.sp.div2,0) + + bin.mat2<-bin.mat/2 + bin.mat<-cbind(0,bin.mat2)+cbind(bin.mat2,0) + } + + #CC# Than with all the other ones + spnot.div<-data %w/o% sp.div + spnot.div2<-which((data %in% sp.div)==FALSE) + + bin.spnot.div<-vector(mode="numeric",length=nbin) + + if(method=="log" | method=="modhalflog"){ + for(i in 1:length(spnot.div)){ + bin.sel<-which(sp.div>spnot.div[i])[1] + bin.spnot.div[bin.sel]<-bin.spnot.div[bin.sel]+1 + + bin.mat[spnot.div2[i],bin.sel]<-1 + } + } + else if(method=="modlog"){ + + for(i in 1:length(spnot.div)){ + bin.sel<-which(sp.div>spnot.div[i])[1]-1 + bin.spnot.div[bin.sel]<-bin.spnot.div[bin.sel]+1 + + bin.mat[spnot.div2[i],bin.sel]<-1 + } + }else{ + stop("method should be 'log' or 'modlog'") + } + + #CC# Construct the resulting binning + if(method=="modhalflog"){ + bin<-bin.sp.div.good[-length(bin.sp.div.good)]+bin.spnot.div + bin.mat<-bin.mat[,-length(bin.sp.div.good)] + } + else if(method=="log"){ + bin<-bin.sp.div+bin.spnot.div + } + else if(method=="modlog"){ + bin<-bin.sp.div+bin.spnot.div + bin<-bin[-length(bin)] + bin.mat<-bin.mat[,-ncol(bin.mat)] + + }else{ + stop("method should be 'log' or 'modlog'") + } + + return(list(bin=bin,sp.bin=bin.mat)) +} Added: pkg/ordiconsensus/man/SADbin.Rd =================================================================== --- pkg/ordiconsensus/man/SADbin.Rd (rev 0) +++ pkg/ordiconsensus/man/SADbin.Rd 2013-06-18 13:56:29 UTC (rev 2530) @@ -0,0 +1,54 @@ +\name{SADbin} +\alias{SADbin} +\title{ +Species-abundance distribution (SAD) bins +} +\description{ +This function constructs bins for a species-abundance distribution. The function was designed so that every variation of bins can easily be constructed. +} +\usage{ +SADbin(data, method = c("log", "modlog", "modhalflog"), base = 2) +} +%- maybe also 'usage' for other objects documented here. +\arguments{ + \item{data}{ +A vector of species abundance for the whole study area. +} + \item{method}{ +A character string defining which binning method to use. +} + \item{base}{ +The logarithm base used to perform the binning +} +} +\details{ +All value in \code{data} are expected to be count data. An error message will be sent if the value in \code{data} are not integers. + +The different method of binning are defined as such : + +log (using a base = 2) : Bin 1 = 1, Bin 2 = 2, Bin 3 = 3-4, Bin 4 = 5-8, ... + +modlog (using a base = 2) : Bin 1 = 1, Bin 2 = 2-3, Bin 3 = 4-7, Bin 4 = 8-15,... + +modhalflog (using a base = 2) : Bin 1 = half the number of species with 1 individuals, Bin 2 = half the number of species with 2 individuals, all species with 3 individuals and half the number of species with 4 individuals, Bin 3 = 4-8, abundances that fall exactly on the boundary are divided equally between the given bin and the next lower bin, and so on. +} + +\value{ +\item{bin}{A vector defining the number of species in each bin} +\item{sp.bin}{A matrix with the species in rows and the bins in columns. This matrix describe which species is in which bin} +} +\references{ +Gray, J.S., A. Bjorgesaeter, and K. I. Ugland. 2006. On plotting species abundance distributions. \emph{Journal of Animal Ecology} \strong{75}:752--756. +} +\author{ +F. Guillaume Blanchet +} + +\examples{ + +data(mite) +SADmite<-SADbin(colSums(mite)) +barplot(SADmite$bin,names.arg=paste("Bin",1:length(SADmite$bin)),las=2) + +} +\keyword{ cluster } Modified: pkg/ordiconsensus/man/consensusRDA.Rd =================================================================== --- pkg/ordiconsensus/man/consensusRDA.Rd 2013-06-17 13:44:09 UTC (rev 2529) +++ pkg/ordiconsensus/man/consensusRDA.Rd 2013-06-18 13:56:29 UTC (rev 2530) @@ -100,8 +100,8 @@ ### Consensus RDA consRDA<-consensusRDA(ordiRes,ordiResTest,beetle,beetle.expl) summary(consRDA) +axisLabels<-c(paste("Axis 1 - ",round(consRDA$values[1]/sum(consRDA$values),4)*100,sep=""),paste("Axis 2 - ",round(consRDA$values[2]/sum(consRDA$values),4)*100,sep="")) -axisLabels<-c(paste("Axis 1 - ",round(consRDA$values[1]/sum(consRDA$values),4)*100,"%",sep=""),paste("Axis 2 - ",round(consRDA$values[2]/sum(consRDA$values),4)*100,"%",sep="")) plot(consRDA$siteConsensus[,1:2],pch=19,xlab=axisLabels[1],ylab=axisLabels[2],las=1) abline(h=0,v=0,lty=3) @@ -110,6 +110,7 @@ arrows(0,0,consRDA$descConsensus[,1]*0.4,consRDA$descConsensus[,2]*0.4,col="blue",length=0.1,angle=12) text(consRDA$descConsensus[,1:2]*0.4,labels=rownames(consRDA$descConsensus),col="blue") + } \keyword{ multivariate } Modified: pkg/ordiconsensus/man/ordiconsensus-package.Rd =================================================================== --- pkg/ordiconsensus/man/ordiconsensus-package.Rd 2013-06-17 13:44:09 UTC (rev 2529) +++ pkg/ordiconsensus/man/ordiconsensus-package.Rd 2013-06-18 13:56:29 UTC (rev 2530) @@ -12,7 +12,7 @@ \tabular{ll}{ Package: \tab ordiconsensus\cr Type: \tab Package\cr -Version: \tab 0.3-1\cr +Version: \tab 0.3-2\cr Date: \tab 2012-11-12\cr License: \tab Unlimited\cr } From noreply at r-forge.r-project.org Tue Jun 18 21:10:24 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 18 Jun 2013 21:10:24 +0200 (CEST) Subject: [Vegan-commits] r2531 - in pkg/ordiconsensus: . R man Message-ID: <20130618191025.2D828185488@r-forge.r-project.org> Author: gblanchet Date: 2013-06-18 21:10:23 +0200 (Tue, 18 Jun 2013) New Revision: 2531 Added: pkg/ordiconsensus/R/simulSADcomm.R pkg/ordiconsensus/man/simulSADcomm.Rd Modified: pkg/ordiconsensus/DESCRIPTION pkg/ordiconsensus/NAMESPACE pkg/ordiconsensus/man/ordiconsensus-package.Rd Log: Added function simulSADcomm to package ordiconsensus Modified: pkg/ordiconsensus/DESCRIPTION =================================================================== --- pkg/ordiconsensus/DESCRIPTION 2013-06-18 13:56:29 UTC (rev 2530) +++ pkg/ordiconsensus/DESCRIPTION 2013-06-18 19:10:23 UTC (rev 2531) @@ -1,7 +1,7 @@ Package: ordiconsensus Type: Package Title: Consensus of canonical ordinations through the canonical redundancy analysis -Version: 0.3-2 +Version: 0.4 Date: 2012-11-09 Author: F. Guillaume Blanchet Maintainer: F. Guillaume Blanchet Modified: pkg/ordiconsensus/NAMESPACE =================================================================== --- pkg/ordiconsensus/NAMESPACE 2013-06-18 13:56:29 UTC (rev 2530) +++ pkg/ordiconsensus/NAMESPACE 2013-06-18 19:10:23 UTC (rev 2531) @@ -1,6 +1,6 @@ ### Export -export(coeffCompare,consensusRDA,RV,SADbin) +export(coeffCompare,consensusRDA,RV,SADbin,simulSADcomm) ### Import Added: pkg/ordiconsensus/R/simulSADcomm.R =================================================================== --- pkg/ordiconsensus/R/simulSADcomm.R (rev 0) +++ pkg/ordiconsensus/R/simulSADcomm.R 2013-06-18 19:10:23 UTC (rev 2531) @@ -0,0 +1,162 @@ +simulSADcomm <- +function(sp.abund,expl.var,expl.rand.sel=TRUE,nexpl.comb=2,binary=FALSE,fix.expl=NULL,nsite=50,weight=NULL,range.weight=c(0,2),sd.expl=FALSE,norm=c(0,1)){ +### Description: +### +### Function that simulates data tables which have the same species +### abundance distribution. +### +### Arguments: +### +### sp.abund : A vector defining the number of species in a bin. +### See "Details" for more information. +### nsite : Numeric. Number of sites (rows) in the resulting matrix. See details. +### expl.var : Matrix. Explanatory variables related to the species. +### expl.rand.sel : Logical. Whether explanatory should be randomly selected to construct species or a fixed combination should be given. (Default is TRUE) +### nexpl.comb : Numeric. The number of explanatory variables that will be combined together to construct the environmental variables. Default is 2. +### binary : Logical. Whether the site-by-species matrix is an abundance (FALSE) or a presence/absence (TRUE). Default is FALSE +### fix.expl : Matrix. Defines which combination of explanatory variables should be used to construct species. This argument is only active when expl.rand.sel=FALSE. See Details for more information. +### weight : Vector. Regression coefficient used to give weight on each species. If NULL weights are random selected through a random samping of a uniform distribution with a range defined by range.weight. Default is NULL. +### range.weight : Vector of length 2 giving the minimum and the maximum of a uniform distribution. This will be used to weight each species use to construct an explanatory variable. Default is 0 and 2. +### sd.expl : Logical. Whether the standard deviation of the Normal error is a multiplier of the standard deviation of the deterministic portion of the newly created explanatory variable (TRUE) or the pure standard deviation (FALSE). Default is FALSE. +### norm : Vector of length 2 giving the mean and a multiplier of the standard deviation of the deterministic portion of a newly created explanatory variable. Default is mean 0 and 1 time the standard deviation of the new deterministic explanatory variable. +### +### Details : +### +### The argument "sp.abund" defines the species-abundance distribution structure of the data following the binnings proposed by Gray et al. (2006). For example, if the vector is (40,20,30), it means that there will be 40 species with 1 individual, 20 with 2 or 3 individuals, and 30 with 4 to 7 individuals. +### +### The individuals are assigned to the sites according to the the set of exlanatory variables given in expl.var. It is possible that a site occur with 0 individuals. They will be included in the analysis and dealt with a posteriori. +### +### The explanatory variables are randomly sampled (without replacement) when combining (adding) explanatory variables together. The number of explanatory variables must be a multiple of nexpl.comb. +### +### Error was included to a species by multiplying a weight to the explanatory variable used to construct the species and by adding a normally distributed error term to that same explanatory variable. An error term with a standard deviation equal to the standard deviation of the explanatory variable allows for the explanatory variable to explain roughly 50% of the species it constructed. +### +### fix.expl is a matrix that has as many rows as there are species and as many columns as nexpl.comb (number of explanatory variables to combine). The numbers in fix.expl are integers that refers to the columns of expl.var. When fix.expl is used, nexpl.comb becomes meaningless. +### +### If a presence-absence matrix is constructed (binary=TRUE), sp.abund should be constructed in such a way that no bin should include species with an abundance larger than the number of sites. If it is not the case, an error message is sent. Within, this constraint, if the maximum of the last bin (the one with the largest abundance) is larger than the number of site, it will be automatically changed to the number of sites-1. +### +### Value : +### +### site.sp : The site (rows) by species (column) generated. +### sel.expl : A vector presenting the order explanatory variables used to model which species. The order follows the order of the species. +### +### Reference : +### Gray, J. S., A. Bjorgeaeter, and K. I. Ugland. 2006. On plotting species abundance distributions, Journal of Animal Ecology. 75:752-756. +### +### +### F. Guillaume Blanchet - September 2010, July 2011 +################################################################################ + if(!is.vector(sp.abund)){ + stop("'sp.abund' is not a vector") + } + + is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol + + nexpl.var<-ncol(expl.var) + + if(expl.rand.sel){ + nexpl.var.new<-ncol(expl.var)/nexpl.comb + if(!is.wholenumber(nexpl.var.new)){ + stop("'expl.var' is not a multiple of 'nexp.comb'") + } + } + + if(nrow(expl.var)!=nsite){ + stop("'expl.var' should have the same number of row as 'nsite'") + } + + #CC# Find the minimum and the maximium number of individuals for each bin define in sp.abund + nbins<-length(sp.abund) + min.bin<-2^(0:(nbins-1)) + max.bin<-2^(1:nbins)-1 + + if(binary){ + if(max(min.bin) > nsite){ + stop("'sp.abund' has species with abundance too large") + } + max.bin[which.max(max.bin)]<-nsite-1 + + } + + #CC# Construct site by specie result matrix + nsp<-sum(sp.abund) + site.sp<-matrix(0,nsite,nsp) + + #CC# Construct matrix presenting the environmental variable selection + if(expl.rand.sel){ + expl.var.new<-matrix(NA,ncol=nexpl.var.new,nrow=nsite) + sel.expl<-sample(1:ncol(expl.var)) + + first<-seq(1,nexpl.var,by=nexpl.comb) + last<-seq(nexpl.comb,nexpl.var,by=nexpl.comb) + + for(i in 1:nexpl.var.new){ + expl.var.new[,i]<-rowSums(expl.var[,sel.expl[first[i]:last[i]]]) + } + + sel.expl.new<-sample(1:nexpl.var.new,nsp,replace=TRUE) + sd.expl.var.new<-apply(expl.var.new,2,sd) + }else{ + expl.var.new<-matrix(NA,ncol=nsp,nrow=nsite) + + for(i in 1:nsp){ + expl.var.new[,i]<-rowSums(expl.var[,fix.expl[i,]]) + sel.expl.new<-1:nsp + if(sd.expl){ + sd.expl.var.new<-apply(expl.var.new,2,sd) + }else{ + sd.expl.var.new<-rep(1,ncol(expl.var.new)) + } + } + } + + #CC# Fill up site by species matrix + sp<-1 + for(i in 1:nbins){ + if(sp.abund[i]>0){ + for(j in 1:sp.abund[i]){ + for(k in sample(min.bin[i]:max.bin[i],1)){ + #CC# Add a weight and an error term to the selected environmental variable + error<-rnorm(nsite,mean=norm[1],sd=sd.expl.var.new[sel.expl.new[sp]]*norm[2]) + if(is.null(weight)){ + weight.rnd<-runif(1,range.weight[1],range.weight[2]) + smpl.prob<-abs(expl.var.new[,sel.expl.new[sp]]*weight.rnd+error) + #CC# Consider the sign of the regression coefficient + if(weight.rnd>0){ + smpl.prob<-smpl.prob/sum(smpl.prob) + }else{ + smpl.prob<-(1/smpl.prob)/sum(1/smpl.prob) + } + }else{ + smpl.prob<-abs(expl.var.new[,sel.expl.new[sp]]*weight[sp]+error) + #CC# Consider the sign of the regression coefficient + if(weight[sp]>0){ + smpl.prob<-smpl.prob/sum(smpl.prob) + }else{ + smpl.prob<-(1/smpl.prob)/sum(1/smpl.prob) + } + } + #CC# Build presence/absence data + if(binary){ + smpl.site<-sample(nsite,k,replace=FALSE,prob=smpl.prob) + site.sp[smpl.site,sp]<-site.sp[smpl.site,sp]+1 + }else{ + smpl.site<-sample(nsite,k,replace=TRUE,prob=smpl.prob) + for(l in smpl.site){ + site.sp[l,sp]<-site.sp[l,sp]+1 + } + } + } + sp<-sp+1 + } + } + } + + if(expl.rand.sel){ + res<-list(site.sp,sel.expl) + names(res)<-c("site.sp","sel.expl") + }else{ + res<-list(site.sp,fix.expl) + names(res)<-c("site.sp","sel.expl") + } + return(res) +} Modified: pkg/ordiconsensus/man/ordiconsensus-package.Rd =================================================================== --- pkg/ordiconsensus/man/ordiconsensus-package.Rd 2013-06-18 13:56:29 UTC (rev 2530) +++ pkg/ordiconsensus/man/ordiconsensus-package.Rd 2013-06-18 19:10:23 UTC (rev 2531) @@ -12,7 +12,7 @@ \tabular{ll}{ Package: \tab ordiconsensus\cr Type: \tab Package\cr -Version: \tab 0.3-2\cr +Version: \tab 0.4\cr Date: \tab 2012-11-12\cr License: \tab Unlimited\cr } Added: pkg/ordiconsensus/man/simulSADcomm.Rd =================================================================== --- pkg/ordiconsensus/man/simulSADcomm.Rd (rev 0) +++ pkg/ordiconsensus/man/simulSADcomm.Rd 2013-06-18 19:10:23 UTC (rev 2531) @@ -0,0 +1,79 @@ +\name{simulSADcomm} +\alias{simulSADcomm} +\title{ +Simulate community matrix with constant SAD +} +\description{ +This function simulates community matrices with the same species abundance distribution following patterns defined by a set of explanatory variables. This function was used to simulate community matrices in Blanchet et al. (In press)} +\usage{ +simulSADcomm(sp.abund, expl.var, expl.rand.sel = TRUE, nexpl.comb = 2, binary = FALSE, fix.expl = NULL, nsite = 50, weight = NULL, range.weight = c(0, 2), sd.expl = FALSE, norm = c(0, 1)) +} +\arguments{ + \item{sp.abund}{ +A vector defining the number of species in a bin. See Details for more information. +} + \item{expl.var}{ +A matrix of explanatory variables to use to construct the species. +} + \item{expl.rand.sel}{ +Logical. Whether explanatory should be randomly selected to construct species (TRUE) or a fixed combination should be given (FALSE). (Default is TRUE) +} + \item{nexpl.comb}{ +Numeric. The number of explanatory variables that will be combined together to construct the environmental variables. Default is 2. +} + \item{binary}{ +Logical. Whether the site-by-species matrix is an abundance (FALSE) or a presence/absence (TRUE). Default is FALSE. +} + \item{fix.expl}{ +A matrix that defines which combination of explanatory variables should be used to construct species. This argument is only active when expl.rand.sel=FALSE. See Details for more information. +} + \item{nsite}{ +Numeric. Number of sites (rows) in the resulting community matrix. See Details. +} + \item{weight}{ +A vector of regression coefficient used to give weight on each species. If NULL, weights are random selected through a random samping of a uniform distribution with a range defined by range.weight. Default is NULL. +} + \item{range.weight}{ +A vector of length 2 giving the minimum and the maximum of a uniform distribution from which \code{weights} will be sampled. This will be used to weight each species use to construct an explanatory variable. Default is 0 and 2. +} + \item{sd.expl}{ +Logical. This argument is only active when \code{expl.rand.sel} is FALSE (That is when a fixed combination of explanatory variable is used to construct a community matrix). Whether the standard deviation of the Normal error added when constructing a species is a multiplier of the standard deviation of the deterministic portion of the newly created explanatory variable (TRUE) or the pure standard deviation (FALSE). Default is FALSE. +} + \item{norm}{ +Vector of length 2 giving the mean and a multiplier of the standard deviation of the deterministic portion of a newly created explanatory variable. Default is mean = 0 and multiplier of the standard deviation of the new deterministic explanatory variable = 1. +} +} +\details{ +The argument \code{sp.abund} defines the species-abundance distribution structure of the data following the binnings proposed by Gray et al. (2006). For example, if the vector is (40,20,30), it means that there will be 40 species with 1 individual, 20 with 2 or 3 individuals, and 30 with 4 to 7 individuals. + +The individuals are assigned to the sites according to the the set of exlanatory variables given in \code{expl.var}. It is possible that a site occur with 0 individuals. They will be included in the community matrix and should be dealt with \emph{a posteriori}. + +When \code{expl.rand.sel} is TRUE, the explanatory variables are randomly sampled (without replacement) when combining (adding) explanatory variables together. The number of explanatory variables must be a multiple of nexpl.comb. + +Error is included to a species by multiplying a weight to the explanatory variable used to construct the species and by adding a normally distributed error term to the same explanatory variable. An error term with a standard deviation equal to the standard deviation of the explanatory variable allows for the explanatory variable to explain roughly 50% of the species it constructed. + +\code{fix.expl} is a matrix that has as many rows as there are species and as many columns as \code{nexpl.comb} (number of explanatory variables to combine). The numbers in \code{fix.expl} are integers that refers to the columns of \code{expl.var}. When \code{fix.expl} is used, \code{nexpl.comb} becomes meaningless. + +If a presence-absence matrix is constructed (\code{binary}=TRUE), \code{sp.abund} should be constructed in such a way that no bin should include species with an abundance larger than the number of sites. If it is not the case, an error message will be sent. Within, this constraint, if the maximum of the last bin (the one with the largest abundance) is larger than the number of site, it will be automatically changed to the number of sites-1. + +This function was designed to do much more than the simulations generated in the work of Blanchet et al. (in press). It is meant to be used for future simulation studies. +} +\value{ +\code{site.sp} : The site (rows) by species (column) community matrix generated. +\code{sel.expl} : A vector presenting the order explanatory variables used to construct each species. The order follows the order of the species. +} +\references{ +Gray, J.S., A. Bjorgeaeter, and K.I. Ugland. 2006. On plotting species abundance distributions, \emph{Journal of Animal Ecology} \strong{75}:752--756. + +Blanchet, F.G., P. Legendre, J.A.C. Bergeron, F. He. In press. Consensus RDA across dissimilarity coefficients for canonical ordination of community composition data, \emph{Ecological Monographs}. +} +\author{ +F. Guillaume Blanchet +} + +\examples{ +SAD<-c(1,2,4,6,4,2,1,0,0,0) +expl<-matrix(rnorm(400),ncol=8) +simulSADcomm(SAD,expl) +} +\keyword{ datagen } From noreply at r-forge.r-project.org Thu Jun 20 21:16:49 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 20 Jun 2013 21:16:49 +0200 (CEST) Subject: [Vegan-commits] r2532 - pkg/vegan/R Message-ID: <20130620191649.5D0E1185937@r-forge.r-project.org> Author: gsimpson Date: 2013-06-20 21:16:48 +0200 (Thu, 20 Jun 2013) New Revision: 2532 Modified: pkg/vegan/R/ordilabel.R Log: cleanup Modified: pkg/vegan/R/ordilabel.R =================================================================== --- pkg/vegan/R/ordilabel.R 2013-06-18 19:10:23 UTC (rev 2531) +++ pkg/vegan/R/ordilabel.R 2013-06-20 19:16:48 UTC (rev 2532) @@ -29,10 +29,6 @@ else col <- par("fg") for (i in 1:nrow(x)) { - ## polygon(x[i,1] + c(-1,1,1,-1)*w[i], x[i,2] + c(-1,-1,1,1)*h[i], - ## col = fill, border = border, xpd = xpd) - ## text(x[i,1], x[i,2], labels = labels[i], cex = cex, col = col, - ## xpd = xpd, ...) ordiArgAbsorber(x[i,1] + c(-1,1,1,-1)*w[i], x[i,2] + c(-1,-1,1,1)*h[i], col = fill, border = border, xpd = xpd, FUN = polygon, ...) From noreply at r-forge.r-project.org Fri Jun 21 06:02:12 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 21 Jun 2013 06:02:12 +0200 (CEST) Subject: [Vegan-commits] r2533 - in pkg/vegan: R inst man Message-ID: <20130621040212.4478C185165@r-forge.r-project.org> Author: gsimpson Date: 2013-06-21 06:02:11 +0200 (Fri, 21 Jun 2013) New Revision: 2533 Modified: pkg/vegan/R/ordipointlabel.R pkg/vegan/inst/ChangeLog pkg/vegan/man/ordipointlabel.Rd Log: ordipointlabel now uses ordiArgAbsorber to stop warnings about non-graphical parameters Modified: pkg/vegan/R/ordipointlabel.R =================================================================== --- pkg/vegan/R/ordipointlabel.R 2013-06-20 19:16:48 UTC (rev 2532) +++ pkg/vegan/R/ordipointlabel.R 2013-06-21 04:02:11 UTC (rev 2533) @@ -88,9 +88,13 @@ sol <- optim(par = pos, fn = fn, gr = gr, method="SANN", control=list(maxit=nit)) if (!add) - points(xy, pch = pch, col = col, cex=cex, ...) + ##points(xy, pch = pch, col = col, cex=cex, ...) + ordiArgAbsorber(xy, pch = pch, col = col, cex = cex, FUN = points, + ...) lab <- xy + makeoff(sol$par, box) - text(lab, labels=labels, col = col, cex = cex, font = font, ...) + ##text(lab, labels=labels, col = col, cex = cex, font = font, ...) + ordiArgAbsorber(lab, labels=labels, col = col, cex = cex, font = font, + FUN = text, ...) pl <- list(points = xy) pl$labels <- lab attr(pl$labels, "font") <- font Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-06-20 19:16:48 UTC (rev 2532) +++ pkg/vegan/inst/ChangeLog 2013-06-21 04:02:11 UTC (rev 2533) @@ -17,6 +17,9 @@ permutations and other features of the design are set via `control` and function `how()` from permute. + * ordipointlabel: now uses `ordiArgAbsorber()` to stop the warnings + about non-graphical paramters being passed to plotting functions. + Version 2.1-30 (opened May 5, 2013) * bioenv: can now use Mahalanobis, Manhattan and Gower distances Modified: pkg/vegan/man/ordipointlabel.Rd =================================================================== --- pkg/vegan/man/ordipointlabel.Rd 2013-06-20 19:16:48 UTC (rev 2532) +++ pkg/vegan/man/ordipointlabel.Rd 2013-06-21 04:02:11 UTC (rev 2533) @@ -75,6 +75,14 @@ data(dune) ord <- cca(dune) ordipointlabel(ord) + +## set scaling - should be no warnings! +ordipointlabel(ord, scaling = 1) + +## plot then add +plot(ord, scaling = 3, type = "n") +ordipointlabel(ord, display = "species", scaling = 3, add = TRUE) +ordipointlabel(ord, display = "sites", scaling = 3, add = TRUE) } \keyword{ hplot } \keyword{ aplot } From noreply at r-forge.r-project.org Fri Jun 21 06:20:10 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 21 Jun 2013 06:20:10 +0200 (CEST) Subject: [Vegan-commits] r2534 - in pkg/vegan: R inst man Message-ID: <20130621042010.E0AC91855D8@r-forge.r-project.org> Author: gsimpson Date: 2013-06-21 06:20:10 +0200 (Fri, 21 Jun 2013) New Revision: 2534 Modified: pkg/vegan/R/ordisurf.R pkg/vegan/R/plot.ordisurf.R pkg/vegan/inst/ChangeLog pkg/vegan/man/ordisurf.Rd Log: all setting lwd for contours Modified: pkg/vegan/R/ordisurf.R =================================================================== --- pkg/vegan/R/ordisurf.R 2013-06-21 04:02:11 UTC (rev 2533) +++ pkg/vegan/R/ordisurf.R 2013-06-21 04:20:10 UTC (rev 2534) @@ -21,7 +21,7 @@ fx = FALSE, add = FALSE, display = "sites", w = weights(x), main, nlevels = 10, levels, npoints = 31, labcex = 0.6, bubble = FALSE, cex = 1, select = TRUE, method = "REML", - gamma = 1, plot = TRUE, ...) + gamma = 1, plot = TRUE, lwd.cl = par("lwd"), ...) { weights.default <- function(object, ...) NULL if(!missing(thinplate)) { @@ -156,7 +156,8 @@ (select && !isTRUE(all.equal(as.numeric(summary(mod)$edf), 0)))) contour(xn1, xn2, matrix(fit, nrow=GRID), col = col, add = TRUE, levels = levels, labcex = labcex, - drawlabels = !is.null(labcex) && labcex > 0) + drawlabels = !is.null(labcex) && labcex > 0, + lwd = lwd.cl) } mod$grid <- list(x = xn1, y = xn2, z = matrix(fit, nrow = GRID)) class(mod) <- c("ordisurf", class(mod)) Modified: pkg/vegan/R/plot.ordisurf.R =================================================================== --- pkg/vegan/R/plot.ordisurf.R 2013-06-21 04:02:11 UTC (rev 2533) +++ pkg/vegan/R/plot.ordisurf.R 2013-06-21 04:20:10 UTC (rev 2534) @@ -1,6 +1,7 @@ `plot.ordisurf` <- function(x, what = c("contour","persp","gam"), add = FALSE, bubble = FALSE, col = "red", cex = 1, - nlevels = 10, levels, labcex = 0.6, ...) { + nlevels = 10, levels, labcex = 0.6, + lwd.cl = par("lwd"), ...) { what <- match.arg(what) y <- x$model$y x1 <- x$model$x1 @@ -23,7 +24,8 @@ levels <- pretty(range(x$grid$z, finite = TRUE), nlevels) contour(X, Y, Z, col = col, add = TRUE, levels = levels, labcex = labcex, - drawlabels = !is.null(labcex) && labcex > 0) + drawlabels = !is.null(labcex) && labcex > 0, + lwd = lwd.cl) } else if(isTRUE(all.equal(what, "persp"))) { persp(X, Y, Z, col = col, cex = cex, ...) } else { Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-06-21 04:02:11 UTC (rev 2533) +++ pkg/vegan/inst/ChangeLog 2013-06-21 04:20:10 UTC (rev 2534) @@ -20,6 +20,9 @@ * ordipointlabel: now uses `ordiArgAbsorber()` to stop the warnings about non-graphical paramters being passed to plotting functions. + * ordisurf: can now pass in a line width for the contours via + argument `lwd.cl`. + Version 2.1-30 (opened May 5, 2013) * bioenv: can now use Mahalanobis, Manhattan and Gower distances Modified: pkg/vegan/man/ordisurf.Rd =================================================================== --- pkg/vegan/man/ordisurf.Rd 2013-06-21 04:02:11 UTC (rev 2533) +++ pkg/vegan/man/ordisurf.Rd 2013-06-21 04:20:10 UTC (rev 2534) @@ -17,7 +17,7 @@ display = "sites", w = weights(x), main, nlevels = 10, levels, npoints = 31, labcex = 0.6, bubble = FALSE, cex = 1, select = TRUE, method = "REML", gamma = 1, - plot = TRUE, ...) + plot = TRUE, lwd.cl = par("lwd"), ...) \method{ordisurf}{formula}(formula, data, ...) @@ -25,7 +25,7 @@ \method{plot}{ordisurf}(x, what = c("contour","persp","gam"), add = FALSE, bubble = FALSE, col = "red", cex = 1, - nlevels = 10, levels, labcex = 0.6, \dots) + nlevels = 10, levels, labcex = 0.6, lwd.cl = par("lwd"), \dots) } \arguments{ @@ -108,6 +108,8 @@ \item{plot}{logical; should any plotting be done by \code{ordisurf}? Useful if all you want is the fitted response surface model.} + \item{lwd.cl}{numeric; the \code{lwd} (line width) parameter to use + when drawing the contour lines.} \item{formula, data}{Alternative definition of the fitted model as \code{x ~ y}, where left-hand side is the ordination \code{x} and right-hand side the single fitted continuous variable From noreply at r-forge.r-project.org Sat Jun 22 14:51:57 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 22 Jun 2013 14:51:57 +0200 (CEST) Subject: [Vegan-commits] r2535 - in pkg/vegan: R inst man Message-ID: <20130622125157.71DE31858D4@r-forge.r-project.org> Author: jarioksa Date: 2013-06-22 14:51:56 +0200 (Sat, 22 Jun 2013) New Revision: 2535 Added: pkg/vegan/R/ordiArrowTextXY.R Modified: pkg/vegan/R/plot.cca.R pkg/vegan/R/plot.envfit.R pkg/vegan/R/text.cca.R pkg/vegan/inst/ChangeLog pkg/vegan/man/vegan-internal.Rd Log: improve position of labels to biplot arrows: add internal ordiArrowTextXY Added: pkg/vegan/R/ordiArrowTextXY.R =================================================================== --- pkg/vegan/R/ordiArrowTextXY.R (rev 0) +++ pkg/vegan/R/ordiArrowTextXY.R 2013-06-22 12:51:56 UTC (rev 2535) @@ -0,0 +1,27 @@ +### Location of the text at the point of the arrow. 'vect' are the +### coordinates of the arrow heads, and 'labels' are the text used to +### label these heads, '...' passes arguments (such as 'cex') to +### strwidth() and strheight(). +`ordiArrowTextXY` <- + function (vect, labels, ...) +{ + w <- strwidth(labels, ...) + h <- strheight(labels, ...) + ## slope of arrows + b <- vect[,2]/vect[,1] + ## offset based on string dimensions + off <- cbind(sign(vect[,1]) * (w/2 + h/4), 0.75 * h * sign(vect[,2])) + ## move the centre of the string to the continuation of the arrow + for(i in 1:nrow(vect)) { + move <- off[i,2] / b[i] + ## arrow points to the top/bottom of the text box + if (is.finite(move) && abs(move) <= abs(off[i, 1])) + off[i, 1] <- move + else { + ## arrow points to a side of the text box + move <- b[i] * off[i,1] + off[i, 2] <- move + } + } + off + vect +} Modified: pkg/vegan/R/plot.cca.R =================================================================== --- pkg/vegan/R/plot.cca.R 2013-06-21 04:20:10 UTC (rev 2534) +++ pkg/vegan/R/plot.cca.R 2013-06-22 12:51:56 UTC (rev 2535) @@ -93,7 +93,8 @@ attr(g$biplot, "arrow.mul") <- mul arrows(0, 0, mul * g$biplot[, 1], mul * g$biplot[, 2], length = 0.05, col = "blue") - text(1.1 * mul * g$biplot, rownames(g$biplot), col = "blue") + biplabs <- ordiArrowTextXY(mul * g$biplot, rownames(g$biplot)) + text(biplabs, rownames(g$biplot), col = "blue") axis(3, at = c(-mul, 0, mul), labels = rep("", 3), col = "blue") axis(4, at = c(-mul, 0, mul), labels = c(-1, 0, 1), col = "blue") } Modified: pkg/vegan/R/plot.envfit.R =================================================================== --- pkg/vegan/R/plot.envfit.R 2013-06-21 04:20:10 UTC (rev 2534) +++ pkg/vegan/R/plot.envfit.R 2013-06-22 12:51:56 UTC (rev 2535) @@ -59,7 +59,8 @@ ax <- -c(-1, 0, 1) * arrow.mul * maxarr } vect <- arrow.mul * vect - vtext <- sweep(1.1 * vect, 2, at, "+") + vtext <- ordiArrowTextXY(vect, labs$v, ...) + vtext <- sweep(vtext, 2, at, "+") vect <- sweep(vect, 2, at, "+") } if (!add) { Modified: pkg/vegan/R/text.cca.R =================================================================== --- pkg/vegan/R/text.cca.R 2013-06-21 04:20:10 UTC (rev 2534) +++ pkg/vegan/R/text.cca.R 2013-06-22 12:51:56 UTC (rev 2535) @@ -29,7 +29,7 @@ pts <- pts * arrow.mul arrows(0, 0, pts[, 1], pts[, 2], length = head.arrow, ...) - pts <- pts * 1.1 + pts <- ordiArrowTextXY(pts, rownames(pts), ...) if (axis.bp) { axis(side = 3, at = c(-arrow.mul, 0, arrow.mul), labels = rep("", 3)) Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-06-21 04:20:10 UTC (rev 2534) +++ pkg/vegan/inst/ChangeLog 2013-06-22 12:51:56 UTC (rev 2535) @@ -23,6 +23,15 @@ * ordisurf: can now pass in a line width for the contours via argument `lwd.cl`. + * ordiArrowTextXY: New (internal) support function that finds + coordinates of text box at the point of the arrow so that the + arrow point just touches the text. This should improve + positioning of the arrow labels and avoid writing labels over the + arrows. + + * plot.envfit, plot.cca, text.cca: use ordiArrowTextXY() for arrow + labels instead of expanding arrow heads by 10%. + Version 2.1-30 (opened May 5, 2013) * bioenv: can now use Mahalanobis, Manhattan and Gower distances Modified: pkg/vegan/man/vegan-internal.Rd =================================================================== --- pkg/vegan/man/vegan-internal.Rd 2013-06-21 04:20:10 UTC (rev 2534) +++ pkg/vegan/man/vegan-internal.Rd 2013-06-22 12:51:56 UTC (rev 2535) @@ -8,6 +8,7 @@ \alias{ordiTerminfo} \alias{pasteCall} \alias{ordiArrowMul} +\alias{oridArrowTextXY} \alias{ordiArgAbsorber} \alias{veganCovEllipse} \alias{hierParseFormula} @@ -27,6 +28,7 @@ ordiNAexclude(x, excluded) ordiNApredict(omit, x) ordiArrowMul(x, at = c(0,0), fill = 0.75) +ordiArrowTextXY(vect, labels, ...) ordiArgAbsorber(..., shrink, origin, scaling, triangular, display, choices, const, FUN) centroids.cca(x, mf, wt) @@ -64,6 +66,11 @@ \code{ordiNApredict} puts pads the result object with these or with WA scores similarly as \code{\link{napredict}}. + \code{ordiArrowMul} finds a multiplier to scale a bunch of arrows to + fill an ordination plot, and \code{ordiArrowTextXY} finds the + coordinates for labels of these arrows. See \code{\link{envfit}} + for an application. + \code{ordiArgAbsorber} absorbs arguments of \code{\link{scores}} function of \pkg{vegan} so that these do not cause superfluous warnings in graphical function \code{FUN}. If you implement From noreply at r-forge.r-project.org Wed Jun 26 08:57:12 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 26 Jun 2013 08:57:12 +0200 (CEST) Subject: [Vegan-commits] r2536 - in pkg/vegan: R inst Message-ID: <20130626065712.B06E8184985@r-forge.r-project.org> Author: jarioksa Date: 2013-06-26 08:57:12 +0200 (Wed, 26 Jun 2013) New Revision: 2536 Modified: pkg/vegan/R/plot.envfit.R pkg/vegan/inst/ChangeLog Log: fix string positioning and xlim,ylim scaling in plot.envfit(..., add = TRUE) Modified: pkg/vegan/R/plot.envfit.R =================================================================== --- pkg/vegan/R/plot.envfit.R 2013-06-22 12:51:56 UTC (rev 2535) +++ pkg/vegan/R/plot.envfit.R 2013-06-26 06:57:12 UTC (rev 2536) @@ -59,52 +59,67 @@ ax <- -c(-1, 0, 1) * arrow.mul * maxarr } vect <- arrow.mul * vect - vtext <- ordiArrowTextXY(vect, labs$v, ...) - vtext <- sweep(vtext, 2, at, "+") vect <- sweep(vect, 2, at, "+") + if (add) { + vtext <- ordiArrowTextXY(vect, labs$v, ...) + vtext <- sweep(vtext, 2, at, "+") + } } if (!add) { - plot.new() ## needed for string widths and heights - if(!is.null(vect)) { - ## compute axis limits allowing space for labels - sw <- strwidth(labs$v, ...) + plot.new() + ## needed for string widths and heights We need dimensions to + ## fit completely the names of vectors and factors with no + ## clipping at axes. If there are (1) factors and vectors, we + ## need to adjust arrow lengths, if there are (2) only factors + ## or only vectors, we can use their scores directly. After + ## finding the scores, we must expand the scores by string + ## widths and heights. The expansion can be only estimated + ## after setting plot.window with its xlim and ylim, but we + ## need to find xlim and ylim to set the plot.window... + + if(is.null(vect) || is.null(x$factors)) { + ## Only factors or vectors: set preliminary plot.window + xstack <- rbind(vect, x$factors$centroids) + plot.window(xlim = range(xstack[,1], at[1]), + ylim = range(xstack[,2], at[2]), + asp = 1, ...) + } else { + ## Both vectors and factors: set preliminary plot.window + ## from factors only and and find arrow.mul (which is + ## otherwise ## arrow.mul = 1) + plot.window(xlim = range(x$factors$centroids[,1], at[1]), + ylim = range(x$factors$centroids[,2], at[2]), + asp = 1, ...) + vfill <- 0.75 + arrow.mul <- ordiArrowMul(vect, at = at, fill = 1) + vect <- arrow.mul * vect + } + ## Get string dimensions (width/2, height) + sw <- strwidth(c(labs$v, labs$f), ...) / 2 + sh <- strheight(c(labs$v, labs$f), ...) + ## Reset limits + xstack <- rbind(x$factors$centroids, vect) + xlim <- range(xstack[,1] + sw, xstack[,2] - sw) + ylim <- range(xstack[,2] + sh, xstack[,2] - sh) + plot.window(xlim = xlim, ylim = ylim, asp = 1, ...) + ## Re-evaluate arrow.mul, set its text and re-evaluate limits again + if (!is.null(vect)) { + arrow.mul <- ordiArrowMul(vect, at = at, fill = 1) + vect <- arrow.mul * vect + vtext <- ordiArrowTextXY(vect, labs$v, ...) + sw <- strwidth(labs$v, ...) / 2 sh <- strheight(labs$v, ...) - xlim <- range(at[1], vtext[,1] + sw, vtext[,1] - sw) - ylim <- range(at[2], vtext[,2] + sh, vtext[,2] - sh) - if(!is.null(x$factors)) { - ## if factors, also need to consider them - sw <- strwidth(labs$f, ...) - sh <- strheight(labs$f, ...) - xlim <- range(xlim, x$factors$centroids[, choices[1]] + sw, - x$factors$centroids[, choices[1]] - sw) - ylim <- range(ylim, x$factors$centroids[, choices[2]] + sh, - x$factors$centroids[, choices[2]] - sh) - } - ## these plotting calls will prob. generate warnings - ## because of passing ... everywhere. localFoo needed? + xlim <- range(xlim, vtext[,1] + sw, vtext[,1] - sw) + ylim <- range(xlim, vtext[,2] + sh, vtext[,2] - sh) plot.window(xlim = xlim, ylim = ylim, asp = 1, ...) - axis(side = 1, ...) - axis(side = 2, ...) - box(...) - alabs <- colnames(vect) - title(..., ylab = alabs[2], xlab = alabs[1]) - } else if (!is.null(x$factors)) { - sw <- strwidth(labs$f, ...) - sh <- strheight(labs$f, ...) - xlim <- range(at[1], x$factors$centroids[, choices[1]] + sw, - x$factors$centroids[, choices[1]] - sw) - ylim <- range(at[2], x$factors$centroids[, choices[2]] + sh, - x$factors$centroids[, choices[2]] - sh) - ## these plotting calls will prob. generate warnings - ## because of passing ... everywhere. localFoo needed? - plot.window(xlim = xlim, ylim = ylim, asp = 1, ...) - axis(side = 1, ...) - axis(side = 2, ...) - box(...) - alabs <- colnames(x$factors$centroids[, choices, drop = FALSE]) - title(..., ylab = alabs[2], xlab = alabs[1]) - } else stop("Nothing to plot") + } + axis(side = 1, ...) + axis(side = 2, ...) + box(...) + alabs <- colnames(vect) + title(..., ylab = alabs[2], xlab = alabs[1]) } + if (!is.null(vect)) { arrows(at[1], at[2], vect[, 1], vect[, 2], len = 0.05, col = col) Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-06-22 12:51:56 UTC (rev 2535) +++ pkg/vegan/inst/ChangeLog 2013-06-26 06:57:12 UTC (rev 2536) @@ -32,6 +32,13 @@ * plot.envfit, plot.cca, text.cca: use ordiArrowTextXY() for arrow labels instead of expanding arrow heads by 10%. + * plot.envfit: plot(..., add = FALSE) estimated string (text) + dimensions after plot.new() but before plot.window(). Since + plot.new() sets xlim, ylim to c(0,1) and then plot.window resets + the limits to the data values, string dimensions in user units + were poorly estimated. This became evident with new positioning of + arrow text based on string dimensions. + Version 2.1-30 (opened May 5, 2013) * bioenv: can now use Mahalanobis, Manhattan and Gower distances From noreply at r-forge.r-project.org Thu Jun 27 00:58:58 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 27 Jun 2013 00:58:58 +0200 (CEST) Subject: [Vegan-commits] r2537 - in pkg/vegan: . inst man Message-ID: <20130626225858.A8FB3185979@r-forge.r-project.org> Author: gsimpson Date: 2013-06-27 00:58:58 +0200 (Thu, 27 Jun 2013) New Revision: 2537 Modified: pkg/vegan/NAMESPACE pkg/vegan/inst/ChangeLog pkg/vegan/man/ordipointlabel.Rd Log: add plot method for ordipointlabel that doesn't fiddle with par() Modified: pkg/vegan/NAMESPACE =================================================================== --- pkg/vegan/NAMESPACE 2013-06-26 06:57:12 UTC (rev 2536) +++ pkg/vegan/NAMESPACE 2013-06-26 22:58:58 UTC (rev 2537) @@ -258,6 +258,7 @@ S3method(plot, nestednodf) S3method(plot, nestedtemp) S3method(plot, ordisurf) +S3method(plot, ordipointlabel) S3method(plot, orditkplot) S3method(plot, permat) S3method(plot, poolaccum) Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-06-26 06:57:12 UTC (rev 2536) +++ pkg/vegan/inst/ChangeLog 2013-06-26 22:58:58 UTC (rev 2537) @@ -27,7 +27,7 @@ coordinates of text box at the point of the arrow so that the arrow point just touches the text. This should improve positioning of the arrow labels and avoid writing labels over the - arrows. + arrows. * plot.envfit, plot.cca, text.cca: use ordiArrowTextXY() for arrow labels instead of expanding arrow heads by 10%. @@ -39,6 +39,11 @@ were poorly estimated. This became evident with new positioning of arrow text based on string dimensions. + * plot.ordipointlabel: gains a plot method that is very similar to + `plot.orditkplot()` but which does not mess with graphical + parameters. This allows it to fit more naturally into a standard + R workflow (it plays nicely with `layout()` for example. + Version 2.1-30 (opened May 5, 2013) * bioenv: can now use Mahalanobis, Manhattan and Gower distances Modified: pkg/vegan/man/ordipointlabel.Rd =================================================================== --- pkg/vegan/man/ordipointlabel.Rd 2013-06-26 06:57:12 UTC (rev 2536) +++ pkg/vegan/man/ordipointlabel.Rd 2013-06-26 22:58:58 UTC (rev 2537) @@ -1,5 +1,6 @@ \name{ordipointlabel} \alias{ordipointlabel} +\alias{plot.ordipointlabel} \title{ Ordination Plots with Points and Optimized Locations for Text } \description{ @@ -13,10 +14,14 @@ ordipointlabel(x, display = c("sites", "species"), choices = c(1, 2), col = c(1, 2), pch = c("o", "+"), font = c(1, 1), cex = c(0.8, 0.8), add = FALSE, select, ...) + +\method{plot}{ordipointlabel}(x, ...) } \arguments{ - \item{x}{A result object from ordination. } + \item{x}{For \code{ordipointlabel()} a result object from an + ordination function. For \code{plot.ordipointlabel} an object + resulting from a call to \code{ordipointlabel()}.} \item{display}{Scores displayed in the plot. } \item{choices}{Axes shown. } \item{col, pch, font, cex}{Colours, point types, font style and @@ -56,9 +61,14 @@ label. In addition, it returns the result of \code{\link{optim}} as an attribute \code{"optim"}. The unit of overlap is the area of character \code{"m"}, and with variable \code{cex} it is the - smallest alternative. The result object inherits from - \code{\link{orditkplot}} result, and can be replotted with its - \code{plot} command. It may be possible to further edit the result + smallest alternative. + + There is a \code{plot} method based on \code{orditkplot} but which + does not alter nor reset the graphical parameters via \code{par}. + + The result object from \code{ordipointlabel} inherits from + \code{\link{orditkplot}}, and can also be replotted with its + \code{plot} method. It may be possible to further edit the result object with \code{\link{orditkplot}}, but for good results it is necessary that the points span the whole horizontal axis without empty margins. @@ -74,7 +84,7 @@ \examples{ data(dune) ord <- cca(dune) -ordipointlabel(ord) +plt <- ordipointlabel(ord) ## set scaling - should be no warnings! ordipointlabel(ord, scaling = 1) @@ -83,6 +93,9 @@ plot(ord, scaling = 3, type = "n") ordipointlabel(ord, display = "species", scaling = 3, add = TRUE) ordipointlabel(ord, display = "sites", scaling = 3, add = TRUE) + +## redraw plot without rerunning SANN optimisation +plot(plt) } \keyword{ hplot } \keyword{ aplot } From noreply at r-forge.r-project.org Thu Jun 27 11:15:01 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 27 Jun 2013 11:15:01 +0200 (CEST) Subject: [Vegan-commits] r2538 - in pkg/vegan: R inst Message-ID: <20130627091501.1529C185638@r-forge.r-project.org> Author: jarioksa Date: 2013-06-27 11:15:00 +0200 (Thu, 27 Jun 2013) New Revision: 2538 Modified: pkg/vegan/R/stressplot.R pkg/vegan/inst/ChangeLog Log: stressplot use expression(R^2) instead of R2 Modified: pkg/vegan/R/stressplot.R =================================================================== --- pkg/vegan/R/stressplot.R 2013-06-26 22:58:58 UTC (rev 2537) +++ pkg/vegan/R/stressplot.R 2013-06-27 09:15:00 UTC (rev 2538) @@ -61,9 +61,12 @@ ## Stress as R2 rstress <- 1 - object$stress^2 ralscal <- if(object$iregn == 3) ralscal/2 else ralscal/object$ngrp - lab <- paste("Non-metric fit, R2 =", format(rstress, digits=3), - "\nLinear fit, R2 =", format(ralscal, digits=3)) - text(min(x), 0.95*max(y), lab, pos=4) + Rst <- format(rstress, digits = 3) + Ral <- format(ralscal, digits = 3) + lab1 <- bquote("Non-metric fit, " * R^2 == .(Rst)) + lab2 <- bquote("Linear fit, " * R^2 == .(Ral)) + text(min(x), 0.95*max(y), lab1, pos=4) + text(min(x), 0.95*max(y) - strheight(lab1), lab2, pos=4) invisible(list("x" = x, "y" = y, "yf" = yf)) } @@ -94,8 +97,11 @@ plot(shep, pch = pch, col = p.col, xlab = "Observed Dissimilarity", ylab = "Ordination Distance", ...) lines(shep$x, shep$yf, type = "S", col = l.col, lwd = lwd, ...) - lab <- paste("Non-metric fit, R2 =", format(rstress, digits=3), - "\nLinear fit, R2 =", format(ralscal, digits=3)) - text(min(shep$x), 0.95*max(shep$y), lab, pos=4) + Rst <- format(rstress, digits = 3) + Ral <- format(ralscal, digits = 3) + lab1 <- bquote("Non-metric fit, " * R^2 == .(Rst)) + lab2 <- bquote("Linear fit, " * R^2 == .(Ral)) + text(min(shep$x), 0.95*max(shep$y), lab1, pos=4) + text(min(shep$x), 0.95*max(shep$y) - strheight(lab1), lab2, pos=4) invisible(shep) } Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-06-26 22:58:58 UTC (rev 2537) +++ pkg/vegan/inst/ChangeLog 2013-06-27 09:15:00 UTC (rev 2538) @@ -44,6 +44,9 @@ parameters. This allows it to fit more naturally into a standard R workflow (it plays nicely with `layout()` for example. + * stressplot: metaMDS and monoMDS stressplot() use now + expression(R^2) instead of ascii R2. + Version 2.1-30 (opened May 5, 2013) * bioenv: can now use Mahalanobis, Manhattan and Gower distances From noreply at r-forge.r-project.org Sat Jun 29 09:51:32 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 29 Jun 2013 09:51:32 +0200 (CEST) Subject: [Vegan-commits] r2539 - in pkg/vegan: R inst Message-ID: <20130629075132.3C7461856B7@r-forge.r-project.org> Author: jarioksa Date: 2013-06-29 09:51:31 +0200 (Sat, 29 Jun 2013) New Revision: 2539 Modified: pkg/vegan/R/stressplot.R pkg/vegan/inst/ChangeLog Log: return plotting structures in input order from stressplot.monoMDS Modified: pkg/vegan/R/stressplot.R =================================================================== --- pkg/vegan/R/stressplot.R 2013-06-27 09:15:00 UTC (rev 2538) +++ pkg/vegan/R/stressplot.R 2013-06-29 07:51:31 UTC (rev 2539) @@ -67,7 +67,9 @@ lab2 <- bquote("Linear fit, " * R^2 == .(Ral)) text(min(x), 0.95*max(y), lab1, pos=4) text(min(x), 0.95*max(y) - strheight(lab1), lab2, pos=4) - invisible(list("x" = x, "y" = y, "yf" = yf)) + ## we want to have invisible return lists in the input order + o <- order(object$jidx, object$iidx) + invisible(list("x" = x[o], "y" = y[o], "yf" = yf[o])) } `stressplot.default` <- Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-06-27 09:15:00 UTC (rev 2538) +++ pkg/vegan/inst/ChangeLog 2013-06-29 07:51:31 UTC (rev 2539) @@ -45,7 +45,9 @@ R workflow (it plays nicely with `layout()` for example. * stressplot: metaMDS and monoMDS stressplot() use now - expression(R^2) instead of ascii R2. + expression(R^2) instead of ascii R2. The stressplot.monoMDS() + function returns the plotting structures in the original input + order. Version 2.1-30 (opened May 5, 2013) From noreply at r-forge.r-project.org Sun Jun 30 18:44:04 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 30 Jun 2013 18:44:04 +0200 (CEST) Subject: [Vegan-commits] r2540 - in pkg/vegan/inst: . doc Message-ID: <20130630164405.00456185791@r-forge.r-project.org> Author: jarioksa Date: 2013-06-30 18:44:04 +0200 (Sun, 30 Jun 2013) New Revision: 2540 Modified: pkg/vegan/inst/ChangeLog pkg/vegan/inst/doc/veganjss.sty Log: Remove inconsolata styles from vignettes From: Prof Brian Ripley Subject: CRAN packages CHNOSZ events rspa vegan Date: 30 June 2013 4:50:43 PM GMT+03:00 These packages hard-code inconsolata.sty, which may not be installed and is now unavailable from CTAN. See https://stat.ethz.ch/pipermail/r-devel/2013-June/066850.html The problems are starting to show on your packages CRAN pages. This needs an urgent fix. Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-06-29 07:51:31 UTC (rev 2539) +++ pkg/vegan/inst/ChangeLog 2013-06-30 16:44:04 UTC (rev 2540) @@ -47,8 +47,12 @@ * stressplot: metaMDS and monoMDS stressplot() use now expression(R^2) instead of ascii R2. The stressplot.monoMDS() function returns the plotting structures in the original input - order. + order. + * vignettes: Brian Ripley urged as to remove + \usepackage{inconsolota} as this package is on the way to be + removed from CTAN. + Version 2.1-30 (opened May 5, 2013) * bioenv: can now use Mahalanobis, Manhattan and Gower distances Modified: pkg/vegan/inst/doc/veganjss.sty =================================================================== --- pkg/vegan/inst/doc/veganjss.sty 2013-06-29 07:51:31 UTC (rev 2539) +++ pkg/vegan/inst/doc/veganjss.sty 2013-06-30 16:44:04 UTC (rev 2540) @@ -17,8 +17,9 @@ \textbf{\large \thesubsection. #2} \nopagebreak \vskip \postSskip \nopagebreak} -%% use inconsolata fonts for code and examples -\usepackage{inconsolata} +%% do not use inconsolata fonts for code and examples: they are to be +%% removed from CTAN +%\usepackage{inconsolata} %% smaller examples \renewenvironment{Schunk}{\par\small}{}