[Vegan-commits] r2937 - in pkg/vegan: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Mar 11 08:18:55 CET 2015
Author: jarioksa
Date: 2015-03-11 08:18:55 +0100 (Wed, 11 Mar 2015)
New Revision: 2937
Removed:
pkg/vegan/R/goodness.rda.R
Modified:
pkg/vegan/NAMESPACE
pkg/vegan/R/goodness.cca.R
pkg/vegan/man/goodness.cca.Rd
Log:
Merge branch 'cran-2.2' into r-forge-svn-local
Redesign goodness.cca, remove goodness.rda
Modified: pkg/vegan/NAMESPACE
===================================================================
--- pkg/vegan/NAMESPACE 2015-03-09 10:10:02 UTC (rev 2936)
+++ pkg/vegan/NAMESPACE 2015-03-11 07:18:55 UTC (rev 2937)
@@ -192,7 +192,6 @@
S3method(goodness, cca)
S3method(goodness, metaMDS)
S3method(goodness, monoMDS)
-S3method(goodness, rda)
# head: utils
S3method(head, summary.cca)
# hiersimu: vegan
Modified: pkg/vegan/R/goodness.cca.R
===================================================================
--- pkg/vegan/R/goodness.cca.R 2015-03-09 10:10:02 UTC (rev 2936)
+++ pkg/vegan/R/goodness.cca.R 2015-03-11 07:18:55 UTC (rev 2937)
@@ -1,33 +1,53 @@
`goodness.cca` <-
function (object, display = c("species", "sites"), choices,
model = c("CCA", "CA"), statistic = c("explained", "distance"),
- summarize = FALSE, ...)
+ summarize = FALSE, addpartial = TRUE, ...)
{
model <- match.arg(model)
+ display <- match.arg(display)
+ if (inherits(object, "capscale") && display == "species")
+ stop("display = \"species\" not available for 'capscale'")
+ if (inherits(object, "rda"))
+ NR <- nobs(object) - 1
+ else
+ NR <- 1
if (is.null(object$CCA))
model <- "CA"
if (is.null(object[[model]]) || object[[model]]$rank == 0)
stop("model ", model, " is not available")
statistic <- match.arg(statistic)
- display <- match.arg(display)
- cs <- if(display == "species") object$colsum else object$rowsum
+ if (inherits(object, "rda"))
+ cs <- 1
+ else {
+ cs <-
+ if (display == "species") object$colsum else object$rowsum
+ }
lambda2 <- sqrt(object[[model]]$eig)
+ ## collect contributions to the variation and scores
+ ptot <- ctot <- rtot <- 0
if (display == "species") {
- if (is.null(object$CCA))
- Xbar <- object$CA$Xbar
- else Xbar <- object$CCA$Xbar
+ if (!is.null(object$pCCA))
+ ptot <- diag(crossprod(object$pCCA$Fit)) / NR
+ if (!is.null(object$CCA)) {
+ Xbar <- qr.fitted(object$CCA$QR, object$CCA$Xbar)
+ ctot <- diag(crossprod(Xbar)) / NR
+ }
+ if (!is.null(object$CA))
+ rtot <- diag(crossprod(object$CA$Xbar)) / NR
v <- sweep(object[[model]]$v, 2, lambda2, "*")
- tot <- diag(crossprod(Xbar))
}
else {
- tot <- diag(crossprod(t(object$CA$Xbar)))
+ if (!is.null(object$pCCA))
+ ptot <- diag(tcrossprod(object$pCCA$Fit)) / NR
if (!is.null(object$CCA)) {
- Xbar <- object$CCA$Xbar
- Xbar <- qr.fitted(object$CCA$QR, Xbar)
- tot <- tot + diag(crossprod(t(Xbar)))
+ Xbar <- qr.fitted(object$CCA$QR, object$CCA$Xbar)
+ ctot <- diag(tcrossprod(Xbar)) / NR
}
+ if (!is.null(object$CA))
+ rtot <- diag(tcrossprod(object$CA$Xbar)) / NR
v <- sweep(object[[model]]$u, 2, lambda2, "*")
}
+ v <- sweep(v, 1, sqrt(cs), "*")
if (ncol(v) > 1)
vexp <- t(apply(v^2, 1, cumsum))
else
@@ -35,27 +55,21 @@
if (!missing(choices))
vexp <- vexp[, choices, drop = FALSE]
if (statistic == "explained") {
- vexp <- sweep(vexp, 1, cs, "*")
- if (!is.null(object$pCCA)) {
- Xbar <- object$pCCA$Fit
- if (display == "sites")
- Xbar <- t(Xbar)
- ptot <- diag(crossprod(Xbar))
- tot <- tot + ptot
- if (model == "CCA")
- vexp <- sweep(vexp, 1, ptot, "+")
- }
+ tot <- ptot + ctot + rtot
+ if (addpartial && model == "CCA" && !is.null(object$pCCA))
+ vexp <- sweep(vexp, 1, ptot, "+")
vexp <- sweep(vexp, 1, tot, "/")
}
else {
- if (display == "sites" && (!is.null(object$CCA) || !is.null(object$pCCA)))
- stop("statistic 'distance' not available for sites in constrained analysis")
- vexp <- sweep(-(vexp), 1, tot/cs, "+")
+ tot <- rtot
+ if (model == "CCA")
+ tot <- tot + ctot
+ vexp <- sweep(-(vexp), 1, tot, "+")
vexp[vexp < 0] <- 0
vexp <- sqrt(vexp)
+ vexp <- sweep(vexp, 1, sqrt(cs), "/")
}
if (summarize)
vexp <- vexp[, ncol(vexp)]
vexp
}
-
Deleted: pkg/vegan/R/goodness.rda.R
===================================================================
--- pkg/vegan/R/goodness.rda.R 2015-03-09 10:10:02 UTC (rev 2936)
+++ pkg/vegan/R/goodness.rda.R 2015-03-11 07:18:55 UTC (rev 2937)
@@ -1,67 +0,0 @@
-`goodness.rda` <-
- 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)
- if (inherits(object, "capscale") && display == "species")
- stop("display = \"species\" not available for 'capscale'")
- if (is.null(object$CCA))
- model <- "CA"
- if (is.null(object[[model]]) || object[[model]]$rank == 0)
- 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 <- sweep(object[[model]]$v, 2, lambda2, "*")
- tot <- diag(crossprod(Xbar)/(nrow(Xbar) - 1))
- }
- else {
- Xbar <- object$CA$Xbar
- tot <- diag(crossprod(t(Xbar)))
- if (!is.null(tot))
- tot <- tot/(nrow(Xbar) - 1)
- if (!is.null(object$CCA)) {
- Xbar <- object$CCA$Xbar
- Xbar <- qr.fitted(object$CCA$QR, Xbar)
- tot <- tot + diag(crossprod(t(Xbar)))/(nrow(Xbar) -
- 1)
- }
- v <- sweep(object[[model]]$u, 2, lambda2, "*")
- }
- if (ncol(v) > 1)
- vexp <- t(apply(v^2, 1, cumsum))
- else
- vexp <- v^2
- vexp <- sweep(vexp, 1, cs, "*")
- if (!missing(choices))
- vexp <- vexp[, choices, drop = FALSE]
- if (statistic == "explained") {
- if (!is.null(object$pCCA)) {
- Xbar <- object$pCCA$Fit
- if (display == "sites")
- Xbar <- t(Xbar)
- ptot <- diag(crossprod(Xbar))/(nrow(Xbar)-1)
- tot <- tot + ptot
- if (model == "CCA")
- vexp <- sweep(vexp, 1, ptot, "+")
- }
- vexp <- sweep(vexp, 1, tot, "/")
- }
- else {
- if (display == "sites" && (!is.null(object$CCA) || !is.null(object$pCCA)))
- stop("statistic 'distance' not available for sites in constrained analysis")
- vexp <- sweep(-(vexp), 1, tot, "+")
- vexp[vexp < 0] <- 0
- vexp <- sweep(sqrt(vexp), 1, cs, "/")
- }
- if (summarize)
- vexp <- vexp[, ncol(vexp)]
- vexp
-}
-
Modified: pkg/vegan/man/goodness.cca.Rd
===================================================================
--- pkg/vegan/man/goodness.cca.Rd 2015-03-09 10:10:02 UTC (rev 2936)
+++ pkg/vegan/man/goodness.cca.Rd 2015-03-11 07:18:55 UTC (rev 2937)
@@ -1,6 +1,5 @@
\name{goodness.cca}
\alias{goodness}
-\alias{goodness.rda}
\alias{goodness.cca}
\alias{inertcomp}
\alias{spenvcor}
@@ -21,7 +20,7 @@
\usage{
\method{goodness}{cca}(object, display = c("species", "sites"), choices,
model = c("CCA", "CA"), statistic = c("explained", "distance"),
- summarize = FALSE, ...)
+ summarize = FALSE, addpartial = TRUE, ...)
inertcomp(object, display = c("species", "sites"),
statistic = c("explained", "distance"), proportional = FALSE)
spenvcor(object)
@@ -33,15 +32,26 @@
\arguments{
\item{object}{A result object from \code{\link{cca}},
\code{\link{rda}} or \code{\link{capscale}}. }
- \item{display}{Display \code{"species"} or \code{"sites"}. }
- \item{choices}{Axes shown. Default is to show all axes of the \code{"model"}. }
+
+ \item{display}{Display \code{"species"} or \code{"sites"}. Species
+ are not available in \code{\link{capscale}}. }
+
+ \item{choices}{Axes shown. Default is to show all axes of the
+ \code{"model"}. }
+
\item{model}{Show constrained (\code{"CCA"}) or unconstrained
(\code{"CA"}) results. }
+
\item{statistic}{Statistic used: \code{"explained"} gives the cumulative
- percentage accounted for, \code{"distance"} shows the residual
- distances. Distances are not available for sites in constrained or
- partial analyses. }
- \item{summarize}{Show only the accumulated total. }
+ percentage accounted for, \code{"distance"} shows the residual
+ distances. }
+
+ \item{summarize}{Show only the accumulated total.}
+
+ \item{addpartial}{Add the variation explained by conditions
+ (partialled out variation) to the constraints when
+ \code{statistic="explained"}.}
+
\item{proportional}{Give the inertia components as proportional for
the corresponding total.}
\item{names.only}{Return only names of aliased variable(s) instead of
@@ -52,10 +62,7 @@
Function \code{goodness} gives the diagnostic statistics for species
or sites. The alternative statistics are the cumulative proportion of
inertia accounted for up to the axes, and the residual distance left
- unaccounted for. The conditional (\dQuote{partialled out})
- constraints are always regarded as explained and included in the
- statistics of the constrained component with\code{model = "CCA"}
- (but not in the residual component with \code{model = "CA"}).
+ unaccounted for.
Function \code{inertcomp} decomposes the inertia into partial,
constrained and unconstrained components for each site or
@@ -117,12 +124,6 @@
total inertia is not a meaningful concept in \code{cca}, in particular
for rare species.
- Function \code{vif} is defined as generic in package \pkg{car}
- (\code{\link[car]{vif}}), but if you have not loaded that package
- you must specify the call as \code{vif.cca}. Variance inflation
- factor is useful diagnostic tool for detecting nearly collinear
- constraints, but these are not a problem with algorithm used in this
- package to fit a constrained ordination.
}
\seealso{\code{\link{cca}}, \code{\link{rda}}, \code{\link{capscale}},
More information about the Vegan-commits
mailing list