add model column instead of row names

Author: jgabry

R/loo_compare.R

@@ -10,7 +10,7 @@
 #'   list.
 #'
 #' @return A data frame with class `"compare.loo"` that has its own
-#'   print method. See the **Details** section.
+#'   print method. See the **Details** and **Examples** sections.
 #'
 #' @details
 #'   When comparing two fitted models, we can estimate the difference in their
@@ -149,16 +149,18 @@ loo_compare.default <- function(x, ...) {
     ))
     diag_diff[khat_diff > 0.5] <- "khat_diff > 0.5"
   }
+
   comp <- cbind(
     data.frame(
+      model = rnms,
       elpd_diff = elpd_diff,
       se_diff = se_diff,
       p_worse = p_worse,
       diag_diff = diag_diff
     ),
     as.data.frame(comp)
   )
-  rownames(comp) <- rnms
+  rownames(comp) <- NULL
 
   # run order statistics-based checks for many model comparisons
   loo_order_stat_check(loos, ord)
@@ -175,25 +177,28 @@ loo_compare.default <- function(x, ...) {
 #'   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) {
-  if (!inherits(x, "data.frame") && !inherits(x, "old_compare.loo")) {
+  if (inherits(x, "old_compare.loo")) {
+    return(unclass(x))
+  }
+  if (!inherits(x, "data.frame")) {
     class(x) <- c(class(x), "data.frame")
   }
-  xcopy <- x
-  if (NCOL(xcopy) >= 2) {
-    xcopy <- xcopy[, c("elpd_diff", "se_diff")]
+  if (!all(c("model", "elpd_diff", "se_diff") %in% colnames(x))) {
+    print(as.data.frame(x))
+    return(x)
   }
-  if (p_worse &&
-      "p_worse" %in% colnames(x) &&
-      !inherits(x, "old_compare.loo")) {
-    print(
-      cbind(.fr(xcopy, digits),
-            p_worse = .fr(x[, "p_worse"], 2),
-            diag_diff = x[, "diag_diff"]),
-      quote = FALSE
+  x2 <- cbind(
+    model = x$model,
+    .fr(x[, c("elpd_diff", "se_diff")], digits)
+  )
+  if (p_worse && "p_worse" %in% colnames(x)) {
+    x2 <- cbind(
+      x2,
+      p_worse = .fr(x[, "p_worse"], digits = 2),
+      diag_diff = x[, "diag_diff"]
     )
-  } else {
-    print(.fr(xcopy, digits), quote = FALSE)
   }
+  print(x2, quote = FALSE)
   invisible(x)
 }
 

man/loo_compare.Rd

@@ -1,48 +1,86 @@
 # loo_compare returns expected results (2 models)
 
-    WAoAAAACAAQEAgACAwAAAAMTAAAACgAAAA4AAAACAAAAAAAAAADAEDpTX5xF7gAAAA4AAAAC
-    AAAAAAAAAAA/tmpHtC8TAQAAAA4AAAACf/AAAAAAB6I/8AAAAAAAAAAAABAAAAACAAQACQAA
-    AAAABAAJAAAAB04gPCAxMDAAAAAOAAAAAsBU4fDdyUJYwFXllhPDBrkAAAAOAAAAAkARCD2z
-    EXBfQBEalRIN2T8AAAAOAAAAAkAKKMBh1blTQCZnlesA0IoAAAAOAAAAAj/x/WXscvNeP/Gb
-    YJxtZ8cAAAAOAAAAAkBk4fDdyUJYQGXllhPDBrkAAAAOAAAAAkAhCD2zEXBfQCEalRIN2T8A
-    AAQCAAAAAQAEAAkAAAAFbmFtZXMAAAAQAAAACgAEAAkAAAAJZWxwZF9kaWZmAAQACQAAAAdz
-    ZV9kaWZmAAQACQAAAAdwX3dvcnNlAAQACQAAAAlkaWFnX2RpZmYABAAJAAAACWVscGRfd2Fp
-    YwAEAAkAAAAMc2VfZWxwZF93YWljAAQACQAAAAZwX3dhaWMABAAJAAAACXNlX3Bfd2FpYwAE
-    AAkAAAAEd2FpYwAEAAkAAAAHc2Vfd2FpYwAABAIAAAABAAQACQAAAAVjbGFzcwAAABAAAAAC
-    AAQACQAAAAtjb21wYXJlLmxvbwAEAAkAAAAKZGF0YS5mcmFtZQAABAIAAAABAAQACQAAAAly
-    b3cubmFtZXMAAAAQAAAAAgAEAAkAAAAGbW9kZWwxAAQACQAAAAZtb2RlbDIAAAD+
+    WAoAAAACAAQEAgACAwAAAAMTAAAACwAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v
+    ZGVsMgAAAA4AAAACAAAAAAAAAAAAAAAAAAAAAAAAAA4AAAACAAAAAAAAAAAAAAAAAAAAAAAA
+    AA4AAAACf/AAAAAAB6J/8AAAAAAHogAAABAAAAACAAQACQAAAAAABAAJAAAAAAAAAA4AAAAC
+    wFTh8N3JQljAVOHw3clCWAAAAA4AAAACQBEIPbMRcF9AEQg9sxFwXwAAAA4AAAACQAoowGHV
+    uVNACijAYdW5UwAAAA4AAAACP/H9Zexy814/8f1l7HLzXgAAAA4AAAACQGTh8N3JQlhAZOHw
+    3clCWAAAAA4AAAACQCEIPbMRcF9AIQg9sxFwXwAABAIAAAABAAQACQAAAAVuYW1lcwAAABAA
+    AAALAAQACQAAAAVtb2RlbAAEAAkAAAAJZWxwZF9kaWZmAAQACQAAAAdzZV9kaWZmAAQACQAA
+    AAdwX3dvcnNlAAQACQAAAAlkaWFnX2RpZmYABAAJAAAACWVscGRfd2FpYwAEAAkAAAAMc2Vf
+    ZWxwZF93YWljAAQACQAAAAZwX3dhaWMABAAJAAAACXNlX3Bfd2FpYwAEAAkAAAAEd2FpYwAE
+    AAkAAAAHc2Vfd2FpYwAABAIAAAABAAQACQAAAAVjbGFzcwAAABAAAAACAAQACQAAAAtjb21w
+    YXJlLmxvbwAEAAkAAAAKZGF0YS5mcmFtZQAABAIAAAABAAQACQAAAAlyb3cubmFtZXMAAAAN
+    AAAAAoAAAAD////+AAAA/g==
 
-# loo_compare returns expected result (3 models)
+---
+
+    Code
+      print(comp1)
+    Output
+         model elpd_diff se_diff p_worse diag_diff
+      1 model1       0.0     0.0      NA          
+      2 model2       0.0     0.0      NA          
 
-    WAoAAAACAAQEAgACAwAAAAMTAAAACgAAAA4AAAADAAAAAAAAAADAEDpTX5xF7sAwDcqRtgQY
-    AAAADgAAAAMAAAAAAAAAAD+2ake0LxMBP8uv7eE07V4AAAAOAAAAA3/wAAAAAAeiP/AAAAAA
-    AAA/8AAAAAAAAAAAABAAAAADAAQACQAAAAAABAAJAAAAB04gPCAxMDAABAAJAAAAB04gPCAx
-    MDAAAAAOAAAAA8BU4fDdyUJYwFXllhPDBrnAWOVjgjbDYgAAAA4AAAADQBEIPbMRcF9AERqV
-    Eg3ZP0AQ8gXcaKATAAAADgAAAANACijAYdW5U0AmZ5XrANCKQEHI2FIa3QoAAAAOAAAAAz/x
-    /WXscvNeP/GbYJxtZ8c/8YDQkmfJXwAAAA4AAAADQGTh8N3JQlhAZeWWE8MGuUBo5WOCNsNi
-    AAAADgAAAANAIQg9sxFwX0AhGpUSDdk/QCDyBdxooBMAAAQCAAAAAQAEAAkAAAAFbmFtZXMA
-    AAAQAAAACgAEAAkAAAAJZWxwZF9kaWZmAAQACQAAAAdzZV9kaWZmAAQACQAAAAdwX3dvcnNl
-    AAQACQAAAAlkaWFnX2RpZmYABAAJAAAACWVscGRfd2FpYwAEAAkAAAAMc2VfZWxwZF93YWlj
-    AAQACQAAAAZwX3dhaWMABAAJAAAACXNlX3Bfd2FpYwAEAAkAAAAEd2FpYwAEAAkAAAAHc2Vf
-    d2FpYwAABAIAAAABAAQACQAAAAVjbGFzcwAAABAAAAACAAQACQAAAAtjb21wYXJlLmxvbwAE
-    AAkAAAAKZGF0YS5mcmFtZQAABAIAAAABAAQACQAAAAlyb3cubmFtZXMAAAAQAAAAAwAEAAkA
-    AAAGbW9kZWwxAAQACQAAAAZtb2RlbDIABAAJAAAABm1vZGVsMwAAAP4=
-
-# compare returns expected result (2 models)
+---
+
+    WAoAAAACAAQEAgACAwAAAAMTAAAACwAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v
+    ZGVsMgAAAA4AAAACAAAAAAAAAADAEDpTX5xF7gAAAA4AAAACAAAAAAAAAAA/tmpHtC8TAQAA
+    AA4AAAACf/AAAAAAB6I/8AAAAAAAAAAAABAAAAACAAQACQAAAAAABAAJAAAAB04gPCAxMDAA
+    AAAOAAAAAsBU4fDdyUJYwFXllhPDBrkAAAAOAAAAAkARCD2zEXBfQBEalRIN2T8AAAAOAAAA
+    AkAKKMBh1blTQCZnlesA0IoAAAAOAAAAAj/x/WXscvNeP/GbYJxtZ8cAAAAOAAAAAkBk4fDd
+    yUJYQGXllhPDBrkAAAAOAAAAAkAhCD2zEXBfQCEalRIN2T8AAAQCAAAAAQAEAAkAAAAFbmFt
+    ZXMAAAAQAAAACwAEAAkAAAAFbW9kZWwABAAJAAAACWVscGRfZGlmZgAEAAkAAAAHc2VfZGlm
+    ZgAEAAkAAAAHcF93b3JzZQAEAAkAAAAJZGlhZ19kaWZmAAQACQAAAAllbHBkX3dhaWMABAAJ
+    AAAADHNlX2VscGRfd2FpYwAEAAkAAAAGcF93YWljAAQACQAAAAlzZV9wX3dhaWMABAAJAAAA
+    BHdhaWMABAAJAAAAB3NlX3dhaWMAAAQCAAAAAQAEAAkAAAAFY2xhc3MAAAAQAAAAAgAEAAkA
+    AAALY29tcGFyZS5sb28ABAAJAAAACmRhdGEuZnJhbWUAAAQCAAAAAQAEAAkAAAAJcm93Lm5h
+    bWVzAAAADQAAAAKAAAAA/////gAAAP4=
+
+---
 
     Code
-      comp1
+      print(comp2)
     Output
-      elpd_diff        se 
-            0.0       0.0 
+         model elpd_diff se_diff p_worse diag_diff
+      1 model1       0.0     0.0      NA          
+      2 model2      -4.1     0.1    1.00   N < 100
+
+---
+
+    Code
+      print(comp2, p_worse = FALSE)
+    Output
+         model elpd_diff se_diff
+      1 model1       0.0     0.0
+      2 model2      -4.1     0.1
+
+# loo_compare returns expected result (3 models)
+
+    WAoAAAACAAQEAgACAwAAAAMTAAAACwAAABAAAAADAAQACQAAAAZtb2RlbDEABAAJAAAABm1v
+    ZGVsMgAEAAkAAAAGbW9kZWwzAAAADgAAAAMAAAAAAAAAAMAQOlNfnEXuwDANypG2BBgAAAAO
+    AAAAAwAAAAAAAAAAP7ZqR7QvEwE/y6/t4TTtXgAAAA4AAAADf/AAAAAAB6I/8AAAAAAAAD/w
+    AAAAAAAAAAAAEAAAAAMABAAJAAAAAAAEAAkAAAAHTiA8IDEwMAAEAAkAAAAHTiA8IDEwMAAA
+    AA4AAAADwFTh8N3JQljAVeWWE8MGucBY5WOCNsNiAAAADgAAAANAEQg9sxFwX0ARGpUSDdk/
+    QBDyBdxooBMAAAAOAAAAA0AKKMBh1blTQCZnlesA0IpAQcjYUhrdCgAAAA4AAAADP/H9Zexy
+    814/8ZtgnG1nxz/xgNCSZ8lfAAAADgAAAANAZOHw3clCWEBl5ZYTwwa5QGjlY4I2w2IAAAAO
+    AAAAA0AhCD2zEXBfQCEalRIN2T9AIPIF3GigEwAABAIAAAABAAQACQAAAAVuYW1lcwAAABAA
+    AAALAAQACQAAAAVtb2RlbAAEAAkAAAAJZWxwZF9kaWZmAAQACQAAAAdzZV9kaWZmAAQACQAA
+    AAdwX3dvcnNlAAQACQAAAAlkaWFnX2RpZmYABAAJAAAACWVscGRfd2FpYwAEAAkAAAAMc2Vf
+    ZWxwZF93YWljAAQACQAAAAZwX3dhaWMABAAJAAAACXNlX3Bfd2FpYwAEAAkAAAAEd2FpYwAE
+    AAkAAAAHc2Vfd2FpYwAABAIAAAABAAQACQAAAAVjbGFzcwAAABAAAAACAAQACQAAAAtjb21w
+    YXJlLmxvbwAEAAkAAAAKZGF0YS5mcmFtZQAABAIAAAABAAQACQAAAAlyb3cubmFtZXMAAAAN
+    AAAAAoAAAAD////9AAAA/g==
 
 ---
 
     Code
-      comp2
+      print(comp1)
     Output
-      elpd_diff        se 
-           -4.1       0.1 
+         model elpd_diff se_diff p_worse diag_diff
+      1 model1       0.0     0.0      NA          
+      2 model2      -4.1     0.1    1.00   N < 100
+      3 model3     -16.1     0.2    1.00   N < 100
 
 # compare returns expected result (3 models)
 

tests/testthat/_snaps/compare.md

@@ -60,6 +60,7 @@ test_that("loo_compare throws appropriate warnings", {
 
 
 comp_colnames <- c(
+  "model",
   "elpd_diff",
   "se_diff",
   "p_worse",
@@ -77,19 +78,26 @@ test_that("loo_compare returns expected results (2 models)", {
   expect_s3_class(comp1, "compare.loo")
   expect_s3_class(comp1, "data.frame")
   expect_equal(colnames(comp1), comp_colnames)
-  expect_equal(rownames(comp1), c("model1", "model2"))
-  expect_output(print(comp1), "elpd_diff")
-  expect_equal(comp1[1:2, 1], c(0, 0), ignore_attr = TRUE)
-  expect_equal(comp1[1:2, 2], c(0, 0), ignore_attr = TRUE)
+  expect_equal(comp1$model, c("model1", "model2"))
+  expect_equal(comp1$elpd_diff, c(0, 0), ignore_attr = TRUE)
+  expect_equal(comp1$se_diff, c(0, 0), ignore_attr = TRUE)
+  expect_equal(comp1$p_worse, c(NA_real_, NA_real_), ignore_attr = TRUE)
+  expect_snapshot_value(comp1, style = "serialize")
+  expect_snapshot(print(comp1))
 
   comp2 <- loo_compare(w1, w2)
   expect_s3_class(comp2, "compare.loo")
   expect_equal(colnames(comp2), comp_colnames)
-
   expect_snapshot_value(comp2, style = "serialize")
+  expect_snapshot(print(comp2))
+  expect_snapshot(print(comp2, p_worse = FALSE))
 
   # specifying objects via ... and via arg x gives equal results
   expect_equal(comp2, loo_compare(x = list(w1, w2)))
+
+  # custom naming works
+  comp3 <- loo_compare(x = list("A" = w2, "B" = w1))
+  expect_equal(comp3$model, c("B", "A"))
 })
 
 
@@ -98,12 +106,12 @@ test_that("loo_compare returns expected result (3 models)", {
   comp1 <- loo_compare(w1, w2, w3)
 
   expect_equal(colnames(comp1), comp_colnames)
-  expect_equal(rownames(comp1), c("model1", "model2", "model3"))
-  expect_equal(comp1[1, 1], 0)
+  expect_equal(comp1$model, c("model1", "model2", "model3"))
+  expect_equal(comp1$p_worse, c(NA, 1, 1))
   expect_s3_class(comp1, "compare.loo")
   expect_s3_class(comp1, "data.frame")
-
   expect_snapshot_value(comp1, style = "serialize")
+  expect_snapshot(print(comp1))
 
   # specifying objects via '...' gives equivalent results (equal
   # except rownames) to using 'x' argument
@@ -119,13 +127,11 @@ test_that("compare throws deprecation warnings", {
 
 test_that("compare returns expected result (2 models)", {
   expect_warning(comp1 <- loo::compare(w1, w1), "Deprecated")
-  expect_snapshot(comp1)
   expect_equal(comp1[1:2], c(elpd_diff = 0, se = 0))
 
   expect_warning(comp2 <- loo::compare(w1, w2), "Deprecated")
-  expect_snapshot(comp2)
-  expect_named(comp2, c("elpd_diff", "se"))
-  expect_s3_class(comp2, "compare.loo")
+  expect_equal(round(comp2[1:2], 3), c(elpd_diff = -4.057, se = 0.088))
+  expect_s3_class(comp2, "old_compare.loo")
 
   # specifying objects via ... and via arg x gives equal results
   expect_warning(comp_via_list <- loo::compare(x = list(w1, w2)), "Deprecated")