From noreply at r-forge.r-project.org Mon May 11 12:58:49 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 11 May 2015 12:58:49 +0200 (CEST) Subject: [Vegan-commits] r2946 - in pkg/vegan: R man Message-ID: <20150511105849.ACC55187859@r-forge.r-project.org> Author: jarioksa Date: 2015-05-11 12:58:49 +0200 (Mon, 11 May 2015) New Revision: 2946 Added: pkg/vegan/man/ordiArrowTextXY.Rd Modified: pkg/vegan/R/ordiArrowMul.R pkg/vegan/R/ordiArrowTextXY.R pkg/vegan/R/pcnm.R pkg/vegan/R/rarefy.R pkg/vegan/man/diversity.Rd pkg/vegan/man/envfit.Rd Log: Merge branch 'cran-2.2' into r-forge-svn-local Modified: pkg/vegan/R/ordiArrowMul.R =================================================================== --- pkg/vegan/R/ordiArrowMul.R 2015-04-20 06:46:45 UTC (rev 2945) +++ pkg/vegan/R/ordiArrowMul.R 2015-05-11 10:58:49 UTC (rev 2946) @@ -1,19 +1,33 @@ ### Scaling of arrows to 'fill' a plot with vectors centred at 'at'. ### Plot dims from 'par("usr")' and arrow heads are in 'x'. -`ordiArrowMul` <- - function (x, at = c(0,0), fill=0.75) -{ +`ordiArrowMul` <- function (x, at = c(0,0), fill = 0.75, + display, choices = c(1,2), ...) { + ## handle x, which we try with scores, but also retain past usage of + ## a two column matrix + X <- if (is.matrix(x)) { + nc <- NCOL(x) + if (nc != 2L) { + stop("A 2-column matrix of coordinates is required & not supplied.") + } + x + } else { + if (inherits(x, "envfit")) { + scores(x, display = "vectors", ...)[, 1:2] + } else { + scores(x, display = display, choices = choices, ...) + } + } + u <- par("usr") u <- u - rep(at, each = 2) - r <- c(range(x[,1], na.rm = TRUE), range(x[,2], na.rm = TRUE)) + r <- c(range(X[,1], na.rm = TRUE), range(X[,2], na.rm = TRUE)) ## 'rev' takes care of reversed axes like xlim(1,-1) rev <- sign(diff(u))[-2] if (rev[1] < 0) u[1:2] <- u[2:1] if (rev[2] < 0) u[3:4] <- u[4:3] - u <- u/r + u <- u/r u <- u[is.finite(u) & u > 0] fill * min(u) } - Modified: pkg/vegan/R/ordiArrowTextXY.R =================================================================== --- pkg/vegan/R/ordiArrowTextXY.R 2015-04-20 06:46:45 UTC (rev 2945) +++ pkg/vegan/R/ordiArrowTextXY.R 2015-05-11 10:58:49 UTC (rev 2946) @@ -2,17 +2,53 @@ ### 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 (x, labels, ...) -{ +`ordiArrowTextXY` <- function (x, labels, display, choices = c(1,2), + rescale = TRUE, fill = 0.75, ...) { + ## handle x, which we try with scores, but also retain past usage of + ## a two column matrix + X <- if (is.matrix(x)) { + nc <- NCOL(x) + if (nc != 2L) { + stop("A 2-column matrix of coordinates is required & not supplied.") + } + x + } else { + if (inherits(x, "envfit")) { + scores(x, display = "vectors", ...)[, 1:2] + } else { + scores(x, display = display, choices = choices, ...) + } + if (!rescale) { + warning("Extracted scores usually need rescaling but you set 'rescale = FALSE'.\nConsider using 'rescale = TRUE', the default.") + } + } + + ## find multiplier to fill if rescaling + if (rescale) { + mul <- ordiArrowMul(X, fill = fill) + X <- X * mul + } + + if (missing(labels)) { + rnames <- rownames(X) + labels <- if (is.null(rnames)) { + paste("V", seq_len(NROW(X))) + } else { + rnames + } + } + w <- strwidth(labels, ...) h <- strheight(labels, ...) + ## slope of arrows - b <- x[,2]/x[,1] + b <- X[,2] / X[,1] + ## offset based on string dimensions - off <- cbind(sign(x[,1]) * (w/2 + h/4), 0.75 * h * sign(x[,2])) + off <- cbind(sign(X[,1]) * (w/2 + h/4), 0.75 * h * sign(X[,2])) + ## move the centre of the string to the continuation of the arrow - for(i in seq_len(nrow(x))) { + for(i in seq_len(nrow(X))) { 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])) @@ -23,5 +59,5 @@ off[i, 2] <- move } } - off + x + off + X } Modified: pkg/vegan/R/pcnm.R =================================================================== --- pkg/vegan/R/pcnm.R 2015-04-20 06:46:45 UTC (rev 2945) +++ pkg/vegan/R/pcnm.R 2015-05-11 10:58:49 UTC (rev 2946) @@ -1,6 +1,11 @@ -`pcnm` <- - function(dis, threshold, w, dist.ret = FALSE) -{ +`pcnm` <- function(dis, threshold, w, dist.ret = FALSE) { + if (!inherits(dis, "dist")) { + dims <- dim(dis) + if (length(unique(dims)) >1) { + stop("'dis' does not appear to be a square distance matrix.") + } + dis <- as.dist(dis) + } EPS <- sqrt(.Machine$double.eps) wa.old <- options(warn = -1) on.exit(options(wa.old)) @@ -16,7 +21,7 @@ res <- list(vectors = mypcnm$points, values = mypcnm$eig, weights = mypcnm$weig) k <- ncol(mypcnm$points) - res$vectors <- sweep(res$vectors, 2, sqrt(res$values[1:k]), "/") + res$vectors <- sweep(res$vectors, 2, sqrt(res$values[seq_len(k)]), "/") colnames(res$vectors) <- paste("PCNM", 1:k, sep="") res$threshold <- threshold if (dist.ret) { Modified: pkg/vegan/R/rarefy.R =================================================================== --- pkg/vegan/R/rarefy.R 2015-04-20 06:46:45 UTC (rev 2945) +++ pkg/vegan/R/rarefy.R 2015-05-11 10:58:49 UTC (rev 2946) @@ -2,6 +2,11 @@ function (x, sample, se = FALSE, MARGIN = 1) { x <- as.matrix(x) + minsample <- min(apply(x, MARGIN, sum)) + if (any(sample > minsample)) + warning( + gettextf("Requested 'sample' was larger than smallest site maximum (%d)", + minsample)) ## as.matrix changes an n-vector to a n x 1 matrix if (ncol(x) == 1 && MARGIN == 1) x <- t(x) Modified: pkg/vegan/man/diversity.Rd =================================================================== --- pkg/vegan/man/diversity.Rd 2015-04-20 06:46:45 UTC (rev 2945) +++ pkg/vegan/man/diversity.Rd 2015-05-11 10:58:49 UTC (rev 2946) @@ -60,9 +60,9 @@ Function \code{rarefy} gives the expected species richness in random subsamples of size \code{sample} from the community. The size of \code{sample} should be smaller than total community size, but the - function will silently work for larger \code{sample} as well and - return non-rarefied species richness (and standard error = 0). If - \code{sample} is a vector, rarefaction of all observations is + function will work for larger \code{sample} as well (with a warning) + and return non-rarefied species richness (and standard error = + 0). If \code{sample} is a vector, rarefaction of all observations is performed for each sample size separately. Rarefaction can be performed only with genuine counts of individuals. The function \code{rarefy} is based on Hurlbert's (1971) formulation, and the Modified: pkg/vegan/man/envfit.Rd =================================================================== --- pkg/vegan/man/envfit.Rd 2015-04-20 06:46:45 UTC (rev 2945) +++ pkg/vegan/man/envfit.Rd 2015-05-11 10:58:49 UTC (rev 2946) @@ -7,8 +7,6 @@ \alias{plot.envfit} \alias{scores.envfit} \alias{labels.envfit} -\alias{ordiArrowMul} -\alias{ordiArrowTextXY} \title{Fits an Environmental Vector or Factor onto an Ordination } \description{ @@ -26,9 +24,6 @@ \method{scores}{envfit}(x, display, choices, ...) vectorfit(X, P, permutations = 0, strata = NULL, w, ...) factorfit(X, P, permutations = 0, strata = NULL, w, ...) -## support functions -ordiArrowMul(x, at = c(0,0), fill = 0.75) -ordiArrowTextXY(x, labels, ...) } \arguments{ @@ -95,9 +90,6 @@ \item{w}{Weights used in fitting (concerns mainly \code{\link{cca}} and \code{\link{decorana}} results which have nonconstant weights).} - \item{fill}{numeric; the proportion of the plot to fill by the span of - the arrows.} - \item{...}{Parameters passed to \code{\link{scores}}.} } \details{ @@ -162,13 +154,9 @@ for the physical size of the plot, and the arrow lengths cannot be compared across plots. For similar scaling of arrows, you must explicitly set the \code{arrow.mul} argument in the \code{plot} - command. \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. NB., - \code{ordiArrowTextXY} does not draw labels; it simply returns - coordinates at which the labels should be drawn for use with another - function, such as \code{\link{text}}. - + command; see \code{\link{ordiArrowMul}} and + \code{\link{ordiArrowTextXY}}. + The results can be accessed with \code{scores.envfit} function which returns either the fitted vectors scaled by correlation coefficient or the centroids of the fitted environmental variables. @@ -231,22 +219,7 @@ plot(ord, type="p") fit <- envfit(ord, varechem, perm = 999, display = "lc") plot(fit, p.max = 0.05, col = "red") -## Scale arrows by hand to fill 80% of the plot -## Biplot arrows by hand -data(varespec, varechem) -ord <- cca(varespec ~ Al + P + K, varechem) -plot(ord, display = c("species","sites")) -## biplot scores -bip <- scores(ord, choices = 1:2, display = "bp") -## scaling factor for arrows to fill 80% of plot -(mul <- ordiArrowMul(bip, fill = 0.8)) -bip.scl <- bip * mul # Scale the biplot scores -labs <- c("Al","P","K") # Arrow labels -## calculate coordinate of labels for arrows -(bip.lab <- ordiArrowTextXY(bip.scl, labels = labs)) -## draw arrows and text labels -arrows(0, 0, bip.scl[,1], bip.scl[,2], length = 0.1) -text(bip.lab, labels = labs) + ## Class variables, formula interface, and displaying the ## inter-class variability with `ordispider', and semitransparent ## white background for labels (semitransparent colours are not @@ -265,6 +238,7 @@ plot(ord) plot(fit, labels=list(factors = paste("M", c(1,2,4,5), sep = "")), bg = rgb(1,1,0,0.5)) +detach(dune.env) } \keyword{multivariate } \keyword{aplot} Added: pkg/vegan/man/ordiArrowTextXY.Rd =================================================================== --- pkg/vegan/man/ordiArrowTextXY.Rd (rev 0) +++ pkg/vegan/man/ordiArrowTextXY.Rd 2015-05-11 10:58:49 UTC (rev 2946) @@ -0,0 +1,109 @@ +\name{ordiArrowTextXY} +\alias{ordiArrowMul} +\alias{ordiArrowTextXY} + +\title{Support Functions for Drawing Vectors} +\description{ + Support functions to assist with drawing of vectors (arrows) on + ordination plots. \code{ordiArrowMul} finds the multiplier for the + coordinates of the head of the vector such that they accupy + \code{fill} proportion of the plot region. \code{ordiArrowTextXY} + finds coordinates for the locations of \code{labels} to be drawn just + beyond the head of the vector. +} +\usage{ +ordiArrowTextXY(x, labels, display, choices = c(1,2), + rescale = TRUE, fill = 0.75, \ldots) +ordiArrowMul(x, at = c(0,0), fill = 0.75, + display, choices = c(1,2), \ldots) +} + +\arguments{ + \item{x}{An R object, from which \code{\link{scores}} can determine + suitable ordination scores or an object created by + \code{\link{envfit}}, or a two-column matrix of coordinates of arrow + heads on the two plot axes.} + + \item{labels}{Change plotting labels. A character vector of labels for + which label coordinates are sought. If not supplied, these will be + determined from the row names of \code{x}, or \code{scores(x, ...)} + if required. If either of these are not defined, suitable labels + will be generated.} + + \item{display}{a character string known to \code{\link{scores}} or one + of its methods which indicates the type of scores to extract. In + fitting functions these are ordinary site scores or linear + combination scores (\code{"lc"}) in constrained ordination + (\code{\link{cca}}, \code{\link{rda}}, \code{\link{capscale}}). If + \code{x} was created by \code{envfit} then \code{display} can not be + set by the user and takes the value \code{"vectors"}. Ignored if + \code{x} is a matrix.} + + \item{choices}{Axes to be plotted.} + + \item{rescale}{logical; should the coordinates in or extracted from + \code{x} be rescaled to fill \code{fill} proportion of the plot + region? The default is to always rescale the coordinates as this is + usually desired for objects \code{x} from which coordinates are + retrieved. If supplying \code{x} a 2-column matrix that has already + been rescaled, then set this to \code{FALSE}.} + + \item{fill}{numeric; the proportion of the plot to fill by the span of + the arrows.} + + \item{at}{The origin of fitted arrows in the plot. If you plot arrows + in other places than origin, you probably have to specify + \code{arrrow.mul}.} + + \item{...}{Parameters passed to \code{\link{scores}}, and + \code{\link{strwidth}} and \code{\link{strheight}}.} +} + +\details{ + \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. NB., + \code{ordiArrowTextXY} does not draw labels; it simply returns + coordinates at which the labels should be drawn for use with another + function, such as \code{\link{text}}. +} + +\value{ + For \code{ordiArrowTextXY}, a 2-column matrix of coordinates for the + label centres in the coordinate system of the currently active + plotting device. + + For \code{ordiArrowMul}, a length-1 vector containing the scaling + factor. +} + +\author{Jari Oksanen, with modifications by Gavin L. Simpson} + +\examples{ + ## Scale arrows by hand to fill 80% of the plot + ## Biplot arrows by hand + data(varespec, varechem) + ord <- cca(varespec ~ Al + P + K, varechem) + plot(ord, display = c("species","sites")) + + ## biplot scores + bip <- scores(ord, choices = 1:2, display = "bp") + + ## scaling factor for arrows to fill 80% of plot + (mul <- ordiArrowMul(bip, fill = 0.8)) + bip.scl <- bip * mul # Scale the biplot scores + labs <- rownames(bip) # Arrow labels + + ## calculate coordinate of labels for arrows + (bip.lab <- ordiArrowTextXY(bip.scl, rescale = FALSE, labels = labs)) + + ## draw arrows and text labels + arrows(0, 0, bip.scl[,1], bip.scl[,2], length = 0.1) + text(bip.lab, labels = labs) + + ## Handling of ordination objects directly + mul2 <- ordiArrowMul(ord, display = "bp", fill = 0.8) + stopifnot(all.equal(mul, mul2)) +} + +\keyword{utilities} \ No newline at end of file From noreply at r-forge.r-project.org Wed May 20 14:03:36 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 20 May 2015 14:03:36 +0200 (CEST) Subject: [Vegan-commits] r2947 - in pkg/vegan: . R inst man Message-ID: <20150520120336.80C1F187A59@r-forge.r-project.org> Author: jarioksa Date: 2015-05-20 14:03:35 +0200 (Wed, 20 May 2015) New Revision: 2947 Added: pkg/vegan/R/rareslope.R pkg/vegan/R/specslope.R Modified: pkg/vegan/NAMESPACE pkg/vegan/R/fitspecaccum.R pkg/vegan/R/plot.specaccum.R pkg/vegan/R/predict.fitspecaccum.R pkg/vegan/R/predict.specaccum.R pkg/vegan/R/print.specaccum.R pkg/vegan/R/specaccum.R pkg/vegan/inst/NEWS.Rd pkg/vegan/man/diversity.Rd pkg/vegan/man/specaccum.Rd Log: Merge branch 'cran-2.2' into r-forge-svn-local Modified: pkg/vegan/NAMESPACE =================================================================== --- pkg/vegan/NAMESPACE 2015-05-11 10:58:49 UTC (rev 2946) +++ pkg/vegan/NAMESPACE 2015-05-20 12:03:35 UTC (rev 2947) @@ -22,10 +22,10 @@ orditkplot, orditorp, ordixyplot, pcnm, permatfull, permatswap, permustats, permutest, poolaccum, postMDS, prc, prestondistr, prestonfit, procrustes, -protest, radfit, radlattice, rankindex, rarefy, rarecurve, raupcrick, -rda, renyiaccum, renyi, rrarefy, scores, -showvarparts, simper, spandepth, -spantree, specaccum, specnumber, specpool2vect, specpool, spenvcor, +protest, radfit, radlattice, rankindex, rarefy, rarecurve, rareslope, +raupcrick, rda, renyiaccum, renyi, rrarefy, scores, +showvarparts, simper, spandepth, spantree, specaccum, specslope, +specnumber, specpool2vect, specpool, spenvcor, stepacross, stressplot, swan, tabasco, taxa2dist, taxondive, tolerance, treedist, treedive, treeheight, tsallisaccum, tsallis, varpart, vectorfit, vegandocs, vegdist, vegemite, veiledspec, wascores, @@ -87,6 +87,7 @@ S3method(adipart, default) S3method(adipart, formula) # AIC: stats +S3method(AIC, fitspecaccum) S3method(AIC, radfit) S3method(AIC, radfit.frame) # RsquareAdj: vegan @@ -159,6 +160,7 @@ S3method(deviance, rda) S3method(deviance, radfit) S3method(deviance, radfit.frame) +S3method(deviance, fitspecaccum) # drop1: stats S3method(drop1, cca) # eigenvals: vegan @@ -442,6 +444,9 @@ S3method(simulate, cca) S3method(simulate, rda) S3method(simulate, nullmodel) +# specslope: vegan +S3method(specslope, specaccum) +S3method(specslope, fitspecaccum) # str: utils S3method(str, nullmodel) # stressplot: vegan Modified: pkg/vegan/R/fitspecaccum.R =================================================================== --- pkg/vegan/R/fitspecaccum.R 2015-05-11 10:58:49 UTC (rev 2946) +++ pkg/vegan/R/fitspecaccum.R 2015-05-20 12:03:35 UTC (rev 2947) @@ -16,6 +16,12 @@ else x <- object$sites hasWeights <- !is.null(object$weights) + ## scale weights to correspond to the no. of sites + if (hasWeights) { + w <- as.matrix(object$weights) + n <- nrow(w) + w <- sweep(w, 2, w[n,], "/") * n + } NLSFUN <- function(y, x, model, ...) { switch(model, "arrhenius" = nls(y ~ SSarrhenius(x, k, z), ...), @@ -31,11 +37,12 @@ mods <- lapply(seq_len(NCOL(SpeciesRichness)), function(i, ...) NLSFUN(SpeciesRichness[,i], - if (hasWeights) object$weights[,i] else x, + if (hasWeights) w[,i] else x, model, ...), ...) object$fitted <- drop(sapply(mods, fitted)) object$residuals <- drop(sapply(mods, residuals)) object$coefficients <- drop(sapply(mods, coef)) + object$SSmodel <- model object$models <- mods object$call <- match.call() class(object) <- c("fitspecaccum", class(object)) @@ -51,7 +58,7 @@ if (is.null(x$weights)) fv <- fitted(x) else - fv <- sapply(x$models, predict, newdata = list(x = x$effort)) + fv <- sapply(x$models, predict, newdata = list(x = x$sites)) matplot(x$sites, fv, col = col, lty = lty, pch = NA, xlab = xlab, ylab = ylab, type = "l", ...) invisible() @@ -63,7 +70,7 @@ if (is.null(x$weights)) fv <- fitted(x) else - fv <- sapply(x$models, predict, newdata= list(x = x$effort)) + fv <- sapply(x$models, predict, newdata= list(x = x$sites)) matlines(x$sites, fv, col = col, lty = lty, pch = NA, type = "l", ...) invisible() } Modified: pkg/vegan/R/plot.specaccum.R =================================================================== --- pkg/vegan/R/plot.specaccum.R 2015-05-11 10:58:49 UTC (rev 2946) +++ pkg/vegan/R/plot.specaccum.R 2015-05-20 12:03:35 UTC (rev 2947) @@ -4,8 +4,10 @@ ci.lty = 1, xlab, ylab = x$method, ylim, xvar = c("sites", "individuals", "effort"), ...) { - if(random && x$method != "random") + if(random && !(x$method %in% c("random", "collector"))) stop("random = TRUE can be used only with method='random'") + if(x$method == "collector") + random <- TRUE xvar <- match.arg(xvar) ## adjust weights to number of sites if (random && !is.null(x$weights) && xvar == "sites") { Modified: pkg/vegan/R/predict.fitspecaccum.R =================================================================== --- pkg/vegan/R/predict.fitspecaccum.R 2015-05-11 10:58:49 UTC (rev 2946) +++ pkg/vegan/R/predict.fitspecaccum.R 2015-05-20 12:03:35 UTC (rev 2947) @@ -1,3 +1,7 @@ +### fitspecaccum returns fitted nls() models in item models. Here we +### provide interfaces for some "nls" class support functions, and +### others can be used in the similar way. + `predict.fitspecaccum` <- function(object, newdata, ...) { @@ -11,3 +15,15 @@ drop(sapply(mods, predict, ...)) } } + +`AIC.fitspecaccum` <- + function(object, ..., k = 2) +{ + sapply(object$models, AIC, k = k, ...) +} + +`deviance.fitspecaccum` <- + function(object, ...) +{ + sapply(object$models, deviance, ...) +} Modified: pkg/vegan/R/predict.specaccum.R =================================================================== --- pkg/vegan/R/predict.specaccum.R 2015-05-11 10:58:49 UTC (rev 2946) +++ pkg/vegan/R/predict.specaccum.R 2015-05-20 12:03:35 UTC (rev 2947) @@ -8,12 +8,43 @@ newdata <- drop(as.matrix(newdata)) if (length(dim(newdata)) > 1) stop("function accepts only one variable as 'newdata'") - if (interpolation == "linear") - out <- approx(x = object$sites, y = object$richness, - xout = newdata, rule = 1)$y - else - out <- spline(x = object$sites, y = object$richness, - xout = newdata, ...)$y + ## Estimation uses lchoose(), but for predict we need to + ## estimates on non-integer sample sizes and therefore we use + ## lgamma(). Original "rarefaction" used sample sizes rounded + ## to integers, but here we can use non-integer data and hence + ## get different results. + if (object$method %in% c("exact", "rarefaction")) { + lg <- function(n, k) { + ifelse(k <= n, lgamma(pmax(n, 0) + 1) - lgamma(k+1) - + lgamma(pmax(n-k, 0) + 1), -Inf) + } + if (object$method == "exact") + n <- length(object$sites) + else { + n <- sum(object$freq) + newdata <- newdata / length(object$sites) * n + } + ldiv <- lg(n, newdata) + out <- numeric(length(ldiv)) + for(i in seq_along(newdata)) { + out[i] <- sum(1 - exp(lg(n-object$freq, newdata[i]) + - ldiv[i])) + } + } else if (object$method == "coleman") { + ## "coleman" also works on non-integer newdata + n <- length(object$sites) + out <- sapply(newdata, + function(x) sum(1 - (1 - x/n)^object$freq)) + } else { + ## Other methods do not accept non-integer newdata, but we + ## can interpolate + if (interpolation == "linear") + out <- approx(x = object$sites, y = object$richness, + xout = newdata, rule = 1)$y + else + out <- spline(x = object$sites, y = object$richness, + xout = newdata, ...)$y + } } out } Modified: pkg/vegan/R/print.specaccum.R =================================================================== --- pkg/vegan/R/print.specaccum.R 2015-05-11 10:58:49 UTC (rev 2946) +++ pkg/vegan/R/print.specaccum.R 2015-05-20 12:03:35 UTC (rev 2947) @@ -2,6 +2,8 @@ function(x, ...) { cat("Species Accumulation Curve\n") + if (inherits(x, "fitspecaccum")) + cat("Non-linear regression model:", x$SSmodel, "\n") cat("Accumulation method:", x$method) if (x$method == "random") { cat(", with ", ncol(x$perm), " permutations", sep="") Added: pkg/vegan/R/rareslope.R =================================================================== --- pkg/vegan/R/rareslope.R (rev 0) +++ pkg/vegan/R/rareslope.R 2015-05-20 12:03:35 UTC (rev 2947) @@ -0,0 +1,42 @@ +#' Slope of Rarefunction Curve at Given Sample Size +#' +#' Function evaluates the derivative of the rarefaction +#' function at given sample size. The derivative was +#' directly derived from the expression used in \code{rarefy}. +#' +#' @param x Community counts, either an integer vector for a single +#' site or a data frame or matrix with each row giving site vectors. +#' @param sample Sample sizes where the derivatives are evaluated; can +#' be real +#' +`rareslope` <- + function(x, sample) +{ + ## 'x' must be integers ('sample' need not be) + if (!identical(all.equal(x, round(x)), TRUE)) + stop("community data 'x' must be integers (counts)") + slope <- function(x, sample) { + x <- x[x>0] + J <- sum(x) + ## Replace Hurlbert's factorials with gamma() functions and do + ## some algebra for derivatives. NB., rarefy() does not use + ## factorials but lchoose directly. + d <- digamma(pmax(J-sample+1, 1)) - digamma(pmax(J-x-sample+1, 1)) + g <- lgamma(pmax(J-x+1, 1)) + lgamma(pmax(J-sample+1, 1)) - + lgamma(pmax(J-x-sample+1, 1)) - lgamma(J+1) + d <- d*exp(g) + sum(d[is.finite(d)]) + } + if (length(dim(x)) == 2) + out <- sapply(sample, function(n) apply(x, 1, slope, sample = n)) + else + out <- sapply(sample, function(n) slope(x, sample=n)) + out <- drop(out) + if (length(sample) > 1) { + if (is.matrix(out)) + colnames(out) <- paste0("N", sample) + else + names(out) <- paste0("N", sample) + } + out +} Modified: pkg/vegan/R/specaccum.R =================================================================== --- pkg/vegan/R/specaccum.R 2015-05-11 10:58:49 UTC (rev 2946) +++ pkg/vegan/R/specaccum.R 2015-05-20 12:03:35 UTC (rev 2947) @@ -30,11 +30,13 @@ sites <- 1:n xout <- weights <- cumsum(w) specaccum <- accumulator(x, sites) + perm <- as.matrix(specaccum) + weights <- as.matrix(weights) }, random = { permat <- getPermuteMatrix(permutations, n) perm <- apply(permat, 1, accumulator, x = x) if (!is.null(w)) - weights <- apply(permat, 1, function(i) cumsum(w[i])) + weights <- as.matrix(apply(permat, 1, function(i) cumsum(w[i]))) sites <- 1:n if (is.null(w)) { specaccum <- apply(perm, 1, mean) @@ -42,7 +44,7 @@ } else { sumw <- sum(w) xout <- seq(sumw/n, sumw, length.out = n) - intx <- sapply(seq_len(n), function(i) + intx <- sapply(seq_len(NCOL(perm)), function(i) approx(weights[,i], perm[,i], xout = xout)$y) specaccum <- apply(intx, 1, mean) sdaccum <- apply(intx, 1, sd) @@ -109,6 +111,9 @@ } if (method == "rarefaction") out$individuals <- ind + ## return 'freq' for methods that are solely defined by them + if (method %in% c("exact", "rarefaction", "coleman")) + out$freq <- freq if (method == "random") attr(out, "control") <- attr(permat, "control") class(out) <- "specaccum" Added: pkg/vegan/R/specslope.R =================================================================== --- pkg/vegan/R/specslope.R (rev 0) +++ pkg/vegan/R/specslope.R 2015-05-20 12:03:35 UTC (rev 2947) @@ -0,0 +1,95 @@ +#' The Slope of Species Accumulation Curve at Given Point +#' +#' Function evaluates the derivative of the species accumulation curve +#' for accumulation methods built upon analytic accumulation +#' methods. These methods are \code{exact}, \code{rarefaction} and +#' \code{coleman}. These methods can be evaluated at any sample size, +#' including non-integer values. For other methods, you must look at +#' the differences between consecutive steps, using +#' \code{diff(predict(mod))}. +#' +#' @param object \code{specaccum} result object fitted with methods +#' \code{"exact"}, \code{"rarefaction"} or \code{"coleman"}. +#' @param at The sample size (number of sites) at which the slope is +#' evaluated. This need not be an integer. + +`specslope` <- + function(object, at) +{ + UseMethod("specslope") +} + +`specslope.specaccum` <- + function(object, at) +{ + accepted <- c("exact", "rarefaction", "coleman") + if (!(object$method %in% accepted)) + stop("accumulation method must be one of: ", + paste(accepted, collapse=", ")) + ## Funcions should accept a vector of 'at', but usually they + ## don't. I don't care to change this, and therefore we check the + ## input. + if (length(at) > 1 && object$method %in% c("exact", "coleman")) + stop("'at' can only have a single value") + ## The following functions are completely defined by species + ## frequencies + f <- object$freq + n <- length(object$sites) + switch(object$method, + exact = { + d <- digamma(pmax(n-at+1, 1)) - digamma(pmax(n-f-at+1, 1)) + g <- lgamma(pmax(n-f+1,1)) + lgamma(pmax(n-at+1,1)) - + lgamma(pmax(n-f-at+1, 1)) - lgamma(n+1) + d <- d*exp(g) + sum(d[is.finite(d)]) + }, + rarefaction = { + ## fractional number of individuals at 'at', and slope + ## for adding whole site instead of one individual + rareslope(f, at/n*sum(f)) * sum(f)/n + }, + coleman = { + sum((1 - at/n)^f*f/(n - at)) + }) +} + +## Analytical derivatives for NLS regression models in fitspecaccum + +`specslope.fitspecaccum` <- + function(object, at) +{ + ## functions for single set of fitted parameters. Parameters are + ## given as a single vector 'p' as returned by coef(). Below a + ## table of original names of 'p': + + ## arrhenius, gitay, gleason: k slope + ## lomolino: Asym xmid slope + ## asymp: Asym RO lrc + ## gompertz: Asym b2 b3 + ## michaelis-menten: Vm K (function SSmicmen) + ## logis: Asym xmid scal + ## weibull: Asym Drop lrc pwr + slope <- + switch(object$SSmodel, + "arrhenius" = function(x,p) p[1]*x^(p[2]-1)*p[2], + "gitay" = function(x,p) 2*(p[1]+p[2]*log(x))*p[2]/x, + "gleason" = function(x,p) p[2]/x, + "lomolino" = function(x,p) p[1]*p[3]^log(p[2]/x)*log(p[3])/ + (1+p[3]^log(p[2]/x))^2/x, + "asymp" = function(x,p) (p[1]-p[2])*exp(p[3]-exp(p[3])*x), + "gompertz" = function(x,p) -p[1]*p[2]*p[3]^x* + log(p[3])*exp(-p[2]*p[3]^x), + "michaelis-menten" = function(x,p) p[1]*p[2]/(p[2]+x)^2, + "logis" = function(x,p) p[1]*exp((x-p[2])/p[3])/ + (1 + exp((x-p[2])/p[3]))^2/p[3], + "weibull" = function(x, p) p[2]*exp(p[3]-exp(p[3])*x^p[4])* + x^(p[4]-1)*p[4]) + ## Apply slope with fitted coefficients at 'at' + p <- coef(object) + if (is.matrix(p)) # several fitted models + out <- apply(p, 2, function(i) slope(at, i)) + else # single site drops to a vector + out <- slope(at, p) + names(out) <- NULL + out +} Modified: pkg/vegan/inst/NEWS.Rd =================================================================== --- pkg/vegan/inst/NEWS.Rd 2015-05-11 10:58:49 UTC (rev 2946) +++ pkg/vegan/inst/NEWS.Rd 2015-05-20 12:03:35 UTC (rev 2947) @@ -40,7 +40,7 @@ } } % windows - \subsection{NEW FEATURES}{ + \subsection{NEW FEATURES AND FUNCTIONS}{ \itemize{ \item \code{goodness} function for constrained ordination @@ -68,6 +68,38 @@ a vector graphics format which can be edited with several external programs, such as Illustrator and Inkscape. + \item Rarefaction curve (\code{rarecurve}) and species + accumulation models (\code{specaccum}, \code{fitspecaccum}) + gained new functions to estimate the slope of curve at given + location. Originally this was based on a response to an + \href{https://stat.ethz.ch/pipermail/r-sig-ecology/2015-May/005038.html}{R-SIG-ecology} + query. For rarefaction curves, the function is \code{rareslope}, + and for species accumulation models it is \code{specslope}. + + The functions are based on analytic equations, and can also be + evaluated at interpolated non-integer values. In + \code{specaccum} models the functions can be only evaluated for + analytic models \code{"exact"}, \code{"rarefaction"} and + \code{"coleman"}. With \code{"random"} and \code{"collector"} + methods you can only use finite differences + (\code{diff(fitted())}). Analytic functions for + slope are used for all non-linear regression models known to + \code{fitspecaccum}. + + \item Species accumulation models (\code{specaccum}) and + non-liner regression models for species accumulation + (\code{fitspecaccum}) work more consistently with weights. In + all cases, the models are defined using the number of sites as + independent variable, which with weights means that observations + can be non-integer numbers of virtual sites. The \code{predict} + models also use the number of sites with \code{newdata}, + and for analytic models they can estimate the expected values + for non-integer number of sites, and for non-analytic randomized + or collector models they can interpolate on non-integer values. + + \item \code{fitspecaccum} gained support functions \code{AIC} + and \code{deviance}. + \item The \code{varpart} plots of four-component models were redesigned following Legendre, Borcard & Roberts \emph{Ecology} 93, 1234--1240 (2012), and they use now four ellipses instead of Modified: pkg/vegan/man/diversity.Rd =================================================================== --- pkg/vegan/man/diversity.Rd 2015-05-11 10:58:49 UTC (rev 2946) +++ pkg/vegan/man/diversity.Rd 2015-05-20 12:03:35 UTC (rev 2947) @@ -5,6 +5,7 @@ \alias{rrarefy} \alias{drarefy} \alias{rarecurve} +\alias{rareslope} \alias{fisher.alpha} \alias{specnumber} @@ -20,6 +21,7 @@ drarefy(x, sample) rarecurve(x, step = 1, sample, xlab = "Sample Size", ylab = "Species", label = TRUE, col, lty, ...) +rareslope(x, sample) fisher.alpha(x, MARGIN = 1, ...) specnumber(x, groups, MARGIN = 1) } @@ -87,6 +89,10 @@ drawn at \code{sample} with horizontal lines for the rarefied species richnesses. + Function \code{rareslope} calculates the slope of \code{rarecurve} + (derivative of \code{rarefy}) at given \code{sample} size; the + \code{sample} need not be an integer. + \code{fisher.alpha} estimates the \eqn{\alpha} parameter of Fisher's logarithmic series (see \code{\link{fisherfit}}). The estimation is possible only for genuine Modified: pkg/vegan/man/specaccum.Rd =================================================================== --- pkg/vegan/man/specaccum.Rd 2015-05-11 10:58:49 UTC (rev 2946) +++ pkg/vegan/man/specaccum.Rd 2015-05-20 12:03:35 UTC (rev 2947) @@ -10,6 +10,9 @@ \alias{lines.fitspecaccum} \alias{predict.specaccum} \alias{predict.fitspecaccum} +\alias{AIC.fitspecaccum} +\alias{deviance.fitspecaccum} +\alias{specslope} \title{Species Accumulation Curves } \description{ @@ -30,6 +33,7 @@ ylab = x$method, ...) \method{predict}{specaccum}(object, newdata, interpolation = c("linear", "spline"), ...) \method{predict}{fitspecaccum}(object, newdata, ...) +specslope(object, at) } \arguments{ @@ -57,7 +61,8 @@ values are taken as \code{FALSE}.} \item{x}{A \code{specaccum} result object} \item{add}{Add to an existing graph.} - \item{random}{\dots} + \item{random}{Draw each random simulation separately instead of + drawing their average and confidence intervals.} \item{ci}{Multiplier used to get confidence intervals from standard deviation (standard error of the estimate). Value \code{ci = 0} suppresses drawing confidence intervals.} @@ -85,6 +90,9 @@ \item{interpolation}{Interpolation method used with \code{newdata}.} + \item{at}{Number of plots where the slope is evaluated. Can be a + real number.} + \item{...}{Other parameters to functions.} } \details{ @@ -108,9 +116,10 @@ deviation following Coleman et al. (1982). All these methods are based on sampling sites without replacement. In contrast, the \code{method = "rarefaction"} finds the expected species richness and - its standard deviation by sampling individuals instead of sites. It - achieves this by applying function \code{\link{rarefy}} with number of individuals - corresponding to average number of individuals per site. + its standard deviation by sampling individuals instead of sites. + It achieves this by applying function \code{\link{rarefy}} with + number of individuals corresponding to average number of individuals + per site. Methods \code{"random"} and \code{"collector"} can take weights (\code{w}) that give the sampling effort for each site. The weights @@ -135,13 +144,16 @@ 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 - (\code{\link{spline}}) interpolation. The function cannot - extrapolate with linear interpolation, and with spline the type and - sensibility of the extrapolation depends on argument \code{method} - which is passed to \code{\link{spline}}. If \code{newdata} is not - given, the function returns the values corresponding to the data. + Function \code{predict} for \code{specaccum} can return the values + corresponding to \code{newdata}. With \code{method} \code{"exact"}, + \code{"rarefaction"} and \code{"coleman"} the function uses analytic + equations for interpolated non-integer values, and for other methods + linear (\code{\link{approx}}) or spline (\code{\link{spline}}) + interpolation. If \code{newdata} is not given, the function returns + the values corresponding to the data. NB., the fitted values with + \code{method="rarefaction"} are based on rounded integer counts, but + \code{predict} can use fractional non-integer counts with + \code{newdata} and give slightly different results. Function \code{fitspecaccum} fits a nonlinear (\code{\link{nls}}) self-starting species accumulation model. The input \code{object} @@ -166,10 +178,19 @@ 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. + Function \code{predict} for \code{fitspecaccum} uses + \code{\link{predict.nls}}, and you can pass all arguments to that + function. In addition, \code{fitted}, \code{residuals} and + \code{coef}, \code{AIC} and \code{deviance} work on the result + object. + Function \code{specslope} evaluates the derivative of the species + accumulation curve at given number of sample plots, and gives the + rate of increase in the number of species. The function works with + \code{specaccum} result object when this is based on analytic models + \code{"exact"}, \code{"rarefaction"} or \code{"coleman"}, and with + non-linear regression results of \code{fitspecaccum}. + Nonlinear regression may fail for any reason, and some of the \code{fitspecaccum} models are fragile and may not succeed. } From noreply at r-forge.r-project.org Wed May 20 14:05:51 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 20 May 2015 14:05:51 +0200 (CEST) Subject: [Vegan-commits] r2948 - www Message-ID: <20150520120551.47233181103@r-forge.r-project.org> Author: jarioksa Date: 2015-05-20 14:05:48 +0200 (Wed, 20 May 2015) New Revision: 2948 Modified: www/NEWS.html Log: Updated NEWS Modified: www/NEWS.html =================================================================== --- www/NEWS.html 2015-05-20 12:03:35 UTC (rev 2947) +++ www/NEWS.html 2015-05-20 12:05:48 UTC (rev 2948) @@ -55,7 +55,7 @@ -

NEW FEATURES

+

NEW FEATURES AND FUNCTIONS