warnings/approximation of observation-level variance in .get_variance…

…_distributional

Fixes #877

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: insight
 Title: Easy Access to Model Information for Various Model Objects
-Version: 0.20.0
+Version: 0.20.0.2
 Authors@R: 
     c(person(given = "Daniel",
              family = "Lüdecke",

NEWS.md

@@ -1,3 +1,14 @@
+# insight 0.20.1
+
+## General
+
+* Improved accuracy of singularity-checks in `get_variance()`.
+
+## Bug fixes
+
+* Fixed issues in `compact_list()` for objects that contained variables of
+  class `vctrs`.
+
 # insight 0.20.0
 
 ## Breaking
@@ -14,9 +25,6 @@
 
 * Fixed errors in CRAN checks.
 
-* Fixed issues in `compact_list()` for objects that contained variables of
-  class `vctrs`.
-
 # insight 0.19.11
 
 ## General

R/compute_variances.R

@@ -12,6 +12,9 @@
   ## Major revisions and adaption to more complex models and other packages
   ## by Daniel Lüdecke
 
+  # needed for singularity check
+  check_if_installed("performance", reason = "to check for singularity")
+
   faminfo <- model_info(x, verbose = FALSE)
 
   if (any(faminfo$family == "truncated_nbinom1")) {
@@ -36,7 +39,7 @@
 
   # Test for non-zero random effects ((near) singularity)
   no_random_variance <- FALSE
-  if (.is_singular(x, vals, tolerance = tolerance) && !(component %in% c("slope", "intercept"))) {
+  if (performance::check_singularity(x, tolerance = tolerance) && !(component %in% c("slope", "intercept"))) {
     if (verbose) {
       format_warning(
         sprintf("Can't compute %s. Some variance components equal zero. Your model may suffer from singularity (see `?lme4::isSingular` and `?performance::check_singularity`).", name_full),

R/helper_functions.R

@@ -300,47 +300,6 @@
 
 
 
-
-# checks if a mixed model fit is singular or not. Need own function,
-# because lme4::isSingular() does not work with glmmTMB
-.is_singular <- function(x, vals, tolerance = 1e-5) {
-  check_if_installed("lme4", reason = "to compute variances for mixed models")
-
-  tryCatch(
-    {
-      if (inherits(x, "glmmTMB")) {
-        eigen_values <- list()
-        for (component in c("cond", "zi")) {
-          for (i in seq_along(vals$vc[[component]])) {
-            eigen_values <- c(eigen_values, list(eigen(vals$vc[[component]][[i]], only.values = TRUE)$values))
-          }
-        }
-        is_si <- any(vapply(eigen_values, min, numeric(1), na.rm = TRUE) < tolerance)
-      } else if (inherits(x, c("clmm", "cpglmm"))) {
-        is_si <- any(sapply(vals$vc, function(.x) any(abs(diag(.x)) < tolerance)))
-      } else if (inherits(x, "merMod")) {
-        theta <- lme4::getME(x, "theta")
-        diag.element <- lme4::getME(x, "lower") == 0
-        is_si <- any(abs(theta[diag.element]) < tolerance)
-      } else if (inherits(x, "MixMod")) {
-        vc <- diag(x$D)
-        is_si <- any(sapply(vc, function(.x) any(abs(.x) < tolerance)))
-      } else if (inherits(x, "lme")) {
-        is_si <- any(abs(stats::na.omit(as.numeric(diag(vals$vc))) < tolerance))
-      } else {
-        is_si <- FALSE
-      }
-
-      is_si
-    },
-    error = function(x) {
-      FALSE
-    }
-  )
-}
-
-
-
 # Filter parameters from Stan-model fits
 .filter_pars <- function(l, parameters = NULL, is_mv = NULL) {
   if (!is.null(parameters)) {