diff --git a/NEWS.md b/NEWS.md index d998539c..dfe2897c 100644 --- a/NEWS.md +++ b/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: diff --git a/R/loo_compare.R b/R/loo_compare.R index ce5bea4a..4e7146b6 100644 --- a/R/loo_compare.R +++ b/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) || diff --git a/man/loo_compare.Rd b/man/loo_compare.Rd index c54b9f86..11dae77d 100644 --- a/man/loo_compare.Rd +++ b/man/loo_compare.Rd @@ -12,7 +12,7 @@ loo_compare(x, ...) \method{loo_compare}{default}(x, ...) -\method{print}{compare.loo}(x, ..., digits = 1, p_worse = TRUE) +\method{print}{compare.loo}(x, ..., digits = 1, p_worse = TRUE, simplify = TRUE) \method{print}{compare.loo_ss}(x, ..., digits = 1) } @@ -30,6 +30,12 @@ printing.} \item{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 \code{TRUE}.} + +\item{simplify}{For the print method only, should the output be simplified to +only include the model names, ELPD differences, and (when \code{p_worse = TRUE}) +diagnostic columns? The default is \code{TRUE}. Set to \code{FALSE} to also print the +available estimate columns (pointwise ELPD, LOOIC/WAIC, and their standard +errors).} } \value{ A data frame with class \code{"compare.loo"} that has its own @@ -118,6 +124,7 @@ loo3 <- loo(LL + 2) # should be best model when compared 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 diff --git a/tests/testthat/_snaps/compare.md b/tests/testthat/_snaps/compare.md index 8abb5cf3..c7b40534 100644 --- a/tests/testthat/_snaps/compare.md +++ b/tests/testthat/_snaps/compare.md @@ -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 diff --git a/tests/testthat/test_compare.R b/tests/testthat/test_compare.R index 4a00a10a..e672ef07 100644 --- a/tests/testthat/test_compare.R +++ b/tests/testthat/test_compare.R @@ -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", {