[Vegan-commits] r2471 - branches/2.0/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Mar 7 09:45:51 CET 2013
Author: jarioksa
Date: 2013-03-07 09:45:51 +0100 (Thu, 07 Mar 2013)
New Revision: 2471
Modified:
branches/2.0/R/fitspecaccum.R
branches/2.0/R/fitted.capscale.R
branches/2.0/R/goodness.cca.R
branches/2.0/R/goodness.rda.R
branches/2.0/R/tabasco.R
Log:
merge r2458, 2462, 2468 thru 2470
r2458: restructure fitspecaccum
r2462: fix model = "asymp" in fitspecaccum
r2468: tabasco check negative data
r2469, 2470: do not use u.eiv, v.eig of the cca result
Modified: branches/2.0/R/fitspecaccum.R
===================================================================
--- branches/2.0/R/fitspecaccum.R 2013-03-06 08:43:40 UTC (rev 2470)
+++ branches/2.0/R/fitspecaccum.R 2013-03-07 08:45:51 UTC (rev 2471)
@@ -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 ~ 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), ...),
+ "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))
Modified: branches/2.0/R/fitted.capscale.R
===================================================================
--- branches/2.0/R/fitted.capscale.R 2013-03-06 08:43:40 UTC (rev 2470)
+++ branches/2.0/R/fitted.capscale.R 2013-03-07 08:45:51 UTC (rev 2471)
@@ -6,8 +6,8 @@
type <- match.arg(type)
## Return scaled eigenvalues
U <- switch(model,
- CCA = object$CCA$u.eig,
- CA = object$CA$u.eig,
+ CCA = object$CCA$u %*% diag(sqrt(object$CCA$eig)),
+ CA = object$CA$u %*% diag(sqrt(object$CA$eig)),
Imaginary = object$CA$imaginary.u.eig,
pCCA = object$pCCA$Fit/object$adjust)
## Distances or working scores U
Modified: branches/2.0/R/goodness.cca.R
===================================================================
--- branches/2.0/R/goodness.cca.R 2013-03-06 08:43:40 UTC (rev 2470)
+++ branches/2.0/R/goodness.cca.R 2013-03-07 08:45:51 UTC (rev 2471)
@@ -1,7 +1,7 @@
`goodness.cca` <-
- function (object, display = c("species", "sites"), choices, model = c("CCA",
- "CA"), statistic = c("explained", "distance"), summarize = FALSE,
- ...)
+ function (object, display = c("species", "sites"), choices,
+ model = c("CCA", "CA"), statistic = c("explained", "distance"),
+ summarize = FALSE, ...)
{
model <- match.arg(model)
if (is.null(object$CCA))
@@ -11,11 +11,12 @@
statistic <- match.arg(statistic)
display <- match.arg(display)
cs <- if(display == "species") object$colsum else object$rowsum
+ lambda2 <- sqrt(object[[model]]$eig)
if (display == "species") {
if (is.null(object$CCA))
Xbar <- object$CA$Xbar
else Xbar <- object$CCA$Xbar
- v <- object[[model]]$v.eig
+ v <- sweep(object[[model]]$v, 2, lambda2, "*")
tot <- diag(crossprod(Xbar))
}
else {
@@ -25,7 +26,7 @@
Xbar <- qr.fitted(object$CCA$QR, Xbar)
tot <- tot + diag(crossprod(t(Xbar)))
}
- v <- object[[model]]$u.eig
+ v <- sweep(object[[model]]$u, 2, lambda2, "*")
}
if (!missing(choices))
v <- v[, choices, drop = FALSE]
Modified: branches/2.0/R/goodness.rda.R
===================================================================
--- branches/2.0/R/goodness.rda.R 2013-03-06 08:43:40 UTC (rev 2470)
+++ branches/2.0/R/goodness.rda.R 2013-03-07 08:45:51 UTC (rev 2471)
@@ -1,7 +1,7 @@
`goodness.rda` <-
- function (object, display = c("species", "sites"), choices, model = c("CCA",
- "CA"), statistic = c("explained", "distance"), summarize = FALSE,
- ...)
+ function (object, display = c("species", "sites"), choices,
+ model = c("CCA", "CA"), statistic = c("explained", "distance"),
+ summarize = FALSE, ...)
{
model <- match.arg(model)
display <- match.arg(display)
@@ -13,11 +13,12 @@
stop("model ", model, " is not available")
statistic <- match.arg(statistic)
cs <- weights(object, display = display)
+ lambda2 <- sqrt(object[[model]]$eig)
if (display == "species") {
if (is.null(object$CCA))
Xbar <- object$CA$Xbar
else Xbar <- object$CCA$Xbar
- v <- object[[model]]$v.eig
+ v <- sweep(object[[model]]$v, 2, lambda2, "*")
tot <- diag(crossprod(Xbar)/(nrow(Xbar) - 1))
}
else {
@@ -31,7 +32,7 @@
tot <- tot + diag(crossprod(t(Xbar)))/(nrow(Xbar) -
1)
}
- v <- object[[model]]$u.eig
+ v <- sweep(object[[model]]$u, 2, lambda2, "*")
}
if (!missing(choices))
v <- v[, choices, drop = FALSE]
Modified: branches/2.0/R/tabasco.R
===================================================================
--- branches/2.0/R/tabasco.R 2013-03-06 08:43:40 UTC (rev 2470)
+++ branches/2.0/R/tabasco.R 2013-03-07 08:45:51 UTC (rev 2471)
@@ -8,6 +8,8 @@
function (x, use, sp.ind = NULL, site.ind = NULL,
select, Rowv = TRUE, Colv = TRUE, ...)
{
+ if (any(x < 0))
+ stop("function cannot be used with negative data values")
pltree <- sptree <- NA
if (!missing(use)) {
if (!is.list(use) && is.vector(use)) {
More information about the Vegan-commits
mailing list