(Re)Add warning for rank deficiency

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: performance
 Title: Assessment of Regression Models Performance
-Version: 0.17.1
+Version: 0.17.1.0001
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

NEWS.md

@@ -1,3 +1,11 @@
+# performance 0.17.xxx
+
+## Bug fixes
+
+* `check_collinearity()` now properly warns when the `vcov` matrix is rank
+  deficient (#922).
+
+
 # performance 0.17.1
 
 ## Changes

R/check_collinearity.R

@@ -447,7 +447,7 @@
 }
 
 
 .check_collinearity <- function(x, component, ci = 0.95, verbose = TRUE) {
   v <- .safe(insight::get_varcov(x, component = component, verbose = FALSE))
 
   # fix class for fixest, which returns a "fixest_vcov" here
@@ -490,7 +490,7 @@
   if (inherits(x, c("clm", "clmm"))) {
     # names(x$beta) returns only non-singular (surviving) slopes
     slope_names <- names(x$beta)
-    keep_idx <- which(colnames(v) %in% slope_names)
+    keep_idx <- colnames(v) %in% slope_names
 
     # Rebuild term_assign by matching model matrix columns to surviving slopes
     tryCatch(
@@ -507,34 +507,55 @@
       },
       error = function(e) NULL
     )
-  } else if (insight::has_intercept(x)) {
-    # Standard behavior: drop the first column/row (the singular intercept)
-    keep_idx <- seq_len(ncol(v))[-1]
   } else {
-    keep_idx <- seq_len(ncol(v))
-    if (isTRUE(verbose)) {
+    keep_idx <- rep(TRUE, ncol(v))
+    if (insight::has_intercept(x)) {
+      # Standard behavior: drop the first column/row (the singular intercept)
+      keep_idx[1] <- FALSE
+    } else if (isTRUE(verbose)) {
       insight::format_alert("Model without intercept. VIFs may not be sensible.")
     }
   }
 
+  # we have rank-deficiency here. remove NA columns from assignment
+  if (isTRUE(attr(v, "rank_deficient")) || anyNA(v)) {
+    if (!is.null(attr(v, "na_columns_index"))) {
+      # If this attribute exists, then NA values were already removed from v
+      term_assign <- term_assign[-attr(v, "na_columns_index")]
+      na_cols <- names(attr(v, "na_columns_name"))
+    } else if (anyNA(v)) {
+      # If no attribute exists, then we need to identify NA columns manually
+      # fixme: this should be ficef in insight::get_varcov() to avoid this step
+      idx_na <- apply(is.na(m), 2, all)
+      na_cols <- colnames(v)[idx_na]
+      keep_idx[idx_na] <- FALSE
+    }
+
+    if (isTRUE(verbose)) {
+      if (length(na_cols) > 0) {
+        insight::format_warning(
+          "Model matrix is rank deficient. VIFs may not be sensible.",
+          paste0(
+            "The following coefficients have VIF = Inf / tolerance = 0: ",
+            paste0(na_cols, collapse = ", ")
+          )
+        )
+      } else {
+        insight::format_warning(
+          "Model matrix is rank deficient. VIFs may not be sensible."
+        )
+      }
+    }
+  }
+
   # Safely subset the matrix
-  if (length(keep_idx) < ncol(v)) {
+  if (any(!keep_idx) < ncol(v)) {
     if (!is.null(term_assign) && length(term_assign) == ncol(v)) {
       term_assign <- term_assign[keep_idx]
     }
     v <- v[keep_idx, keep_idx, drop = FALSE]
   }
 
-  # we have rank-deficiency here. remove NA columns from assignment
-  if (isTRUE(attributes(v)$rank_deficient) && !is.null(attributes(v)$na_columns_index)) {
-    term_assign <- term_assign[-attributes(v)$na_columns_index]
-    if (isTRUE(verbose)) {
-      insight::format_alert(
-        "Model matrix is rank deficient. VIFs may not be sensible."
-      )
-    }
-  }
-
   f <- insight::find_formula(x, verbose = FALSE)
 
   # hurdle or zeroinfl model can have no zero-inflation formula, in which case
@@ -571,7 +592,7 @@
     return(NULL)
   }
 
   R <- stats::cov2cor(v)
   detR <- det(R)
 
   result <- vector("numeric")

tests/testthat/test-check_collinearity.R

@@ -1,5 +1,6 @@
 # https://github.com/easystats/performance/pull/547
 test_that("check_collinearity, correct order in print", {
+  data(mtcars)
   m <- lm(mpg ~ wt + cyl + gear + disp, data = mtcars)
   out <- capture.output(print(check_collinearity(m, verbose = FALSE)))
   expect_identical(
@@ -410,3 +411,23 @@
   expect_identical(out$Term, c("wt", "cyl"))
   expect_false("disp" %in% out$Term)
 })
+
+
+test_that("check_collinearity, rank deficient.", {
+  data(mtcars)
+  mtcars$Z <- mtcars$wt + mtcars$cyl
+
+  m1 <- lm(mpg ~ wt + cyl + Z, data = mtcars)
+  m2 <- lm(mpg ~ wt + cyl, data = mtcars)
+  expect_warning(
+    out1 <- check_collinearity(m1),
+    "Model matrix is rank deficient"
+  )
+  expect_warning(
+    out2 <- check_collinearity(m2),
+    NA
+  )
+  expect_identical(out1$VIF, out2$VIF)
+})
+
+debugonce(performance:::.check_collinearity)