From 3250fd720f961f332aa3946a6d1b30e6f8efb6d7 Mon Sep 17 00:00:00 2001
From: Daniel <mail@danielluedecke.de>
Date: Fri, 16 Feb 2024 20:44:54 +0100
Subject: [PATCH] `check_singularity` doesn't work for `glmmTMB` (#684)

---
 DESCRIPTION                             |  2 +-
 NEWS.md                                 |  3 +++
 R/check_singularity.R                   | 15 +++++++++++---
 tests/testthat/test-check_singularity.R | 26 ++++++++++++++++++++++---
 4 files changed, 39 insertions(+), 7 deletions(-)

diff --git a/DESCRIPTION b/DESCRIPTION
index 142767fa3..bbc3b6532 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: performance
 Title: Assessment of Regression Models Performance
-Version: 0.10.8.13
+Version: 0.10.8.14
 Authors@R: 
     c(person(given = "Daniel",
              family = "Lüdecke",
diff --git a/NEWS.md b/NEWS.md
index 2a8b4ecb9..91d45d051 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -18,6 +18,9 @@
 * Improved plots for overdispersion-checks for negative-binomial models from
   package *glmmTMB* (affects `check_overdispersion()` and `check_mnodel()`).
 
+* Improved detection rates for singularity in `check_singularity()` for models
+  from package *glmmTMB*.
+
 * For model of class `glmmTMB`, deviance residuals are now used in the
   `check_model()` plot.
 
diff --git a/R/check_singularity.R b/R/check_singularity.R
index 3128ef933..b446708bd 100644
--- a/R/check_singularity.R
+++ b/R/check_singularity.R
@@ -101,15 +101,24 @@ check_singularity.merMod <- function(x, tolerance = 1e-5, ...) {
 check_singularity.rlmerMod <- check_singularity.merMod
 
 
-
 #' @export
 check_singularity.glmmTMB <- function(x, tolerance = 1e-5, ...) {
   insight::check_if_installed("lme4")
 
-  vc <- .collapse_cond(lme4::VarCorr(x))
-  any(sapply(vc, function(.x) any(abs(diag(.x)) < tolerance)))
+  eigen_values <- list()
+  vv <- lme4::VarCorr(x)
+  for (component in c("cond", "zi")) {
+    for (i in seq_along(vv[[component]])) {
+      eigen_values <- c(
+        eigen_values,
+        list(eigen(vv[[component]][[i]], only.values = TRUE)$values)
+      )
+    }
+  }
+  any(vapply(eigen_values, min, numeric(1), na.rm = TRUE) < tolerance)
 }
 
+
 #' @export
 check_singularity.glmmadmb <- check_singularity.glmmTMB
 
diff --git a/tests/testthat/test-check_singularity.R b/tests/testthat/test-check_singularity.R
index 3edf6e8f6..dc0d56964 100644
--- a/tests/testthat/test-check_singularity.R
+++ b/tests/testthat/test-check_singularity.R
@@ -1,14 +1,14 @@
-test_that("check_singularity", {
+test_that("check_singularity, lme4", {
   skip_on_cran()
   skip_if_not_installed("lme4")
   data(sleepstudy, package = "lme4")
   set.seed(123)
-  sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE)
+  sleepstudy$mygrp <- sample.int(5, size = 180, replace = TRUE)
   sleepstudy$mysubgrp <- NA
   for (i in 1:5) {
     filter_group <- sleepstudy$mygrp == i
     sleepstudy$mysubgrp[filter_group] <-
-      sample(1:30, size = sum(filter_group), replace = TRUE)
+      sample.int(30, size = sum(filter_group), replace = TRUE)
   }
 
   model <- suppressMessages(lme4::lmer(
@@ -17,3 +17,23 @@ test_that("check_singularity", {
   ))
   expect_true(check_singularity(model))
 })
+
+
+test_that("check_singularity", {
+  skip_on_cran()
+  skip_if_not_installed("glmmTMB")
+  set.seed(101)
+  dd <- expand.grid(x = factor(1:6), f = factor(1:20), rep = 1:5)
+  dd$y <- glmmTMB::simulate_new(~ 1 + (x | f),
+    newdata = dd,
+    newparam = list(
+      beta = 0,
+      theta = rep(0, 21),
+      betad = 0
+    )
+  )[[1]]
+  expect_warning(expect_warning({
+    m2 <- glmmTMB::glmmTMB(y ~ 1 + (x | f), data = dd, REML = FALSE)
+  }))
+  expect_true(check_singularity(m2))
+})