From dfd265106f19b90b89377da9d48e175b33db6285 Mon Sep 17 00:00:00 2001 From: Gavin Simpson Date: Fri, 16 Aug 2024 20:17:56 +0200 Subject: [PATCH 1/2] first go at implementing tgreater notification to users of aliased model terms as per #682 --- R/add1.cca.R | 3 ++- R/anova.ccabyterm.R | 12 ++++++---- R/drop1.cca.R | 3 ++- R/ordConstrained.R | 21 ++++++++++++++---- R/print.cca.R | 54 +++++++++++++++++++++++++++++++++------------ 5 files changed, 69 insertions(+), 24 deletions(-) diff --git a/R/add1.cca.R b/R/add1.cca.R index 4f2b09641..2efc5b8d6 100644 --- a/R/add1.cca.R +++ b/R/add1.cca.R @@ -8,7 +8,8 @@ stop("ordination model must be fitted using formula") test <- match.arg(test) ## Default add1 - out <- NextMethod("add1", object, test = "none", ...) + # don't show messages about aliased terms + out <- suppressMessages(NextMethod("add1", object, test = "none", ...)) cl <- class(out) ## Loop over terms in 'scope' and do anova.cca if (test == "permutation") { diff --git a/R/anova.ccabyterm.R b/R/anova.ccabyterm.R index b9e91641a..7cb61f0cb 100644 --- a/R/anova.ccabyterm.R +++ b/R/anova.ccabyterm.R @@ -90,9 +90,11 @@ stop("old style result object: update() your model") ## analyse only terms of 'ass' thar are in scope scopeterms <- which(alltrms %in% trmlab) - mods <- lapply(scopeterms, function(i, ...) - permutest(ordConstrained(Y, X[, ass != i, drop=FALSE], Z, "pass"), - permutations, ...), ...) + mods <- suppressMessages( + lapply(scopeterms, function(i, ...) + permutest(ordConstrained(Y, X[, ass != i, drop = FALSE], Z, "pass"), + permutations, ...), ...) + ) ## Chande in df Df <- sapply(mods, function(x) x$df[2]) - dfbig ## F of change @@ -197,7 +199,9 @@ F.perm <- matrix(ncol = ncol(LC), nrow = nperm) for (i in seq_along(eig)) { if (i > 1) { - object <- ordConstrained(Y, X, cbind(Z, LC[, seq_len(i-1)]), "pass") + object <- suppressMessages( + ordConstrained(Y, X, cbind(Z, LC[, seq_len(i - 1)]), "pass") + ) } if (length(eig) == i) { mod <- permutest(object, permutations, model = model, diff --git a/R/drop1.cca.R b/R/drop1.cca.R index ca78a75eb..ee9e1b0e7 100644 --- a/R/drop1.cca.R +++ b/R/drop1.cca.R @@ -7,7 +7,8 @@ if (is.null(object$terms)) stop("ordination model must be fitted using formula") test <- match.arg(test) - out <- NextMethod("drop1", object, test="none", ...) + # don't show messages about aliased terms + out <- suppressMessages(NextMethod("drop1", object, test = "none", ...)) cl <- class(out) if (test == "permutation") { rn <- rownames(out)[-1] diff --git a/R/ordConstrained.R b/R/ordConstrained.R index e6f409c22..6f4722bad 100644 --- a/R/ordConstrained.R +++ b/R/ordConstrained.R @@ -199,8 +199,19 @@ if (rank == 0) return(list(Y = Y, result = NULL)) ## check for aliased terms - if (length(Q$pivot) > Q$rank) + if (length(Q$pivot) > Q$rank) { alias <- colnames(Q$qr)[-seq_len(Q$rank)] + # print a message to highlight this aliasing + #msg <- "Some model terms were linearly dependent and their effects +#cannot be uniquely estimated. See '?alias.cca' for more detail and use +#'vif.cca()' to identify these terms." + #message(strwrap(msg, prefix = "\n", initial = "\n", + # width = 0.95 * getOption("width"))) + aliased <- paste(sQuote(alias), collapse = ", ") + msg <- paste("Some constraints or conditions were aliased because they were redundant.", + "This can happen if terms are linearly dependent (collinear):", aliased) + message(strwrap(msg, width = getOption("width"), prefix = "\n", initial = "\n")) + } else alias <- NULL ## kept constraints and their means @@ -418,9 +429,11 @@ } ## Residuals resid <- ordResid(Y) - if (resid$rank < 1) - warning("overfitted model with no unconstrained component", - call. = FALSE) + if (resid$rank < 1) { + msg <- "The model is overfitted with no unconstrained (residual) component" + message(strwrap(msg, prefix = "\n", initial = "\n", + width = 0.95 * getOption("width"))) + } ## return a CCA object out <- c(head, call = match.call(), diff --git a/R/print.cca.R b/R/print.cca.R index 6e94f286d..efb1f86f0 100644 --- a/R/print.cca.R +++ b/R/print.cca.R @@ -1,7 +1,9 @@ `print.cca` <- function (x, digits = max(3, getOption("digits") - 3), ...) { - writeLines(strwrap(pasteCall(x$call))) + ord_obj <- deparse(substitute(x)) + msg_w <- 0.95 * getOption("width") + writeLines(strwrap(pasteCall(x$call), width = msg_w)) cat("\n") if (!is.null(x$CA$imaginary.chi)) totchi <- x$tot.chi - x$CA$imaginary.chi @@ -37,22 +39,46 @@ tbl <- tbl[,-2] ## 'cs' columns before "Rank" are non-integer cs <- which(colnames(tbl) == "Rank") - 1 + writeLines("-- Model Summary --\n") printCoefmat(tbl, digits = digits, na.print = "", cs.ind = seq_len(cs)) - cat("Inertia is", x$inertia, "\n") - ## data used for species scores in db ordination - if (!is.null(x$vdata)) - cat("Species scores projected from", sQuote(x$vdata), "\n") - if (!is.null(x$CCA$alias)) - cat("Some constraints or conditions were aliased because they were redundant\n") - ## Report removed observations and species - if (!is.null(x$na.action)) - cat(naprint(x$na.action), "\n") + writeLines(strwrap(paste("Inertia is", x$inertia), width = msg_w, + initial = "\n")) sp.na <- if (is.null(x$CCA)) attr(x$CA$v, "na.action") else attr(x$CCA$v, "na.action") - if (!is.null(sp.na)) - cat(length(sp.na), "species", - ifelse(length(sp.na)==1, "(variable)", "(variables)"), - "deleted due to missingness\n") + # print any notices + if (any(!is.null(x$vdata), !is.null(x$CCA$alias), x$CA$rank < 1, + !is.null(x$na.action), !is.null(sp.na))) { + writeLines("\n-- Note --") + } + ## data used for species scores in db ordination + if (!is.null(x$vdata)) { + writeLines( + strwrap(paste("Species scores projected from", sQuote(x$vdata)), + width = msg_w, initial = "\n") + ) + } + # notify if any terms are linearly dependent (aliased) + if (!is.null(x$CCA$alias)) { + vif_msg <- sQuote(paste0("vif.cca(", ord_obj, ")")) + aliased <- paste(sQuote(alias(x, names.only = TRUE)), collapse = ", ") + msg <- paste("Some constraints or conditions were aliased because they were redundant.", + "This can happen if terms are linearly dependent (collinear):", aliased) + writeLines(strwrap(msg, width = msg_w, initial = "\n")) + } + if (x$CA$rank < 1) { + msg <- "The model is overfitted with no unconstrained (residual) component." + writeLines(strwrap(msg, width = msg_w, initial = "\n")) + } + ## Report removed observations and species + if (!is.null(x$na.action)) { + writeLines(strwrap(naprint(x$na.action), width = msg_w, initial = "\n")) + } + if (!is.null(sp.na)) { + writeLines(strwrap(paste(length(sp.na), "species", + ifelse(length(sp.na) == 1, "(variable)", "(variables)"), + "deleted due to missingness."), width = msg_w, initial = "\n")) + } + writeLines("\n-- Eigenvalues --") if (!is.null(x$CCA) && x$CCA$rank > 0) { cat("\nEigenvalues for constrained axes:\n") print(zapsmall(x$CCA$eig, digits = digits), ...) From db5cfc2f0bf3cdba6ac5e408150bc30bca7ce898 Mon Sep 17 00:00:00 2001 From: Jari Oksanen Date: Mon, 19 Aug 2024 19:14:02 +0300 Subject: [PATCH 2/2] R CMD build vegan gave confusing message when building man/plot.cca.Rd --- man/plot.cca.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/plot.cca.Rd b/man/plot.cca.Rd index d1350f6f6..45d4bc5c9 100644 --- a/man/plot.cca.Rd +++ b/man/plot.cca.Rd @@ -160,7 +160,7 @@ object may contain scores with names \Sexpr[results=rd,stage=build]{require(vegan, quietly=TRUE); data(dune, dune.env); - noquote(paste0(sQuote(names(scores(rda(dune ~ ., dune.env)))), + noquote(paste0(sQuote(names(scores(rda(dune ~ Moisture, dune.env)))), collapse=", "))} (some of these may be missing depending on your model and are only available if given in \code{display}). The first