Fix check_predictions() for brms models with dec() responses (Wiener / RT-choice) (#972)

Co-authored-by: copilot-swe-agent[bot] <198982749+Copilot@users.noreply.github.com>
Co-authored-by: DominiqueMakowski <8875533+DominiqueMakowski@users.noreply.github.com>
Co-authored-by: Daniel <mail@danielluedecke.de>
Co-authored-by: strengejacke <26301769+strengejacke@users.noreply.github.com>

Author: 3 people

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: performance
 Title: Assessment of Regression Models Performance
-Version: 0.18.2.16
+Version: 0.18.2.17
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

NEWS.md

@@ -1,5 +1,10 @@
 # performance (devel)
 
+## Bug fixes
+
+* Fixed issue in `check_predictions()` for *brms* models with `dec()` response
+  (Wiener and RT-choice families); the RT part of the model is now checked.
+
 ## Changes
 
 * `check_outliers()` now computes the default threshold for Cook's distance as

R/check_predictions.R

@@ -225,6 +225,12 @@ check_predictions.stanreg <- function(
     ...
   )
 
+  # Wiener / RT-choice models predict two components; check the RTs
+  is_rt_model <- isTRUE(minfo$is_wiener) || isTRUE(minfo$is_rtchoice)
+  if (is_rt_model && "Component" %in% colnames(out)) {
+    out <- out[out$Component == "rt", , drop = FALSE]
+  }
+
   iter_columns <- startsWith(colnames(out), "iter_")
   if (!any(iter_columns)) {
     insight::format_error(
@@ -247,10 +253,14 @@ check_predictions.stanreg <- function(
 
   response <- insight::get_response(model)
   if (is.data.frame(response)) {
-    response <- eval(
-      str2lang(insight::find_response(model)),
-      envir = insight::get_response(model)
-    )
+    if (is_rt_model) {
+      response <- response[[insight::find_response(model)[1]]]
+    } else {
+      response <- eval(
+        str2lang(insight::find_response(model)),
+        envir = response
+      )
+    }
   }
   out$y <- response
 

tests/testthat/test-check_predictions.R

@@ -317,3 +317,87 @@ withr::with_environment(
     })
   }
 )
+
+test_that("check_predictions, brms-wiener", {
+  skip_on_cran()
+  skip_if_not_installed("curl")
+  skip_if_offline()
+  skip_if_not_installed("httr2")
+  skip_if_not_installed("rstan")
+  skip_if_not_installed("RWiener")
+
+  m <- insight::download_model("brms_wiener_1")
+  skip_if(is.null(m))
+
+  old_opt <- getOption("wiener_backend")
+  options(wiener_backend = "rtdists")
+  on.exit(options(wiener_backend = old_opt))
+  expect_no_error({
+    out <- check_predictions(m)
+  })
+  # fmt: skip
+  expect_named(
+    out,
+    c(
+      "sim_1", "sim_2", "sim_3", "sim_4", "sim_5", "sim_6", "sim_7",
+      "sim_8", "sim_9", "sim_10", "sim_11", "sim_12", "sim_13", "sim_14",
+      "sim_15", "sim_16", "sim_17", "sim_18", "sim_19", "sim_20", "sim_21",
+      "sim_22", "sim_23", "sim_24", "sim_25", "sim_26", "sim_27", "sim_28",
+      "sim_29", "sim_30", "sim_31", "sim_32", "sim_33", "sim_34", "sim_35",
+      "sim_36", "sim_37", "sim_38", "sim_39", "sim_40", "sim_41", "sim_42",
+      "sim_43", "sim_44", "sim_45", "sim_46", "sim_47", "sim_48", "sim_49",
+      "sim_50", "y"
+    )
+  )
+})
+
+
+test_that("check_predictions, RT-choice models keep RT predictions only (mocked)", {
+  skip_if_not_installed("modelbased", minimum_version = "0.12.0")
+
+  n <- 4
+  iter <- 3
+  rt_draws <- matrix(seq_len(n * iter), nrow = n)
+  choice_draws <- matrix(-seq_len(n * iter), nrow = n)
+  colnames(rt_draws) <- colnames(choice_draws) <- paste0("iter_", seq_len(iter))
+  preds <- rbind(
+    data.frame(Component = "rt", rt_draws),
+    data.frame(Component = "response", choice_draws)
+  )
+  colnames(preds) <- c("Component", paste0("iter_", seq_len(iter)))
+  observed <- data.frame(rt = c(0.5, 0.6, 0.7, 0.8), resp = c(1, 0, 1, 1))
+
+  for (flag in c("is_wiener", "is_rtchoice")) {
+    info <- list(
+      is_wiener = FALSE,
+      is_rtchoice = FALSE,
+      is_bernoulli = FALSE,
+      is_count = FALSE,
+      is_ordinal = FALSE,
+      is_categorical = FALSE,
+      is_multinomial = FALSE
+    )
+    info[[flag]] <- TRUE
+    local_mocked_bindings(
+      model_info = function(...) info,
+      find_terms = function(...) list(response = "rt"),
+      find_response = function(...) c("rt", "resp"),
+      get_response = function(...) observed,
+      .package = "insight"
+    )
+    local_mocked_bindings(
+      estimate_prediction = function(...) preds,
+      .package = "modelbased"
+    )
+    model <- structure(list(), class = c("brmsfit", "stanreg"))
+    out <- check_predictions(model, iterations = iter)
+    expect_s3_class(out, "performance_pp_check")
+    expect_equal(nrow(out), n)
+    expect_named(out, c(paste0("sim_", seq_len(iter)), "y"))
+    expect_equal(
+      unname(as.matrix(out[paste0("sim_", seq_len(iter))])),
+      unname(rt_draws)
+    )
+    expect_equal(out$y, observed$rt)
+  }
+})