Handle models without LOOIC in compare_performance() (#960)

Co-authored-by: Daniel <mail@danielluedecke.de>

Author: jmgirard

DESCRIPTION

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

NEWS.md

@@ -9,6 +9,11 @@
 
 ## Bug fixes
 
+* `compare_performance()` no longer fails when only some of the models have
+  LOOIC, for example a *brms* model and a `glm` (#738). It now computes
+  stacking weights for the models that have LOOIC and gives `NA` for the
+  others. A missing weight now prints as an empty cell, not as `(>.999)`.
+
 * `check_model()` no longer fails for *brms* models that cannot be converted
   to a frequentist model. It now returns only the posterior predictive check
   and multicollinearity panels, and a message lists the panels that were

R/compare_performance.R

@@ -156,8 +156,15 @@ compare_performance <- function(
   }
 
   if ("LOOIC" %in% names(dfs)) {
-    lpd_point <- do.call(cbind, lapply(attri, function(x) x$loo$pointwise[, "elpd_loo"]))
-    dfs$LOOIC_wt <- as.numeric(loo::stacking_weights(lpd_point))
+    # stacking weights only for models that have LOO, e.g. not for a glm
+    # compared with a brms model. NA for the other models.
+    has_loo <- !vapply(attri, function(x) is.null(x$loo), logical(1))
+    dfs$LOOIC_wt <- NA_real_
+    if (sum(has_loo) > 1) {
+      lpd_point <- do.call(cbind, lapply(attri[has_loo], function(x) x$loo$pointwise[, "elpd_loo"]))
+      loo_names <- vapply(m[has_loo], function(x) x$Name[1], character(1))
+      dfs$LOOIC_wt[match(loo_names, dfs$Name)] <- as.numeric(loo::stacking_weights(lpd_point))
+    }
   }
 
   # check if all models were fit from same data
@@ -181,7 +188,7 @@ compare_performance <- function(
   }
   if (all(c("AIC", "AIC_wt") %in% names(dfs))) {
     idx1 <- grep("^AIC$", names(dfs))
-    idx2 <- grep("AIC_wt", names(dfs), fixed = TRUE)
+    idx2 <- grep("^AIC_wt$", names(dfs))
     last_part <- (idx1 + 1):ncol(dfs)
     dfs <- dfs[, c(1:idx1, idx2, last_part[last_part != idx2])]
   }

R/format.R

@@ -9,19 +9,26 @@ format.compare_performance <- function(x, digits = 2, ...) {
   # format weighted ICs
   weighted_ics <- endsWith(colnames(x), "_wt")
   if (any(weighted_ics)) {
-    x[weighted_ics] <- lapply(
-      x[weighted_ics],
-      insight::format_bf,
-      name = NULL,
-      exact = TRUE
-    )
+    x[weighted_ics] <- lapply(x[weighted_ics], function(wt) {
+      out <- insight::format_bf(wt, name = NULL, exact = TRUE)
+      # a model without this IC has no weight, not a weight of 1
+      out[is.na(wt)] <- NA
+      out
+    })
   }
 
   if ("BF" %in% colnames(x)) {
     x$BF[is.na(x$BF)] <- 1
     # x$BF <- insight::format_bf(x$BF, exact = TRUE)
   }
-  insight::format_table(x, digits = digits, ...)
+  out <- insight::format_table(x, digits = digits, ...)
+
+  # drop the empty "()" that format_table() adds for a missing weight
+  weight_columns <- endsWith(colnames(out), "(weights)")
+  out[weight_columns] <- lapply(out[weight_columns], function(i) {
+    trimws(gsub("()", "", i, fixed = TRUE))
+  })
+  out
 }
 
 

tests/testthat/test-compare_performance.R

@@ -251,6 +251,42 @@ test_that("compare_performance, Log_loss ranks in the right direction", {
 })
 
 
+test_that("compare_performance, LOOIC weights when not all models have LOOIC", {
+  skip_on_cran()
+  skip_if_not_installed("brms")
+  skip_if_not_installed("loo")
+  skip_if_not_installed("curl")
+  skip_if_offline()
+  skip_if_not_installed("httr2")
+
+  m_brms <- insight::download_model("brms_1")
+  skip_if(is.null(m_brms))
+  m_brms2 <- m_brms
+  m_lm <- lm(insight::find_formula(m_brms)$conditional, data = insight::get_data(m_brms))
+
+  # only one model has LOOIC, so there are no stacking weights (#738)
+  out <- compare_performance(m_lm, m_brms, verbose = FALSE)
+  expect_identical(out$Name, c("m_lm", "m_brms"))
+  expect_true(is.na(out$LOOIC[1]))
+  expect_false(is.na(out$LOOIC[2]))
+  expect_identical(out$LOOIC_wt, c(NA_real_, NA_real_))
+  # a missing weight prints as an empty cell, not as a weight of 1
+  formatted <- format(out)
+  expect_identical(formatted[["LOOIC (weights)"]][1], "")
+  expect_identical(formatted[["AIC (weights)"]][2], "")
+  expect_identical(formatted[["AIC (weights)"]][1], "156.0")
+
+  # stacking weights for the models that have LOOIC, NA for the others
+  out <- compare_performance(m_lm, m_brms, m_brms2, verbose = FALSE)
+  expect_identical(out$Name, c("m_lm", "m_brms", "m_brms2"))
+  expect_true(is.na(out$LOOIC_wt[1]))
+  expect_equal(sum(out$LOOIC_wt[2:3]), 1, tolerance = 1e-6)
+
+  out <- compare_performance(m_lm, m_brms, m_brms2, rank = TRUE, verbose = FALSE)
+  expect_identical(nrow(out), 3L)
+})
+
+
 test_that("compare_performance, RMSE and Sigma still rank in the right direction", {
   data(mtcars)
   l_best <- lm(mpg ~ wt + cyl + hp, data = mtcars)