From noreply at r-forge.r-project.org Fri Mar 1 04:56:35 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 1 Mar 2013 04:56:35 +0100 (CET) Subject: [Vegan-commits] r2456 - in pkg/permute: . R inst inst/tests man tests tests/Examples vignettes Message-ID: <20130301035635.4E40C183C27@r-forge.r-project.org> Author: gsimpson Date: 2013-03-01 04:56:33 +0100 (Fri, 01 Mar 2013) New Revision: 2456 Added: pkg/permute/R/Plots.R pkg/permute/R/shuffle2.R pkg/permute/R/shuffleSet2.R pkg/permute/man/allUtils.Rd pkg/permute/tests/Examples/ pkg/permute/tests/Examples/permute-Ex.Rout.save Removed: pkg/permute/man/allUtilis.Rd Modified: pkg/permute/DESCRIPTION pkg/permute/NAMESPACE pkg/permute/R/Blocks.R pkg/permute/R/allFree.R pkg/permute/R/allPerms.R pkg/permute/R/getFoo-methods.R pkg/permute/R/permControl.R pkg/permute/R/shuffle-utils.R pkg/permute/R/shuffle.R pkg/permute/R/shuffleSet.R pkg/permute/inst/ChangeLog pkg/permute/inst/tests/test-shuffle.R pkg/permute/man/allPerms.Rd pkg/permute/man/numPerms.Rd pkg/permute/man/permCheck.Rd pkg/permute/man/shuffle.Rd pkg/permute/man/shuffleSet.Rd pkg/permute/vignettes/permutations.Rnw Log: push all updates, which breaks everything as I've added true Blocking capability, shuffle() works, as does almost all of shuffleSet(). Other user utility functions are very broken. Modified: pkg/permute/DESCRIPTION =================================================================== --- pkg/permute/DESCRIPTION 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/DESCRIPTION 2013-03-01 03:56:33 UTC (rev 2456) @@ -1,11 +1,18 @@ Package: permute Title: Functions for generating restricted permutations of data -Version: 0.7-0 +Version: 0.7-2 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 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/NAMESPACE =================================================================== --- pkg/permute/NAMESPACE 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/NAMESPACE 2013-03-01 03:56:33 UTC (rev 2456) @@ -1,8 +1,8 @@ ### Visible functions: export(`allPerms`, `Blocks`, `numPerms`, `check`, `permCheck`, - `permControl`, `permute`, `shuffle`, `Within`, + `permControl`, `permute`, `shuffle`, `Within`, `Plots`, `shuffleFree`, `shuffleSeries`, `shuffleGrid`, `shuffleStrata`, - `getBlocks`, `getWithin`, `getStrata`, + `getBlocks`, `getWithin`, `getStrata`, `getType`, `shuffleSet`, `permuplot`) ### Imports: nobs() only exists in R 2.13.0 for import. We define the @@ -35,3 +35,5 @@ S3method(`getWithin`, `permControl`) S3method(`getStrata`, `default`) S3method(`getStrata`, `permControl`) +S3method(`getType`, `default`) +S3method(`getType`, `permControl`) Modified: pkg/permute/R/Blocks.R =================================================================== --- pkg/permute/R/Blocks.R 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/R/Blocks.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -1,13 +1,6 @@ -`Blocks` <- function(type = c("free","series","grid","none"), - mirror = FALSE, ncol = NULL, nrow = NULL) -{ - if(missing(type)) - type <- "none" - else - type <- match.arg(type) - out <- list(type = type, mirror = mirror, - ncol = ncol, nrow = nrow) +`Blocks` <- function(strata = NULL) { + out <- list(strata = strata) ## keep as list for now ##class(out) <- "Blocks" - return(out) + out } Added: pkg/permute/R/Plots.R =================================================================== --- pkg/permute/R/Plots.R (rev 0) +++ pkg/permute/R/Plots.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -0,0 +1,9 @@ +`Plots` <- function(strata = NULL, type = c("free","series","grid","none"), + mirror = FALSE, ncol = NULL, nrow = NULL) { + type <- match.arg(type) + out <- list(strata = strata, type = type, mirror = mirror, + ncol = ncol, nrow = nrow) + ## keep as list for now + ##class(out) <- "Plots" + out +} Modified: pkg/permute/R/allFree.R =================================================================== --- pkg/permute/R/allFree.R 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/R/allFree.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -1,11 +1,20 @@ -`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 - } +## `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)) { + if(n == 1L) return(array(v, c(1L, 1L))) + do.call(rbind, + lapply(seq_len(n), + function(i) cbind(v[i], allFree(n - 1L, v[-i])))) } Modified: pkg/permute/R/allPerms.R =================================================================== --- pkg/permute/R/allPerms.R 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/R/allPerms.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -37,7 +37,7 @@ if(WI$constant) { ## same permutation in each block pg <- unique(tab) - ctrl.wi <- permControl(strata = NULL, within = WI) + ctrl.wi <- permControl(within = WI) nperms <- numPerms(pg, ctrl.wi) ord <- switch(type.wi, free = allFree(pg), @@ -62,7 +62,7 @@ ## FIXME: this should not be needed once all checks are ## in place in check() stop("Unbalanced grid designs are not supported") - ctrl.wi <- permControl(strata = NULL, within = WI) + ctrl.wi <- permControl(within = WI) sp <- split(v, STRATA) res <- vector(mode = "list", length = ng) add <- c(0, cumsum(tab)[1:(ng-1)]) @@ -90,7 +90,7 @@ unlist(sp), v)) } else { ## same number of observations per level of strata - ctrl.wi <- permControl(strata = NULL, within = WI) + ctrl.wi <- permControl(within = WI) np <- numPerms(pg, ctrl.wi) ord <- switch(type.wi, @@ -126,6 +126,7 @@ 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 CTRL that just permutes blocks ctrl.b <- permControl(strata = STRATA, Modified: pkg/permute/R/getFoo-methods.R =================================================================== --- pkg/permute/R/getFoo-methods.R 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/R/getFoo-methods.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -1,4 +1,6 @@ -## Extractor functions for blocks and within +## Extractor functions for blocks, plots and within, plus strata + +## Blocks getBlocks <- function(object, ...) { UseMethod("getBlocks") } @@ -11,6 +13,20 @@ object$blocks } +## Plots +getPlots <- function(object, ...) { + UseMethod("getPlots") +} + +getPlots.default <- function(object, ...) { + stop("No default method for 'getPlots()'") +} + +getPlots.permControl <- function(object, ...) { + object$plots +} + +## Within plots getWithin <- function(object, ...) { UseMethod("getWithin") } @@ -23,6 +39,7 @@ object$within } +## Strata getStrata <- function(object, ...) { UseMethod("getStrata") } @@ -31,9 +48,40 @@ stop("No default method for 'getStrata()'") } -getStrata.permControl <- function(object, ...) { - object$strata +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$strata + else + stop("Ambiguous `which`") + if(isTRUE(drop) && !is.null(strata)) + strata <- droplevels(strata) + strata } +## Get type of permutation +getType <- function(object, ...) { + UseMethod("getType") +} + +getType.default <- function(object, ...) { + stop("No default method for 'getType()'") +} + +getType.permControl <- 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.... Modified: pkg/permute/R/permControl.R =================================================================== --- pkg/permute/R/permControl.R 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/R/permControl.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -1,12 +1,29 @@ -`permControl` <- function(strata = NULL, nperm = 199, complete = FALSE, - within = Within(), +## `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 = Blocks(), + nperm = 199, complete = FALSE, maxperm = 9999, minperm = 99, all.perms = NULL, observed = FALSE) { - out <- list(strata = strata, nperm = nperm, complete = complete, - within = within, blocks = blocks, + 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))) Modified: pkg/permute/R/shuffle-utils.R =================================================================== --- pkg/permute/R/shuffle-utils.R 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/R/shuffle-utils.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -70,3 +70,15 @@ `shuffleFree` <- function(x, size) { sample.int(x, size, replace = FALSE) } + +## wrapper function when shuffling without any strata at all at any level +`shuffleNoStrata` <- function(n, control) { + type <- control$within$type + switch(type, + "free" = shuffleFree(n, n), + "series" = shuffleSeries(seq_len(n), mirror = control$within$mirror), + "grid" = shuffleGrid(nrow = control$within$nrow, + ncol = control$within$ncol, mirror = control$within$mirror), + "none" = seq_len(n) + ) +} Modified: pkg/permute/R/shuffle.R =================================================================== --- pkg/permute/R/shuffle.R 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/R/shuffle.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -1,16 +1,95 @@ -`shuffle` <- function (n, control = permControl()) { - ## If no strata then permute all samples using stated scheme - if(is.null(control$strata)) { - out <- - switch(control$within$type, - "free" = shuffleFree(n, n), - "series" = shuffleSeries(seq_len(n), - mirror = control$within$mirror), - "grid" = shuffleGrid(nrow = control$within$nrow, - ncol = control$within$ncol, - mirror = control$within$mirror), - "none" = seq_len(n) - ) +## `shuffle` <- function (n, control = permControl()) { +## ## If no strata then permute all samples using stated scheme +## if(is.null(control$strata)) { +## out <- +## switch(control$within$type, +## "free" = shuffleFree(n, n), +## "series" = shuffleSeries(seq_len(n), +## mirror = control$within$mirror), +## "grid" = shuffleGrid(nrow = control$within$nrow, +## ncol = control$within$ncol, +## mirror = control$within$mirror), +## "none" = seq_len(n) +## ) +## } else { +## ## If strata present, either permute samples, strata or both + +## ## permute strata? +## if(control$blocks$type == "none") { +## out <- seq_len(n) +## } else { +## flip <- runif(1L) < 0.5 ## why are we doing this? Null better? +## out <- shuffleStrata(control$strata, +## type = control$blocks$type, +## mirror = control$blocks$mirror, +## flip = flip, +## nrow = control$blocks$nrow, +## ncol = control$blocks$ncol) +## } +## ## permute the samples within strata? +## if(control$within$type != "none") { +## tab <- table(control$strata[out]) +## ## the levels of the strata +## inds <- names(tab) +## ## same permutation within each level of strata? +## if(control$within$constant) { +## if(control$within$type == "free") { +## n <- unique(tab)[1L] +## same.rand <- shuffleFree(n, n) +## } else if(control$within$type == "series") { +## start <- shuffleFree(n / length(inds), 1L) +## flip <- runif(1L) < 0.5 +## } else if(control$within$type == "grid") { +## start.row <- shuffleFree(control$within$nrow, 1L) +## start.col <- shuffleFree(control$within$ncol, 1L) +## flip <- runif(2L) < 0.5 +## } +## } else { +## start <- start.row <- start.col <- flip <- NULL +## } +## tmp <- out +## ## for each level of strata, permute +## for (is in inds) { +## ## must re-order strata here on basis of out as they +## ## may have been permuted above +## MATCH <- control$strata[out] == is +## gr <- out[MATCH] +## if ((n.gr <- length(gr)) > 1) { +## tmp[which(MATCH)] <- +## switch(control$within$type, +## "free" = +## if(control$within$constant) { +## gr[same.rand] +## } else { +## out[gr][shuffleFree(n.gr, n.gr)] +## }, +## "series" = +## gr[shuffleSeries(seq_len(n.gr), +## mirror = control$within$mirror, +## start = start, flip = flip)], +## "grid" = +## gr[shuffleGrid(nrow = control$within$nrow, +## ncol = control$within$ncol, +## mirror = control$within$mirror, +## start.row = start.row, +## start.col = start.col, +## flip = flip)] +## ) +## } +## } +## out <- tmp +## } +## } +## out +## } + +`shuffle2` <- function (n, control = permControl()) { + ## capture strata data + Pstrata <- getStrata(control, which = "plots") + Bstrata <- getStrata(control, which = "blocks") + ## if no strata at all permute all samples using stated scheme + if(is.null(Pstrata) && is.null(Bstrata)) { + out <- shuffleNoStrata(n, control) } else { ## If strata present, either permute samples, strata or both Added: pkg/permute/R/shuffle2.R =================================================================== --- pkg/permute/R/shuffle2.R (rev 0) +++ pkg/permute/R/shuffle2.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -0,0 +1,113 @@ +## new version of shuffle() that allows for blocking +`shuffle` <- function(n, control = permControl()) { + ## get blocking, if any + Block <- getStrata(control, which = "blocks") + if(is.null(Block)) + Block <- factor(rep(1, n)) + + sn <- seq_len(n) ## sequence of samples in order of input + + ## 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]] <- doShuffle(spln[[i]], control) + } + out <- unsplit(out, Block) ## undo the original splitting + out +} + +`doShuffle` <- function(ind, control) { + ## collect strata at Plot level + Pstrata <- getStrata(control, which = "plots", drop = TRUE) + plotCTRL <- getPlots(control) + + n <- length(ind) + sn <- seq_len(n) + + ## if no strata at Plot level permute all samples using stated scheme + if(is.null(Pstrata)) { + perm <- shuffleNoStrata(n, control) + } else { + typeP <- getType(control, which = "plots") + typeW <- getType(control, which = "within") + + ## permute Plot strata? + if(isTRUE(all.equal(typeP, "none"))) { ## NO + perm <- sn + } else { ## YES + flip <- runif(1L) < 0.5 ## logical, passed on & used only if mirroring + perm <- shuffleStrata(Pstrata[ind], ## take only the ind values + type = typeP, + mirror = plotCTRL$mirror, + flip = flip, + nrow = plotCTRL$nrow, + ncol = plotCTRL$ncol) + } + + ## permute the samples within Plot strata + if(!isTRUE(all.equal(typeW, "none"))) { ## NOTE the `!` + ## house keeping to track permuted strata - used later + tab <- table(Pstrata[ind][perm]) + levs <- names(tab) ## levels of Plot strata in this split + + ## use same permutation within each level of strata? + withinCTRL <- getWithin(control) + CONSTANT <- withinCTRL$constant + if(isTRUE(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 + } else if(isTRUE(all.equal(typeW, "grid"))) { + start.row <- shuffleFree(withinCTRL$nrow, 1L) + start.col <- shuffleFree(withinCTRL$ncol, 1L) + flip <- runif(2L) < 0.5 + } + } else { + start <- start.row <- start.col <- flip <- NULL + } + + ## copy perm at this stage + tmp <- perm + + ## for each level of strata in this split, shuffle + for(lv in levs) { + ## must re-order strata here on basis of out as they + ## may have been permuted above + MATCH <- Pstrata[ind][perm] == lv + gr <- perm[MATCH] + if((n.gr <- length(gr)) > 1) { + tmp[which(MATCH)] <- + switch(typeW, + "free" = if(isTRUE(CONSTANT)) { + gr[same.rand] + } else { + perm[gr][shuffleFree(n.gr, n.gr)] + }, + "series" = + gr[shuffleSeries(seq_len(n.gr), + mirror = withinCTRL$mirror, + start = start, flip = flip)], + "grid" = + gr[shuffleGrid(nrow = withinCTRL$nrow, + ncol = withinCTRL$ncol, + mirror = withinCTRL$mirror, + start.row = start.row, + start.col = start.col, + flip = flip)] + ) + } + } + perm <- tmp + } + } + ind[perm] +} Modified: pkg/permute/R/shuffleSet.R =================================================================== --- pkg/permute/R/shuffleSet.R 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/R/shuffleSet.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -1,4 +1,4 @@ -`shuffleSet` <- function(n, nset = 1, control = permControl()) { +`shuffleSet2` <- function(n, nset = 1, control = permControl()) { Set <- matrix(nrow = nset, ncol = n) WI <- getWithin(control) strata <- getStrata(control) Added: pkg/permute/R/shuffleSet2.R =================================================================== --- pkg/permute/R/shuffleSet2.R (rev 0) +++ pkg/permute/R/shuffleSet2.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -0,0 +1,143 @@ +## new version of shuffleSet() that allows for blocking +`shuffleSet` <- function(n, nset = 1, control = permControl()) { + ## get blocking, if any + Block <- getStrata(control, which = "blocks") + if(is.null(Block)) + Block <- factor(rep(1, n)) + + sn <- seq_len(n) ## sequence of samples in order of input + + ## 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 +} + +`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 + + ## 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 +} Modified: pkg/permute/inst/ChangeLog =================================================================== --- pkg/permute/inst/ChangeLog 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/inst/ChangeLog 2013-03-01 03:56:33 UTC (rev 2456) @@ -2,6 +2,39 @@ permute ChangeLog +Version 0.7-2 + + * Major API change: Added capability to handle true blocking + constraints, as suggested by Cajo ter Braak. We now have + + o Blocks: samples are *never* permuted between blocks. Blocks + can't be permuted either. + o Plots: these define groups of samples, for example the + whole plots in a split-plot design, or repeated measures + on a set of sites. The sites are the "plots". Plots can + be permuted using any of the restricted schemes offered + in permute. + o Within: these are the samples, the rows in the data set. + They can be nested in Plots and/or in Blocks. + + This capability has made it into permControl(), shuffle() and + shuffleSet(), though the latter certainly has one major bug + in the case where there is more than one Block. + + Most other functionality is broken as the above change has + altered the permControl object in a way that is not backwards + compatible. + + Note that the 0.7.x branch is a development branch and should + not be used in ernest until I work through all the implications + of this change. Rest assured, I won't be doing this again! + +Version 0.7-1 + + * allPerms: implement Doug Bates version which simplifies and + speeds up the code. A faste RcppEigen-based version also exists + but will need larger changes to the package to implement. + Version 0.7-0 * Vignette: silly typo is example code illustrating shuffle(). Modified: pkg/permute/inst/tests/test-shuffle.R =================================================================== --- pkg/permute/inst/tests/test-shuffle.R 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/inst/tests/test-shuffle.R 2013-03-01 03:56:33 UTC (rev 2456) @@ -24,12 +24,11 @@ ## test what shuffle returns when permuting only the strata ## must *not* assume that the samples are in contiguous blocks test_that("shuffle() works for non-contigous blocks of samples", { - ## permuting levels of block instead of observations + ## permuting levels of Plots instead of observations ## non-contiguous blocks - checks that r1972 continues to work - block <- factor(rep(1:4, 5)) - CTRL <- permControl(strata = block, - blocks = Blocks(type = "free"), - within = Within(type = "none")) + Plot <- factor(rep(1:4, 5)) + CTRL <- permControl(plots = Plots(strata = Plot, type = "free"), + within = Within(type = "none")) n <- 20 set.seed(2) result <- shuffle(n, CTRL) @@ -40,5 +39,5 @@ 19,18,17,20)) expect_that(result, is_identical_to(out1)) out2 <- factor(as.integer(rep(c(3,2,1,4), 5)), levels = 1:4) - expect_that(block[result], is_identical_to(out2)) + expect_that(Plot[result], is_identical_to(out2)) }) Modified: pkg/permute/man/allPerms.Rd =================================================================== --- pkg/permute/man/allPerms.Rd 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/man/allPerms.Rd 2013-03-01 03:56:33 UTC (rev 2456) @@ -67,6 +67,7 @@ } \author{Gavin Simpson} \examples{ +\dontrun{ % FIXME - this needs updating for blocks ## allPerms can work with a vector vec <- c(3,4,5) allPerms(vec) ## free permutation @@ -89,13 +90,14 @@ numPerms(seq_len(Nobs), control = ctrl) (tmp3 <- allPerms(Nobs, control = ctrl, observed = TRUE)) (tmp4 <- allPerms(Nobs, control = ctrl)) +} -%\dontrun{ +\dontrun{ ## prints out details of the permutation scheme as ## well as the matrix of permutations % FIXME: uncomment the two lines below when we remove old permute % code from vegan and have vegan depend on permute summary(tmp3) summary(tmp4) -%} } +} Deleted: pkg/permute/man/allUtilis.Rd =================================================================== --- pkg/permute/man/allUtilis.Rd 2013-02-28 21:02:32 UTC (rev 2455) +++ pkg/permute/man/allUtilis.Rd 2013-03-01 03:56:33 UTC (rev 2456) @@ -1,53 +0,0 @@ -\name{allUtils} -\alias{allFree} -\alias{allSeries} -\alias{allGrid} -\alias{allStrata} - -\title{Utility functions for complete enumeration of all possible - permutations} - -\description{ - Utility functions to return the set of all permutations under - different designs. For most practical applications, i.e. to combine - designs permuting blocks and/or within blocks function - \code{\link{allPerms}} will be required. -} - -\usage{ -allFree(n, v = 1:n) - -allSeries(n, nperms, mirror = FALSE) - -allGrid(n, nperms, nr, nc, mirror, constant) - -allStrata(n, control) -} - -\arguments{ - \item{n}{the number of observations.} - \item{v}{numeric; vector of indices. Default is \code{1:n}.} - \item{nperms}{numeric; number of possible permutations.} - \item{mirror}{logical; mirroring of permutations allowed?} - \item{nr,nc}{integer; number of rows and columns of grid designs.} - \item{constant}{logical; same permutation within each block?} - \item{control}{a list of control values describing properties of the - permutation design, as returned by a call to - \code{\link{permControl}}.} -} - -\details{ - These are utility functions and aren't designed for casual - use. \code{\link{allPerms}} should be used instead. - - Details on usage of these functions can be found in - \code{\link{allPerms}}. -} - -\value{ - A matrix of all possible permutations of \code{n} observations or of - \code{v}, given the provided options. -} - -\author{Gavin Simpson} - Copied: pkg/permute/man/allUtils.Rd (from rev 2310, pkg/permute/man/allUtilis.Rd) =================================================================== --- pkg/permute/man/allUtils.Rd (rev 0) +++ pkg/permute/man/allUtils.Rd 2013-03-01 03:56:33 UTC (rev 2456) @@ -0,0 +1,53 @@ +\name{allUtils} +\alias{allFree} +\alias{allSeries} +\alias{allGrid} +\alias{allStrata} + +\title{Utility functions for complete enumeration of all possible + permutations} + +\description{ + Utility functions to return the set of all permutations under + different designs. For most practical applications, i.e. to combine + designs permuting blocks and/or within blocks function + \code{\link{allPerms}} will be required. +} + +\usage{ +allFree(n, v = seq_len(n)) + [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vegan -r 2456 From noreply at r-forge.r-project.org Fri Mar 1 18:30:51 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 1 Mar 2013 18:30:51 +0100 (CET) Subject: [Vegan-commits] r2457 - in branches/2.0: R inst man Message-ID: <20130301173051.C8228184CB8@r-forge.r-project.org> Author: jarioksa Date: 2013-03-01 18:30:51 +0100 (Fri, 01 Mar 2013) New Revision: 2457 Modified: branches/2.0/R/nestedtemp.R branches/2.0/R/points.cca.R branches/2.0/R/print.monoMDS.R branches/2.0/R/text.cca.R branches/2.0/inst/ChangeLog branches/2.0/man/plot.cca.Rd Log: merge small fixes to vegan 2.0-7 (2448 partly, 2449, 2452, 2453) - print metaMDS explains clearer the stopping criteria (r2448, 2449) - plot/text.cca gained argument axis.bp = TRUE (r2452) - nestedtemp failed with fill < 0.38% (r2453) Modified: branches/2.0/R/nestedtemp.R =================================================================== --- branches/2.0/R/nestedtemp.R 2013-03-01 03:56:33 UTC (rev 2456) +++ branches/2.0/R/nestedtemp.R 2013-03-01 17:30:51 UTC (rev 2457) @@ -48,7 +48,23 @@ fillfun <- function(x, p) 1 - (1-(1-x)^p)^(1/p) intfun <- function(p, fill) integrate(fillfun, lower=0, upper=1, p=p)$value - fill - p <- uniroot(intfun, c(0,20), fill=fill)$root + ## 'p' will depend on 'fill', and fill = 0.0038 correspond to p = + ## 20. Sometimes the fill is lower, and therefore we try() to see + ## if we need to move the bracket up. We should need to do this + ## very rarely. + lo <- 0 + hi <- 20 + repeat{ + sol <- try(uniroot(intfun, c(lo,hi), fill=fill), silent = TRUE) + if (inherits(sol, "try-error")) { + if (hi > 640) # bail out + stop(gettextf("matrix is too sparse, fill is %g"), fill) + lo <- hi + hi <- hi + hi + } else + break + } + p <- sol$root ## row coordinates of the fill line for all matrix entries out <- matrix(0, nrow=length(r), ncol=length(c)) for (i in 1:length(r)) Modified: branches/2.0/R/points.cca.R =================================================================== --- branches/2.0/R/points.cca.R 2013-03-01 03:56:33 UTC (rev 2456) +++ branches/2.0/R/points.cca.R 2013-03-01 17:30:51 UTC (rev 2457) @@ -1,6 +1,6 @@ `points.cca` <- function (x, display = "sites", choices = c(1, 2), scaling = 2, - arrow.mul, head.arrow = 0.05, select, const, ...) + arrow.mul, head.arrow = 0.05, select, const, axis.bp = TRUE, ...) { formals(arrows) <- c(formals(arrows), alist(... = )) if (length(display) > 1) @@ -28,10 +28,12 @@ arrows(0, 0, pts[, 1], pts[, 2], length = head.arrow, ...) pts <- pts * 1.1 - axis(3, at = c(-arrow.mul, 0, arrow.mul), labels = rep("", - 3)) - axis(4, at = c(-arrow.mul, 0, arrow.mul), labels = c(-1, - 0, 1)) + if (axis.bp) { + axis(3, at = c(-arrow.mul, 0, arrow.mul), + labels = rep("", 3)) + axis(4, at = c(-arrow.mul, 0, arrow.mul), + labels = c(-1, 0, 1)) + } return(invisible()) } points(pts, ...) Modified: branches/2.0/R/print.monoMDS.R =================================================================== --- branches/2.0/R/print.monoMDS.R 2013-03-01 03:56:33 UTC (rev 2456) +++ branches/2.0/R/print.monoMDS.R 2013-03-01 17:30:51 UTC (rev 2457) @@ -31,10 +31,10 @@ cat(", rotated to principal components") cat("\n") stoplab <- switch(x$icause, - "Maximum number of iteration reached", - "Stress nearly zero", - "Stress nearly unchanged", - "Scale factor of gradient nearly zero") + "Maximum number of iterations (maxit) reached", + "Stress nearly zero (< smin)", + "Stress nearly unchanged (ratio > sratmax)", + "Scale factor of gradient nearly zero (< sfgrmin)") cat("Stopped after ", x$iters, " iterations: ", stoplab, "\n", sep="") invisible(x) } Modified: branches/2.0/R/text.cca.R =================================================================== --- branches/2.0/R/text.cca.R 2013-03-01 03:56:33 UTC (rev 2456) +++ branches/2.0/R/text.cca.R 2013-03-01 17:30:51 UTC (rev 2457) @@ -1,6 +1,6 @@ `text.cca` <- function (x, display = "sites", labels, choices = c(1, 2), scaling = 2, - arrow.mul, head.arrow = 0.05, select, const, ...) + arrow.mul, head.arrow = 0.05, select, const, axis.bp = TRUE, ...) { formals(arrows) <- c(formals(arrows), alist(... = )) if (length(display) > 1) @@ -30,10 +30,12 @@ arrows(0, 0, pts[, 1], pts[, 2], length = head.arrow, ...) pts <- pts * 1.1 - axis(3, at = c(-arrow.mul, 0, arrow.mul), labels = rep("", - 3)) - axis(4, at = c(-arrow.mul, 0, arrow.mul), labels = c(-1, - 0, 1)) + if (axis.bp) { + axis(side = 3, at = c(-arrow.mul, 0, arrow.mul), + labels = rep("", 3)) + axis(side = 4, at = c(-arrow.mul, 0, arrow.mul), + labels = c(-1, 0, 1)) + } } text(pts, labels = rownames(pts), ...) invisible() Modified: branches/2.0/inst/ChangeLog =================================================================== --- branches/2.0/inst/ChangeLog 2013-03-01 03:56:33 UTC (rev 2456) +++ branches/2.0/inst/ChangeLog 2013-03-01 17:30:51 UTC (rev 2457) @@ -4,6 +4,10 @@ Version 2.0-7 (opened February 17, 2013) + * merge r2453: nestedtemp failed with fill < 0.38% + * merge r2452: plot/text.cca gained axis.bp = TRUE argument. + * merge r2448 (partly), 2449: print.monoMDS clearer about + convergence. Only this part merged: metaMDSiter untouched. * merge r2443: edit cca.object.Rd. * merge r2434: return wcmdscale object always with non-default arguments. Modified: branches/2.0/man/plot.cca.Rd =================================================================== --- branches/2.0/man/plot.cca.Rd 2013-03-01 03:56:33 UTC (rev 2456) +++ branches/2.0/man/plot.cca.Rd 2013-03-01 17:30:51 UTC (rev 2457) @@ -21,9 +21,9 @@ \method{plot}{cca}(x, choices = c(1, 2), display = c("sp", "wa", "cn"), scaling = 2, type, xlim, ylim, const, ...) \method{text}{cca}(x, display = "sites", labels, choices = c(1, 2), scaling = 2, - arrow.mul, head.arrow = 0.05, select, const, ...) + arrow.mul, head.arrow = 0.05, select, const, axis.bp = TRUE, ...) \method{points}{cca}(x, display = "sites", choices = c(1, 2), scaling = 2, - arrow.mul, head.arrow = 0.05, select, const, ...) + arrow.mul, head.arrow = 0.05, select, const, axis.bp = TRUE, ...) \method{scores}{cca}(x, choices=c(1,2), display=c("sp","wa","cn"), scaling=2, ...) \method{scores}{rda}(x, choices=c(1,2), display=c("sp","wa","cn"), scaling=2, const, ...) @@ -74,6 +74,7 @@ \samp{decision-vegan.pdf} with \code{\link{vegandocs}} for details and discussion). If \code{const} is a vector of two items, the first is used for species, and the second item for site scores.} + \item{axis.bp}{Draw \code{\link{axis}} for biplot arrows.} \item{axes}{Number of axes in summaries.} \item{digits}{Number of digits in output.} \item{n, head, tail}{Number of rows printed from the head and tail of From noreply at r-forge.r-project.org Sun Mar 3 16:35:16 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 3 Mar 2013 16:35:16 +0100 (CET) Subject: [Vegan-commits] r2458 - pkg/vegan/R Message-ID: <20130303153516.80AD2180586@r-forge.r-project.org> Author: jarioksa Date: 2013-03-03 16:35:16 +0100 (Sun, 03 Mar 2013) New Revision: 2458 Modified: pkg/vegan/R/fitspecaccum.R Log: restructure nls() models i fitspecaccum Modified: pkg/vegan/R/fitspecaccum.R =================================================================== --- pkg/vegan/R/fitspecaccum.R 2013-03-01 17:30:51 UTC (rev 2457) +++ pkg/vegan/R/fitspecaccum.R 2013-03-03 15:35:16 UTC (rev 2458) @@ -15,26 +15,20 @@ x <- object$individuals else x <- object$sites - mods <- switch(model, - "arrhenius" = apply(SpeciesRichness, 2, - function(y) nls(y ~ SSarrhenius(x, k, z), ...)), - "gleason" = apply(SpeciesRichness, 2, - function(y) nls(y ~ SSgleason(x, k, slope), ...)), - "gitay" = apply(SpeciesRichness, 2, - function(y) nls(y ~ SSgitay(x, k, slope), ...)), - "lomolino" = apply(SpeciesRichness, 2, - function(y) nls(y ~ SSlomolino(x, Asym, xmid, slope), ...)), - "asymp" = apply(SpeciesRichness, 2, - function(y) nls(y ~ SSlogis(x, Asym, xmid, scal), ...)), - "gompertz" = apply(SpeciesRichness, 2, - function(y) nls(y ~ SSgompertz(x, Asym, xmid, scal), ...)), - "michaelis-menten" = apply(SpeciesRichness, 2, - function(y) nls(y ~ SSmicmen(x, Vm, K), ...)), - "logis" = apply(SpeciesRichness, 2, - function(y) nls(y ~ SSlogis(x, Asym, xmid, scal), ...)), - "weibull" = apply(SpeciesRichness, 2, - function(y) nls(y ~ SSweibull(x, Asym, Drop, lrc, par), ...)) - ) + NLSFUN <- function(y, x, model, ...) { + switch(model, + "arrhenius" = nls(y ~ SSarrhenius(x, k, z), ...), + "gleason" = nls(y ~ SSgleason(x, k, slope), ...), + "gitay" = nls(y ~ SSgitay(x, k, slope), ...), + "lomolino" = nls(y ~ SSlomolino(x, Asym, xmid, slope), ...), + "asymp" = nls(y ~ SSlogis(x, Asym, xmid, scal), ...), + "gompertz" = nls(y ~ SSgompertz(x, Asym, xmid, scal), ...), + "michaelis-menten" = nls(y ~ SSmicmen(x, Vm, K), ...), + "logis" = nls(y ~ SSlogis(x, Asym, xmid, scal), ...), + "weibull" = nls(y ~ SSweibull(x, Asym, Drop, lrc, par), ...)) + } + mods <- lapply(seq_len(NCOL(SpeciesRichness)), + function(i, ...) NLSFUN(SpeciesRichness[,i], x, model, ...)) object$fitted <- drop(sapply(mods, fitted)) object$residuals <- drop(sapply(mods, residuals)) object$coefficients <- drop(sapply(mods, coef)) From noreply at r-forge.r-project.org Sun Mar 3 17:00:30 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 3 Mar 2013 17:00:30 +0100 (CET) Subject: [Vegan-commits] r2459 - in pkg/vegan: . R Message-ID: <20130303160030.BD290184883@r-forge.r-project.org> Author: jarioksa Date: 2013-03-03 17:00:30 +0100 (Sun, 03 Mar 2013) New Revision: 2459 Modified: pkg/vegan/NAMESPACE pkg/vegan/R/fitspecaccum.R Log: fitspecaccum handles weighted models Modified: pkg/vegan/NAMESPACE =================================================================== --- pkg/vegan/NAMESPACE 2013-03-03 15:35:16 UTC (rev 2458) +++ pkg/vegan/NAMESPACE 2013-03-03 16:00:30 UTC (rev 2459) @@ -192,6 +192,7 @@ # labels: base S3method(labels, envfit) # lines: graphics +S3method(lines, fitspecaccum) S3method(lines, humpfit) S3method(lines, permat) S3method(lines, preston) Modified: pkg/vegan/R/fitspecaccum.R =================================================================== --- pkg/vegan/R/fitspecaccum.R 2013-03-03 15:35:16 UTC (rev 2458) +++ pkg/vegan/R/fitspecaccum.R 2013-03-03 16:00:30 UTC (rev 2459) @@ -15,6 +15,7 @@ x <- object$individuals else x <- object$sites + hasWeights <- !is.null(object$weights) NLSFUN <- function(y, x, model, ...) { switch(model, "arrhenius" = nls(y ~ SSarrhenius(x, k, z), ...), @@ -28,7 +29,10 @@ "weibull" = nls(y ~ SSweibull(x, Asym, Drop, lrc, par), ...)) } mods <- lapply(seq_len(NCOL(SpeciesRichness)), - function(i, ...) NLSFUN(SpeciesRichness[,i], x, model, ...)) + function(i, ...) + NLSFUN(SpeciesRichness[,i], + if (hasWeights) object$weights[,i] else x, + model, ...)) object$fitted <- drop(sapply(mods, fitted)) object$residuals <- drop(sapply(mods, residuals)) object$coefficients <- drop(sapply(mods, coef)) @@ -44,8 +48,22 @@ function(x, col = par("fg"), lty = 1, xlab = "Sites", ylab = x$method, ...) { - fv <- fitted(x) + if (is.null(x$weights)) + fv <- fitted(x) + else + fv <- sapply(x$models, predict, newdata = list(x = x$effort)) matplot(x$sites, fv, col = col, lty = lty, pch = NA, xlab = xlab, ylab = ylab, type = "l", ...) invisible() } + +`lines.fitspecaccum` <- + function(x, col = par("fg"), lty = 1, ...) +{ + if (is.null(x$weights)) + fv <- fitted(x) + else + fv <- sapply(x$models, predict, newdata= list(x = x$effort)) + matlines(x$sites, fv, col = col, lty = lty, pch = NA, type = "l", ...) + invisible() +} From noreply at r-forge.r-project.org Mon Mar 4 10:08:02 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 4 Mar 2013 10:08:02 +0100 (CET) Subject: [Vegan-commits] r2460 - pkg/vegan/R Message-ID: <20130304090802.3E7F51849EC@r-forge.r-project.org> Author: jarioksa Date: 2013-03-04 10:08:01 +0100 (Mon, 04 Mar 2013) New Revision: 2460 Modified: pkg/vegan/R/print.specaccum.R Log: print (average) effort in weighted specaccum Modified: pkg/vegan/R/print.specaccum.R =================================================================== --- pkg/vegan/R/print.specaccum.R 2013-03-03 16:00:30 UTC (rev 2459) +++ pkg/vegan/R/print.specaccum.R 2013-03-04 09:08:01 UTC (rev 2460) @@ -8,7 +8,8 @@ } cat("\n") cat("Call:", deparse(x$call), "\n\n") - mat <- rbind(Sites = x$sites, Richness = x$richness, sd=x$sd) + mat <- rbind(Sites = x$sites, Effort = x$effort, Richness = x$richness, + sd=x$sd) colnames(mat) <- rep("", ncol(mat)) print(mat) invisible(x) From noreply at r-forge.r-project.org Mon Mar 4 10:22:06 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 4 Mar 2013 10:22:06 +0100 (CET) Subject: [Vegan-commits] r2461 - pkg/vegan/man Message-ID: <20130304092207.E9EAB184ADE@r-forge.r-project.org> Author: jarioksa Date: 2013-03-04 10:22:06 +0100 (Mon, 04 Mar 2013) New Revision: 2461 Modified: pkg/vegan/man/specaccum.Rd Log: add basic documentation about weights in specaccum and fitspecaccum Modified: pkg/vegan/man/specaccum.Rd =================================================================== --- pkg/vegan/man/specaccum.Rd 2013-03-04 09:08:01 UTC (rev 2460) +++ pkg/vegan/man/specaccum.Rd 2013-03-04 09:22:06 UTC (rev 2461) @@ -3,9 +3,11 @@ \alias{print.specaccum} \alias{summary.specaccum} \alias{plot.specaccum} +\alias{lines.specaccum} \alias{boxplot.specaccum} \alias{fitspecaccum} \alias{plot.fitspecaccum} +\alias{lines.fitspecaccum} \alias{predict.specaccum} \alias{predict.fitspecaccum} @@ -45,8 +47,7 @@ the empirical dataset for the exact SAC} \item{gamma}{Method for estimating the total extrapolated number of species in the survey area by function \code{\link{specpool}}} - \item{w}{Weights giving the sampling effort (an experimental feature - that may be removed).} + \item{w}{Weights giving the sampling effort.} \item{x}{A \code{specaccum} result object} \item{add}{Add to an existing graph.} \item{random}{\dots} @@ -152,6 +153,8 @@ is the number of sites corresponding to a certain number of individuals and generally not an integer, and the average number of individuals is also returned in item \code{individuals}.} + \item{effort}{Average sum of weights corresponding to the number of + sites when model was fitted with argument \code{w}} \item{richness}{The number of species corresponding to number of sites. With \code{method = "collector"} this is the observed richness, for other methods the average or expected richness.} @@ -162,7 +165,9 @@ \item{perm}{Permutation results with \code{method = "random"} and \code{NULL} in other cases. Each column in \code{perm} holds one permutation.} - + \item{weights}{Matrix of accumulated weigths corresponding to the + columns of the \code{perm} matrix when model was fitted with + argument \code{w}.} \item{fitted, residuals, coefficients}{Only in \code{fitspecacum}: fitted values, residuals and nonlinear model coefficients. For \code{method = "random"} these are matrices with a column for From noreply at r-forge.r-project.org Mon Mar 4 14:25:37 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 4 Mar 2013 14:25:37 +0100 (CET) Subject: [Vegan-commits] r2462 - in pkg/vegan: R inst Message-ID: <20130304132537.2D359184DA6@r-forge.r-project.org> Author: jarioksa Date: 2013-03-04 14:25:36 +0100 (Mon, 04 Mar 2013) New Revision: 2462 Modified: pkg/vegan/R/fitspecaccum.R pkg/vegan/inst/ChangeLog Log: model = 'asymp' did not fit SSasymp but SSlogis (like model = 'logis', too) Modified: pkg/vegan/R/fitspecaccum.R =================================================================== --- pkg/vegan/R/fitspecaccum.R 2013-03-04 09:22:06 UTC (rev 2461) +++ pkg/vegan/R/fitspecaccum.R 2013-03-04 13:25:36 UTC (rev 2462) @@ -22,7 +22,7 @@ "gleason" = nls(y ~ SSgleason(x, k, slope), ...), "gitay" = nls(y ~ SSgitay(x, k, slope), ...), "lomolino" = nls(y ~ SSlomolino(x, Asym, xmid, slope), ...), - "asymp" = nls(y ~ SSlogis(x, Asym, xmid, scal), ...), + "asymp" = nls(y ~ SSasymp(x, Asym, R0, lrc), ...), "gompertz" = nls(y ~ SSgompertz(x, Asym, xmid, scal), ...), "michaelis-menten" = nls(y ~ SSmicmen(x, Vm, K), ...), "logis" = nls(y ~ SSlogis(x, Asym, xmid, scal), ...), Modified: pkg/vegan/inst/ChangeLog =================================================================== --- pkg/vegan/inst/ChangeLog 2013-03-04 09:22:06 UTC (rev 2461) +++ pkg/vegan/inst/ChangeLog 2013-03-04 13:25:36 UTC (rev 2462) @@ -19,6 +19,9 @@ of the new argument is still untested with specaccum() support functions. + * fitspecaccum: model = "asymp" was actually fitting logistic + regression (the same as model = "logis"). + * text.cca, points.cca: gained argument 'axis.bp' (defaults TRUE) to suppress drawing axes for scaled biplot arrows. Only effective if 'bp' scores were requested. From noreply at r-forge.r-project.org Mon Mar 4 18:05:14 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 4 Mar 2013 18:05:14 +0100 (CET) Subject: [Vegan-commits] r2463 - pkg/vegan/R Message-ID: <20130304170514.E421F184AD4@r-forge.r-project.org> Author: jarioksa Date: 2013-03-04 18:05:14 +0100 (Mon, 04 Mar 2013) New Revision: 2463 Modified: pkg/vegan/R/print.specaccum.R Log: also print Individuals and zapsmall for prettier figures in print.specaccum Modified: pkg/vegan/R/print.specaccum.R =================================================================== --- pkg/vegan/R/print.specaccum.R 2013-03-04 13:25:36 UTC (rev 2462) +++ pkg/vegan/R/print.specaccum.R 2013-03-04 17:05:14 UTC (rev 2463) @@ -1,4 +1,4 @@ -"print.specaccum" <- +`print.specaccum` <- function(x, ...) { cat("Species Accumulation Curve\n") @@ -8,9 +8,9 @@ } cat("\n") cat("Call:", deparse(x$call), "\n\n") - mat <- rbind(Sites = x$sites, Effort = x$effort, Richness = x$richness, - sd=x$sd) + mat <- rbind(Sites = x$sites, Individuals = x$individuals, Effort = x$effort, + Richness = x$richness, sd=x$sd) colnames(mat) <- rep("", ncol(mat)) - print(mat) + print(zapsmall(mat)) invisible(x) } From noreply at r-forge.r-project.org Mon Mar 4 18:11:23 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 4 Mar 2013 18:11:23 +0100 (CET) Subject: [Vegan-commits] r2464 - pkg/vegan/R Message-ID: <20130304171123.6B020184AD4@r-forge.r-project.org> Author: jarioksa Date: 2013-03-04 18:11:23 +0100 (Mon, 04 Mar 2013) New Revision: 2464 Modified: pkg/vegan/R/print.specaccum.R Log: print if specaccum() was weighted Modified: pkg/vegan/R/print.specaccum.R =================================================================== --- pkg/vegan/R/print.specaccum.R 2013-03-04 17:05:14 UTC (rev 2463) +++ pkg/vegan/R/print.specaccum.R 2013-03-04 17:11:23 UTC (rev 2464) @@ -6,6 +6,8 @@ if (x$method == "random") { cat(", with ", ncol(x$perm), " permutations", sep="") } + if (!is.null(x$weights)) + cat(", weighted") cat("\n") cat("Call:", deparse(x$call), "\n\n") mat <- rbind(Sites = x$sites, Individuals = x$individuals, Effort = x$effort, From noreply at r-forge.r-project.org Mon Mar 4 18:19:04 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 4 Mar 2013 18:19:04 +0100 (CET) Subject: [Vegan-commits] r2465 - pkg/vegan/R Message-ID: <20130304171904.7F64D184EB3@r-forge.r-project.org> Author: jarioksa Date: 2013-03-04 18:19:04 +0100 (Mon, 04 Mar 2013) New Revision: 2465 Modified: pkg/vegan/R/specaccum.R Log: match method name before using, and weighted method = 'collector' returns effort Modified: pkg/vegan/R/specaccum.R =================================================================== --- pkg/vegan/R/specaccum.R 2013-03-04 17:11:23 UTC (rev 2464) +++ pkg/vegan/R/specaccum.R 2013-03-04 17:19:04 UTC (rev 2465) @@ -2,6 +2,8 @@ function (comm, method = "exact", permutations = 100, conditioned=TRUE, gamma="jack1", w = NULL, ...) { + METHODS <- c("collector", "random", "exact", "rarefaction", "coleman") + method <- match.arg(method, METHODS) if (!is.null(w) && !(method %in% c("random", "collector"))) stop(gettextf("weights 'w' can be only used with methods 'random' and 'collector'")) x <- comm @@ -17,14 +19,12 @@ accumulator <- function(x, ind) { rowSums(apply(x[ind, ], 2, cumsum) > 0) } - METHODS <- c("collector", "random", "exact", "rarefaction", "coleman") - method <- match.arg(method, METHODS) specaccum <- sdaccum <- sites <- perm <- NULL if (n == 1 && method != "rarefaction") message("No actual accumulation since only 1 site provided") switch(method, collector = { sites <- 1:n - weights <- cumsum(w) + xout <- weights <- cumsum(w) specaccum <- accumulator(x, sites) }, random = { perm <- array(dim = c(n, permutations)) From noreply at r-forge.r-project.org Mon Mar 4 18:58:10 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 4 Mar 2013 18:58:10 +0100 (CET) Subject: [Vegan-commits] r2466 - pkg/vegan/man Message-ID: <20130304175810.B75B91841D7@r-forge.r-project.org> Author: jarioksa Date: 2013-03-04 18:58:10 +0100 (Mon, 04 Mar 2013) New Revision: 2466 Modified: pkg/vegan/man/specaccum.Rd Log: expand documenation of weights in specaccum Modified: pkg/vegan/man/specaccum.Rd =================================================================== --- pkg/vegan/man/specaccum.Rd 2013-03-04 17:19:04 UTC (rev 2465) +++ pkg/vegan/man/specaccum.Rd 2013-03-04 17:58:10 UTC (rev 2466) @@ -105,8 +105,28 @@ achieves this by applying function \code{\link{rarefy}} with number of individuals corresponding to average number of individuals per site. - The function has a \code{plot} method. In addition, \code{method = "random"} - has \code{summary} and \code{boxplot} methods. + Methods \code{"random"} and \code{"collector"} can take weights + (\code{w}) that give the sampling effort for each site. The weights + \code{w} do not influence the order the sites are accumulated, but + only the value of the sampling effort so that not all sites are + equal. The summary results are expressed against sites even when the + accumulation uses weights (methods \code{"random"}, + \code{"collector"}), or is based on individuals + (\code{"rarefaction"}). The actual sampling effort is given as item + \code{Effort} or \code{Individuals} in the printed result. For + weighted \code{"random"} method the effort refers to the average + effort per site, or sum of weights per number of sites. With + weighted \code{method = "random"}, the averaged species richness is + found from linear interpolation of single random permutations. + Therefore at least the first value (and often several first) have + \code{NA} richness, because these values cannot be interpolated in + all cases but should be extrapolated. The \code{plot} function + defaults to display the results as scaled to sites, but this can be + changed selecting \code{xvar = "effort"} (weighted methods) or + \code{xvar = "individuals"} (with \code{method = "rarefaction"}). + + The \code{summary} and \code{boxplot} methods are available for + \code{method = "random"}. Function \code{predict} can return the values corresponding to \code{newdata} using linear (\code{\link{approx}}) or spline @@ -132,8 +152,13 @@ (\code{\link{SSgompertz}}), \code{"michaelis-menten"}) (\code{\link{SSmicmen}}), \code{"logis"} (\code{\link{SSlogis}}), \code{"weibull"} (\code{\link{SSweibull}}). See these functions for - model specification and details. + model specification and details. + When weights \code{w} were used the fit is based on accumulated + effort and in \code{model = "rarefaction"} on accumulated number of + individuals. The \code{plot} is still based on sites, unless other + alternative is selected with \code{xvar}. + Function \code{predict} uses \code{\link{predict.nls}}, and you can pass all arguments to that function. In addition, \code{fitted}, \code{residuals} and \code{coef} work on the result object. From noreply at r-forge.r-project.org Mon Mar 4 19:33:14 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 4 Mar 2013 19:33:14 +0100 (CET) Subject: [Vegan-commits] r2467 - pkg/vegan/tests/Examples Message-ID: <20130304183314.8E3A9184AD4@r-forge.r-project.org> Author: jarioksa Date: 2013-03-04 19:33:14 +0100 (Mon, 04 Mar 2013) New Revision: 2467 Modified: pkg/vegan/tests/Examples/vegan-Ex.Rout.save Log: update examples for specaccum Modified: pkg/vegan/tests/Examples/vegan-Ex.Rout.save =================================================================== --- pkg/vegan/tests/Examples/vegan-Ex.Rout.save 2013-03-04 17:58:10 UTC (rev 2466) +++ pkg/vegan/tests/Examples/vegan-Ex.Rout.save 2013-03-04 18:33:14 UTC (rev 2467) @@ -23,7 +23,7 @@ > options(warn = 1) > library('vegan') Loading required package: permute -This is vegan 2.1-26 +This is vegan 2.1-27 > > assign(".oldSearch", search(), pos = 'CheckExEnv') > cleanEx() @@ -161,7 +161,7 @@ Formula: y ~ poly(x1, 1) + poly(x2, 1) - + Total model degrees of freedom 3 GCV score: 0.04278782 @@ -4908,7 +4908,7 @@ Formula: y ~ s(x1, x2, k = knots) - + Estimated degrees of freedom: 6.45 total = 7.45 @@ -4924,7 +4924,7 @@ Formula: y ~ s(x1, x2, k = knots) - + Estimated degrees of freedom: 6.12 total = 7.12 @@ -5092,7 +5092,7 @@ Formula: y ~ s(x1, x2, k = knots) - + Estimated degrees of freedom: 8.93 total = 9.93 @@ -5105,7 +5105,7 @@ Formula: y ~ s(x1, x2, k = knots) - + Estimated degrees of freedom: 7.75 total = 8.75 @@ -5118,7 +5118,7 @@ Formula: y ~ s(x1, x2, k = knots) - + Estimated degrees of freedom: 8.9 total = 9.9 @@ -6555,8 +6555,8 @@ > ### Name: specaccum > ### Title: Species Accumulation Curves > ### Aliases: specaccum print.specaccum summary.specaccum plot.specaccum -> ### boxplot.specaccum fitspecaccum plot.fitspecaccum predict.specaccum -> ### predict.fitspecaccum +> ### lines.specaccum boxplot.specaccum fitspecaccum plot.fitspecaccum +> ### lines.fitspecaccum predict.specaccum predict.fitspecaccum > ### Keywords: univar models > > ### ** Examples @@ -6570,42 +6570,34 @@ Accumulation method: random, with 100 permutations Call: specaccum(comm = BCI, method = "random") - -Sites 1.00000 2.000000 3.000000 4.000000 5.000000 6.000000 -Richness 91.34000 121.010000 138.720000 150.540000 159.540000 166.500000 -sd 7.21001 6.928925 6.748109 6.509387 6.125654 5.934831 - -Sites 7.000000 8.000000 9.000000 10.000000 11.000000 12.000000 -Richness 171.820000 176.180000 179.790000 182.730000 185.950000 188.590000 -sd 5.603714 5.182293 5.129229 5.175418 4.719131 4.521766 - -Sites 13.000000 14.000000 15.000000 16.000000 17.000000 18.000000 -Richness 191.080000 193.100000 194.920000 196.870000 198.270000 199.670000 -sd 4.421435 4.372781 4.527536 4.421378 4.287296 4.032832 - -Sites 19.000000 20.000000 21.000000 22.000000 23.000000 24.000000 -Richness 201.000000 202.470000 203.950000 205.180000 206.210000 207.230000 -sd 4.005047 3.968194 3.952687 3.774931 3.682596 3.700546 - -Sites 25.000000 26.000000 27.000000 28.000000 29.000000 30.000000 -Richness 208.380000 209.390000 210.540000 211.430000 212.290000 213.230000 -sd 3.323561 3.323911 3.316381 3.156699 3.098696 2.957118 - -Sites 31.000000 32.000000 33.000000 34.000000 35.000000 36.000000 -Richness 214.100000 214.880000 215.620000 216.370000 217.000000 217.550000 -sd 2.761569 2.575251 2.529742 2.588455 2.486326 2.371442 - -Sites 37.000000 38.000000 39.000000 40.000000 41.000000 42.000000 -Richness 218.160000 218.770000 219.340000 219.970000 220.600000 221.210000 -sd 2.364382 2.210421 2.041093 2.071719 1.964328 1.945183 - -Sites 43.000000 44.00000 45.00 46.000000 47.000000 48.0000000 -Richness 221.850000 222.36000 222.89 223.320000 223.710000 224.1700000 -sd 1.771691 1.58605 1.49 1.476277 1.208514 0.9749903 - -Sites 49.0000000 50 -Richness 224.6500000 225 -sd 0.6092718 0 + +Sites 1.00000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 +Richness 91.34000 121.01000 138.72000 150.54000 159.54000 166.50000 171.82000 +sd 7.21001 6.92892 6.74811 6.50939 6.12565 5.93483 5.60371 + +Sites 8.00000 9.00000 10.00000 11.00000 12.00000 13.00000 14.00000 +Richness 176.18000 179.79000 182.73000 185.95000 188.59000 191.08000 193.10000 +sd 5.18229 5.12923 5.17542 4.71913 4.52177 4.42144 4.37278 + +Sites 15.00000 16.00000 17.0000 18.00000 19.00000 20.00000 21.00000 +Richness 194.92000 196.87000 198.2700 199.67000 201.00000 202.47000 203.95000 +sd 4.52754 4.42138 4.2873 4.03283 4.00505 3.96819 3.95269 + +Sites 22.00000 23.0000 24.00000 25.00000 26.00000 27.00000 28.0000 +Richness 205.18000 206.2100 207.23000 208.38000 209.39000 210.54000 211.4300 +sd 3.77493 3.6826 3.70055 3.32356 3.32391 3.31638 3.1567 + +Sites 29.0000 30.00000 31.00000 32.00000 33.00000 34.00000 35.00000 +Richness 212.2900 213.23000 214.10000 214.88000 215.62000 216.37000 217.00000 +sd 3.0987 2.95712 2.76157 2.57525 2.52974 2.58846 2.48633 + +Sites 36.00000 37.00000 38.00000 39.00000 40.00000 41.00000 42.00000 +Richness 217.55000 218.16000 218.77000 219.34000 219.97000 220.60000 221.21000 +sd 2.37144 2.36438 2.21042 2.04109 2.07172 1.96433 1.94518 + +Sites 43.00000 44.00000 45.00 46.00000 47.00000 48.00000 49.00000 50 +Richness 221.85000 222.36000 222.89 223.32000 223.71000 224.17000 224.65000 225 +sd 1.77169 1.58605 1.49 1.47628 1.20851 0.97499 0.60927 0 > summary(sp2) 1 sites 2 sites 3 sites 4 sites Min. : 77.00 Min. :105.0 Min. :123.0 Min. :135.0 @@ -7692,7 +7684,7 @@ Formula: y ~ s(x1, x2, k = knots) - + Estimated degrees of freedom: 2 total = 3 @@ -8244,7 +8236,7 @@ > ### *