From 6752208ade4adae402da5fc50bae5592585c9da2 Mon Sep 17 00:00:00 2001
From: Daniel <mail@danielluedecke.de>
Date: Sun, 24 Nov 2024 18:13:42 +0100
Subject: [PATCH] Revise compare_models() for Bayesian models Fixes #716

---
 R/compare_performance.R | 51 +++++++++++++++++++++++------------------
 1 file changed, 29 insertions(+), 22 deletions(-)

diff --git a/R/compare_performance.R b/R/compare_performance.R
index 2318d5e63..e326adc24 100644
--- a/R/compare_performance.R
+++ b/R/compare_performance.R
@@ -89,7 +89,10 @@ compare_performance <- function(..., metrics = "all", rank = FALSE, estimator =
   model_objects <- insight::ellipsis_info(..., only_models = TRUE)
 
   # ensure proper object names
-  model_objects <- .check_objectnames(model_objects, sapply(match.call(expand.dots = FALSE)[["..."]], as.character))
+  model_objects <- .check_objectnames(
+    model_objects,
+    sapply(match.call(expand.dots = FALSE)[["..."]], as.character)
+  )
 
   # drop unsupport models
   supported_models <- sapply(model_objects, function(i) insight::is_model_supported(i) | inherits(i, "lavaan"))
@@ -119,14 +122,14 @@ compare_performance <- function(..., metrics = "all", rank = FALSE, estimator =
   })
   dfs <- Reduce(function(x, y) merge(x, y, all = TRUE, sort = FALSE), m)
 
-  if (any(c("AIC", "AICc", "BIC", "WAIC") %in% names(dfs))) {
+  if (any(c("AIC", "AICc", "BIC", "WAIC") %in% colnames(dfs))) {
     dfs$AIC_wt <- .ic_weight(dfs[["AIC"]])
     dfs$AICc_wt <- .ic_weight(dfs[["AICc"]])
     dfs$BIC_wt <- .ic_weight(dfs[["BIC"]])
     dfs$WAIC_wt <- .ic_weight(dfs[["WAIC"]])
   }
 
-  if ("LOOIC" %in% names(dfs)) {
+  if ("LOOIC" %in% colnames(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))
   }
@@ -144,49 +147,53 @@ compare_performance <- function(..., metrics = "all", rank = FALSE, estimator =
   }
 
   # Reorder columns
-  if (all(c("BIC", "BF") %in% names(dfs))) {
-    idx1 <- grep("^BIC$", names(dfs))
-    idx2 <- grep("BF", names(dfs), fixed = TRUE)
+  if (all(c("BIC", "BF") %in% colnames(dfs))) {
+    idx1 <- grep("^BIC$", colnames(dfs))
+    idx2 <- grep("BF", colnames(dfs), fixed = TRUE)
     last_part <- (idx1 + 1):ncol(dfs)
     dfs <- dfs[, c(1:idx1, idx2, last_part[last_part != idx2])]
   }
-  if (all(c("AIC", "AIC_wt") %in% names(dfs))) {
-    idx1 <- grep("^AIC$", names(dfs))
-    idx2 <- grep("AIC_wt", names(dfs), fixed = TRUE)
+  if (all(c("AIC", "AIC_wt") %in% colnames(dfs))) {
+    idx1 <- grep("^AIC$", colnames(dfs))
+    idx2 <- grep("AIC_wt", colnames(dfs), fixed = TRUE)
     last_part <- (idx1 + 1):ncol(dfs)
     dfs <- dfs[, c(1:idx1, idx2, last_part[last_part != idx2])]
   }
-  if (all(c("BIC", "BIC_wt") %in% names(dfs))) {
-    idx1 <- grep("^BIC$", names(dfs))
-    idx2 <- grep("BIC_wt", names(dfs), fixed = TRUE)
+  if (all(c("BIC", "BIC_wt") %in% colnames(dfs))) {
+    idx1 <- grep("^BIC$", colnames(dfs))
+    idx2 <- grep("BIC_wt", colnames(dfs), fixed = TRUE)
     last_part <- (idx1 + 1):ncol(dfs)
     dfs <- dfs[, c(1:idx1, idx2, last_part[last_part != idx2])]
   }
-  if (all(c("AICc", "AICc_wt") %in% names(dfs))) {
-    idx1 <- grep("^AICc$", names(dfs))
-    idx2 <- grep("AICc_wt", names(dfs), fixed = TRUE)
+  if (all(c("AICc", "AICc_wt") %in% colnames(dfs))) {
+    idx1 <- grep("^AICc$", colnames(dfs))
+    idx2 <- grep("AICc_wt", colnames(dfs), fixed = TRUE)
     last_part <- (idx1 + 1):ncol(dfs)
     dfs <- dfs[, c(1:idx1, idx2, last_part[last_part != idx2])]
   }
-  if (all(c("WAIC", "WAIC_wt") %in% names(dfs))) {
-    idx1 <- grep("^WAIC$", names(dfs))
-    idx2 <- grep("WAIC_wt", names(dfs), fixed = TRUE)
+  if (all(c("WAIC", "WAIC_wt") %in% colnames(dfs))) {
+    idx1 <- grep("^WAIC$", colnames(dfs))
+    idx2 <- grep("WAIC_wt", colnames(dfs), fixed = TRUE)
     last_part <- (idx1 + 1):ncol(dfs)
     dfs <- dfs[, c(1:idx1, idx2, last_part[last_part != idx2])]
   }
-  if (all(c("LOOIC", "LOOIC_wt") %in% names(dfs))) {
-    idx1 <- grep("^LOOIC$", names(dfs))
-    idx2 <- grep("LOOIC_wt", names(dfs), fixed = TRUE)
+  if (all(c("LOOIC", "LOOIC_wt") %in% colnames(dfs))) {
+    idx1 <- grep("^LOOIC$", colnames(dfs))
+    idx2 <- grep("LOOIC_wt", colnames(dfs), fixed = TRUE)
     last_part <- (idx1 + 1):ncol(dfs)
     dfs <- dfs[, c(1:idx1, idx2, last_part[last_part != idx2])]
   }
+  if (any(startsWith(colnames(dfs), "R2"))) {
+    idx <- which(startsWith(colnames(dfs), "R2"))
+    dfs <- dfs[, c(1, 2, idx, setdiff(seq_len(ncol(dfs)), idx))]
+  }
 
   # for REML fits, warn user
   if (isTRUE(verbose) &&
     # only warn for REML fit
     identical(estimator, "REML") &&
     # only for IC comparison
-    any(grepl("(AIC|BIC)", names(dfs))) &&
+    any(grepl("(AIC|BIC)", colnames(dfs))) &&
     # only when mixed models are involved, others probably don't have problems with REML fit
     any(sapply(model_objects, insight::is_mixed_model)) &&
     # only if not all models have same fixed effects (else, REML is ok)