Merge pull request #383 from stan-dev/feat/add-simplify

Add `simplify` argument to `print.compare.loo`

Author: jgabry

NEWS.md

@@ -1,5 +1,8 @@
 # loo (development version)
 
+* `print.compare.loo()` regains a `simplify` argument for showing the full
+  comparison table with `simplify = FALSE` by @florence-bockting in #383.
+
 # loo 2.10.0
 
 * Updates to `loo_compare` output by @jgabry, @avehtari, @florence-bockting in #300: 

R/loo_compare.R

@@ -91,6 +91,7 @@
 #'
 #' comp <- loo_compare(loo1, loo2, loo3)
 #' print(comp, digits = 2)
+#' print(comp, simplify = FALSE) # full table
 #'
 #' # can use a list of objects with custom names
 #' # the names will be used in the output
@@ -170,7 +171,13 @@ loo_compare.default <- function(x, ...) {
 #' @param p_worse For the print method only, should we include the normal
 #'   approximation based probability of each model having worse performance than
 #'   the best model? The default is `TRUE`.
-print.compare.loo <- function(x, ..., digits = 1, p_worse = TRUE) {
+#' @param simplify For the print method only, should the output be simplified to
+#'   only include the model names, ELPD differences, and (when `p_worse = TRUE`)
+#'   diagnostic columns? The default is `TRUE`. Set to `FALSE` to also print the
+#'   available estimate columns (pointwise ELPD, LOOIC/WAIC, and their standard
+#'   errors).
+print.compare.loo <- function(x, ..., digits = 1, p_worse = TRUE,
+                              simplify = TRUE) {
   if (inherits(x, "old_compare.loo")) {
     return(unclass(x))
   }
@@ -181,19 +188,35 @@ print.compare.loo <- function(x, ..., digits = 1, p_worse = TRUE) {
     print(as.data.frame(x))
     return(x)
   }
-  x2 <- cbind(
-    model = x$model,
-    .fr(x[, c("elpd_diff", "se_diff")], digits)
+  base_cols <- c("model", "elpd_diff", "se_diff")
+  diag_cols <- c("p_worse", "diag_diff", "diag_elpd")
+  show_diag <- p_worse && "p_worse" %in% colnames(x)
+
+  estimate_cols <- setdiff(colnames(x), c(base_cols, diag_cols))
+  estimate_cols <- estimate_cols[vapply(x[estimate_cols], is.numeric, logical(1))]
+
+  cols <- c(
+    base_cols,
+    if (show_diag) diag_cols,
+    if (!simplify) estimate_cols
   )
-  if (p_worse && "p_worse" %in% colnames(x)) {
-    x2 <- cbind(
-      x2,
-      p_worse = .fr(x[, "p_worse"], digits = 2),
-      diag_diff = x[, "diag_diff"],
-      diag_elpd = x[, "diag_elpd"]
-    )
+  cols <- intersect(cols, colnames(x))
+
+  x2 <- x[, cols, drop = FALSE]
+
+  fmt_cols <- setdiff(cols, c("model", "diag_diff", "diag_elpd"))
+  if (length(fmt_cols)) {
+    if ("p_worse" %in% fmt_cols) {
+      x2$p_worse <- .fr(x2$p_worse, digits = 2)
+      fmt_cols <- setdiff(fmt_cols, "p_worse")
+    }
+    if (length(fmt_cols)) {
+      x2[fmt_cols] <- .fr(x2[fmt_cols], digits)
+    }
   }
-  print(x2, quote = FALSE, row.names = FALSE)
+  # Use `as.data.frame(x2)` here to drop "compare.loo"
+  # so print() uses print.data.frame.
+  print(as.data.frame(x2), quote = FALSE, row.names = FALSE)
 
   # show glossary for diagnostic flags
   has_diag <- any(nzchar(x[["diag_diff"]], keepNA = FALSE), na.rm = TRUE) ||

man/loo_compare.Rd

@@ -62,6 +62,32 @@
        model1       0.0     0.0
        model2      -4.1     0.1
 
+---
+
+    Code
+      print(comp2, simplify = FALSE)
+    Output
+        model elpd_diff se_diff p_worse diag_diff diag_elpd elpd_waic se_elpd_waic
+       model1       0.0     0.0      NA                         -83.5          4.3
+       model2      -4.1     0.1    1.00   N < 100               -87.6          4.3
+       p_waic se_p_waic  waic se_waic
+          3.3       1.1 167.1     8.5
+         11.2       1.1 175.2     8.6
+    Message
+      
+      Diagnostic flags present.
+      See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
+      or https://mc-stan.org/loo/reference/loo-glossary.html.
+
+---
+
+    Code
+      print(comp2, simplify = FALSE, p_worse = FALSE)
+    Output
+        model elpd_diff se_diff elpd_waic se_elpd_waic p_waic se_p_waic  waic se_waic
+       model1       0.0     0.0     -83.5          4.3    3.3       1.1 167.1     8.5
+       model2      -4.1     0.1     -87.6          4.3   11.2       1.1 175.2     8.6
+
 # loo_compare returns expected result (3 models)
 
     WAoAAAACAAQEAgACAwAAAAMTAAAADAAAABAAAAADAAQACQAAAAZtb2RlbDEABAAJAAAABm1v
@@ -95,6 +121,25 @@
       See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
       or https://mc-stan.org/loo/reference/loo-glossary.html.
 
+# loo_compare with simplify=FALSE returns expected result
+
+    Code
+      print(comp, simplify = FALSE)
+    Output
+        model elpd_diff se_diff p_worse diag_diff diag_elpd elpd_loo se_elpd_loo
+       model3       0.0     0.0      NA                        -19.6         4.3
+       model2     -32.0     0.0    1.00   N < 100              -51.6         4.3
+       model1     -64.0     0.0    1.00   N < 100              -83.6         4.3
+       p_loo se_p_loo looic se_looic
+         3.3      1.2  39.2      8.6
+         3.3      1.2 103.2      8.6
+         3.3      1.2 167.2      8.6
+    Message
+      
+      Diagnostic flags present.
+      See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
+      or https://mc-stan.org/loo/reference/loo-glossary.html.
+
 # compare returns expected result (3 models)
 
     WAoAAAACAAQFAAACAwAAAAMOAAAAGAAAAAAAAAAAwBA6U1+cRe7AMA3KkbYEGAAAAAAAAAAA

tests/testthat/_snaps/compare.md

@@ -109,6 +109,8 @@ test_that("loo_compare returns expected results (2 models)", {
   expect_snapshot_value(comp2, style = "serialize")
   expect_snapshot(print(comp2))
   expect_snapshot(print(comp2, p_worse = FALSE))
+  expect_snapshot(print(comp2, simplify = FALSE))
+  expect_snapshot(print(comp2, simplify = FALSE, p_worse = FALSE))
 
   # specifying objects via ... and via arg x gives equal results
   expect_equal(comp2, loo_compare(x = list(w1, w2)))
@@ -118,7 +120,6 @@ test_that("loo_compare returns expected results (2 models)", {
   expect_equal(comp3$model, c("B", "A"))
 })
 
-
 test_that("loo_compare returns expected result (3 models)", {
   w3 <- suppressWarnings(waic(LLarr3))
   comp1 <- loo_compare(w1, w2, w3)
@@ -137,6 +138,15 @@ test_that("loo_compare returns expected result (3 models)", {
   expect_equal(comp1, loo_compare(x = list(w1, w2, w3)), ignore_attr = TRUE)
 })
 
+test_that("loo_compare with simplify=FALSE returns expected result", {
+  LL <- example_loglik_array()
+  loo1 <- loo(LL)
+  loo2 <- loo(LL + 1)
+  loo3 <- loo(LL + 2)
+  comp <- loo_compare(loo1, loo2, loo3)
+  expect_snapshot(print(comp, simplify = FALSE))
+})
+
 # Tests for deprecated compare() ------------------------------------------
 
 test_that("compare throws deprecation warnings", {