Revise compare_models() for Bayesian models

Fixes #716

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)