Merge branch 'centroid-scores'

vegandevs · Jun 11, 2024 · 2d3468e · 2d3468e
2 parents 1432f5b + 2aabcba
commit 2d3468e
Show file tree

Hide file tree

Showing 9 changed files with 52 additions and 57 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -43,6 +43,9 @@
   The new features are more extensively described in help pages
   `?plot.cca`, `?ordiplot` and `?biplot.rda`.
 
+* `rda` and `cca` return centroids for factor levels also when
+  called without formula, for instance `cca(dune, dune.env)`.
+
 ## Bug Fixes
 
 * `summary.ordihull` failed if input data were not two-dimensional.

diff --git a/R/capscale.R b/R/capscale.R
@@ -134,17 +134,9 @@
             sol$CCA$v[] <- NA
         sol$colsum <- NA
     }
-    if (!is.null(sol$CCA) && sol$CCA$rank > 0)
-        sol$CCA$centroids <- centroids.cca(sol$CCA$wa, d$modelframe)
-    if (!is.null(sol$CCA$alias))
-        sol$CCA$centroids <- unique(sol$CCA$centroids)
-    if (!is.null(sol$CCA$centroids)) {
-        rs <- rowSums(sol$CCA$centroids^2)
-        sol$CCA$centroids <- sol$CCA$centroids[rs > 1e-04, ,
-                                               drop = FALSE]
-        if (nrow(sol$CCA$centroids) == 0)
-            sol$CCA$centroids <- NULL
-    }
+    ## centroids
+    sol$CCA$centroids <- getCentroids(sol, d$modelframe)
+
     sol$call <- match.call()
     sol$terms <- terms(formula, "Condition", data = data)
     sol$terminfo <- ordiTerminfo(d, data)

diff --git a/R/cca.default.R b/R/cca.default.R
@@ -8,8 +8,10 @@
         stop("function cannot be used with (dis)similarities")
     X <- as.matrix(X)
     if (!is.null(Y)) {
-        if (is.data.frame(Y) || is.factor(Y))
+        if (is.data.frame(Y) || is.factor(Y)) { # save Y for centroids
+            mframe <- as.data.frame(Y) # can be a single factor
             Y <- model.matrix(~ ., as.data.frame(Y))[,-1,drop=FALSE]
+        }
         Y <- as.matrix(Y)
     }
     if (!is.null(Z)) {
@@ -27,6 +29,10 @@
         X <- X[, !tmp, drop = FALSE]
     }
     sol <- ordConstrained(X, Y, Z, method = "cca")
+    ## mframe exists only if function was called as cca(X, mframe)
+    if (exists("mframe"))
+        sol$CCA$centroids <- getCentroids(sol, mframe)
+
     if (exists("exclude.spec")) {
         if (!is.null(sol$CCA$v))
             attr(sol$CCA$v, "na.action") <- exclude.spec

diff --git a/R/cca.formula.R b/R/cca.formula.R
@@ -10,21 +10,7 @@
     d <- ordiParseFormula(formula, data = data, na.action = na.action,
                           subset = substitute(subset))
     sol <- cca.default(d$X, d$Y, d$Z)
-    if (!is.null(sol$CCA) && sol$CCA$rank > 0) {
-        centroids <- centroids.cca(sol$CCA$wa, d$modelframe,
-                                   sol$rowsum)
-        if (!is.null(sol$CCA$alias))
-            centroids <- unique(centroids)
-        ## See that there really are centroids
-        if (!is.null(centroids)) {
-            rs <- rowSums(centroids^2)
-            centroids <- centroids[rs > 1e-04,, drop = FALSE]
-            if (length(centroids) == 0)
-                centroids <- NULL
-        }
-        if (!is.null(centroids))
-            sol$CCA$centroids <- centroids
-    }
+    sol$CCA$centroids <- getCentroids(sol, d$modelframe)
     ## replace cca.default call
     call <- match.call()
     call[[1]] <- as.name("cca")

diff --git a/R/centroids.cca.R b/R/centroids.cca.R
@@ -9,7 +9,7 @@
     mf <- mf[, facts, drop = FALSE]
     ## Explicitly exclude NA as a level
     mf <- droplevels(mf, exclude = NA)
-    if (missing(wt))
+    if (missing(wt) || is.null(wt))
         wt <- rep(1, nrow(mf))
     ind <- seq_len(nrow(mf))
     workhorse <- function(x, wt)
@@ -36,3 +36,30 @@
     colnames(out) <- colnames(x)
     out
 }
+
+### cca.centroids is used by all constrained ordination methods and
+### factorfit (via envfit). All constrained ordinations sanitize the
+### results is the same way, and instead of having the same code in
+### all functions, let's have it here.
+
+## @param ord ordConstrained result object.
+## @param mframe Data frame, possibly with factors for which centroids
+## are needed.
+
+`getCentroids` <-
+    function(ord, mframe)
+{
+    if (is.null(ord$CCA) || ord$CCA$rank < 1)
+        return(NULL)
+    centroids <- centroids.cca(ord$CCA$u, mframe, ord$rowsum)
+    if (!is.null(ord$CCA$alias))
+        centroids <- unique(centroids)
+    ## See that there really are centroids
+    if (!is.null(centroids)) {
+        rs <- rowSums(centroids^2)
+        centroids <- centroids[rs > 1e-04,, drop = FALSE]
+        if (length(centroids) == 0)
+            centroids <- NULL
+    }
+    centroids
+}
diff --git a/R/dbrda.R b/R/dbrda.R
@@ -115,18 +115,8 @@
                                        drop = FALSE]
         sol$CA$u <- sol$CA$u[, seq_len(sol$CA$poseig), drop = FALSE]
     }
-    if (!is.null(sol$CCA) && sol$CCA$rank > 0)
-        sol$CCA$centroids <-
-            centroids.cca(sol$CCA$u, d$modelframe)
-    if (!is.null(sol$CCA$alias))
-        sol$CCA$centroids <- unique(sol$CCA$centroids)
-    if (!is.null(sol$CCA$centroids)) {
-        rs <- rowSums(sol$CCA$centroids^2)
-        sol$CCA$centroids <- sol$CCA$centroids[rs > 1e-04, ,
-                                               drop = FALSE]
-        if (nrow(sol$CCA$centroids) == 0)
-            sol$CCA$centroids <- NULL
-    }
+    sol$CCA$centroids <- getCentroids(sol, d$modelframe)
+
     sol$call <- match.call()
     sol$terms <- terms(formula, "Condition", data = data)
     sol$terminfo <- ordiTerminfo(d, data)

diff --git a/R/rda.default.R b/R/rda.default.R
@@ -8,8 +8,10 @@
         stop("function cannot be used with (dis)similarities")
     X <- as.matrix(X)
     if (!is.null(Y)) {
-        if (is.data.frame(Y) || is.factor(Y))
+        if (is.data.frame(Y) || is.factor(Y)) { # save Y for centroids
+            mframe <- as.data.frame(Y) # can be a single factor
             Y <- model.matrix(~ ., as.data.frame(Y))[,-1,drop=FALSE]
+        }
         Y <- as.matrix(Y)
     }
     if (!is.null(Z)) {
@@ -19,6 +21,9 @@
     }
 
     sol <- ordConstrained(X, Y, Z, arg = scale, method = "rda")
+    ## mframe exists only if function was called rda(X, mframe)
+    if (exists("mframe"))
+        sol$CCA$centroids <- getCentroids(sol, mframe)
 
     call <- match.call()
     call[[1]] <- as.name("rda")

diff --git a/R/rda.formula.R b/R/rda.formula.R
@@ -11,19 +11,7 @@
     d <- ordiParseFormula(formula, data = data, na.action = na.action,
                           subset = substitute(subset))
     sol <- rda.default(d$X, d$Y, d$Z, scale)
-    if (!is.null(sol$CCA) && sol$CCA$rank > 0) {
-        centroids <- centroids.cca(sol$CCA$wa, d$modelframe)
-        if (!is.null(sol$CCA$alias))
-            centroids <- unique(centroids)
-        if (!is.null(centroids)) {
-            rs <- rowSums(centroids^2)
-            centroids <- centroids[rs > 1e-04,, drop = FALSE]
-            if (length(centroids) == 0)
-                centroids <- NULL
-        }
-        if (!is.null(centroids))
-            sol$CCA$centroids <- centroids
-    }
+    sol$CCA$centroids <- getCentroids(sol, d$modelframe)
     ## replace rda.default call
     call <- match.call()
     call[[1]] <- as.name("rda")

diff --git a/man/plot.cca.Rd b/man/plot.cca.Rd
@@ -173,9 +173,7 @@
   function uses a simple heuristics for adjusting the unit-length arrows
   to the current plot area, but the user can give the expansion factor
   in \code{arrow.mul}.  With \code{display="cn"} the centroids of levels
-  of \code{\link{factor}} variables are displayed (these are available
-  only if there were factors and a formula interface was used in
-  \code{\link{cca}} or \code{\link{rda}}). With this option continuous
+  of \code{\link{factor}} variables are displayed. With this option continuous
   variables still are presented as arrows and ordered factors as arrows
   and centroids. With \code{display = "reg"} arrows will be drawn for
   regression coefficients (a.k.a. canonical coefficients) of constraints