Forward type, detrend, and size_title in check_model() methods for converted and wrapped models

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: performance
 Title: Assessment of Regression Models Performance
-Version: 0.19.0.2
+Version: 0.19.0.3
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",
@@ -77,9 +77,9 @@ BugReports: https://github.com/easystats/performance/issues
 Depends:
     R (>= 4.0)
 Imports:
-    bayestestR (>= 0.19.0),
-    insight (>= 1.5.4),
-    datawizard (>= 1.4.0),
+    bayestestR (>= 0.20.0),
+    insight (>= 1.6.0),
+    datawizard (>= 1.4.1),
     stats,
     methods,
     utils

NEWS.md

@@ -10,6 +10,16 @@
 
 ## Bug fixes
 
+* `check_model()` now applies its defaults for `type` and `detrend` to more
+  objects. These are *rstanarm* and *brms* models that can be converted to a
+  frequentist model, and `model_fit` objects from package *parsnip*. They are
+  also objects from `simulate_residuals()` or package *DHARMa*. Models with a
+  binary, count, ordinal, categorical, or multinomial response thus get the
+  `"discrete_interval"` posterior predictive check. Q-Q plots of simulated
+  residuals are no longer detrended by default. Before, these objects always got
+  `type = "density"` and `detrend = TRUE` by default. These objects also ignored
+  `size_title`, which is now passed on.
+
 * `compare_performance()` no longer returns wrong LOOIC weights for models fit
   to different numbers of observations. Before, it recycled the pointwise LOO
   values of the smaller model to the length of the larger one. Now all LOOIC

R/check_model.R

@@ -332,8 +332,9 @@ check_model.default <- function(
     residual_type <- "normal"
   }
 
-  # set default for detrend
-  if (missing(detrend)) {
+  # set default for detrend; methods that call `check_model()` on another
+  # model pass `detrend = NULL` when the user gave no `detrend`
+  if (missing(detrend) || is.null(detrend)) {
     detrend <- residual_type == "normal"
   }
 
@@ -396,7 +397,9 @@ check_model.default <- function(
     detrend = detrend,
     bandwidth = bandwidth,
     type = type,
-    type_missing = missing(type),
+    # methods that call `check_model()` on another model pass `type = NULL`
+    # when the user gave no `type`
+    type_missing = missing(type) || is.null(type),
     show_dots = show_dots,
     show_ci = show_ci,
     show_smooth = show_smooth,
@@ -455,6 +458,9 @@ check_model.default <- function(
   if (type_missing && suggest_dots) {
     type <- "discrete_interval"
   }
+  if (is.null(type)) {
+    type <- "density"
+  }
 
   # set default for show_dots, based on "model size"
   n <- .safe(insight::n_obs(model))
@@ -583,6 +589,7 @@ check_model.stanreg <- function(
       # bayestestR renamed `resp` to `response`, see https://github.com/easystats/bayestestR/pull/790
       bayestestR::bayesian_as_frequentist(model, response = resp)
     } else {
+      ## TODO: remove this once bayestest 0.20.1 or higher is on CRAN
       bayestestR::bayesian_as_frequentist(model, resp = resp)
     },
     error = function(e) {
@@ -607,10 +614,11 @@ check_model.stanreg <- function(
       conversion_error = conversion_error,
       panel = panel,
       check = check,
-      detrend = detrend,
+      # `detrend` is NULL when a `model_fit` object wraps the model
+      detrend = is.null(detrend) || isTRUE(detrend),
       bandwidth = bandwidth,
       type = type,
-      type_missing = missing(type),
+      type_missing = missing(type) || is.null(type),
       show_dots = show_dots,
       show_ci = show_ci,
       show_smooth = show_smooth,
@@ -634,6 +642,7 @@ check_model.stanreg <- function(
     model = freq_model,
     size_dot = size_dot,
     size_line = size_line,
+    size_title = size_title,
     panel = panel,
     check = check,
     alpha = alpha,
@@ -642,12 +651,14 @@ check_model.stanreg <- function(
     theme = theme,
     base_size = base_size,
     size_axis_title = size_axis_title,
-    detrend = detrend,
+    # NULL lets `check_model.default()` choose the default for the converted model
+    detrend = if (!missing(detrend)) detrend,
     show_dots = show_dots,
     show_ci = show_ci,
     show_smooth = show_smooth,
     bandwidth = bandwidth,
-    type = type,
+    # NULL lets `check_model.default()` choose the default for the converted model
+    type = if (!missing(type)) type,
     residual_type = residual_type,
     maximum_dots = maximum_dots,
     ppc_range = ppc_range,
@@ -859,6 +870,7 @@ check_model.model_fit <- function(
     model$fit,
     size_dot = size_dot,
     size_line = size_line,
+    size_title = size_title,
     panel = panel,
     check = check,
     alpha = alpha,
@@ -867,13 +879,15 @@ check_model.model_fit <- function(
     colors = colors,
     theme = theme,
     base_size = base_size,
-    detrend = detrend,
+    # NULL lets the method for the fitted model choose the default
+    detrend = if (!missing(detrend)) detrend,
     show_dots = show_dots,
     show_ci = show_ci,
     show_smooth = show_smooth,
     maximum_dots = maximum_dots,
     bandwidth = bandwidth,
-    type = type,
+    # NULL lets the method for the fitted model choose the default
+    type = if (!missing(type)) type,
     residual_type = residual_type,
     ppc_range = ppc_range,
     verbose = verbose,
@@ -921,6 +935,7 @@ check_model.performance_simres <- function(
     model$fittedModel,
     size_dot = size_dot,
     size_line = size_line,
+    size_title = size_title,
     panel = panel,
     check = check,
     alpha = alpha,
@@ -929,13 +944,15 @@ check_model.performance_simres <- function(
     colors = colors,
     theme = theme,
     base_size = base_size,
-    detrend = detrend,
+    # NULL lets the method for the fitted model choose the default
+    detrend = if (!missing(detrend)) detrend,
     show_dots = show_dots,
     show_ci = show_ci,
     show_smooth = show_smooth,
     maximum_dots = maximum_dots,
     bandwidth = bandwidth,
-    type = type,
+    # NULL lets the method for the fitted model choose the default
+    type = if (!missing(type)) type,
     residual_type = "simulated",
     ppc_range = ppc_range,
     verbose = verbose,

inst/WORDLIST

@@ -350,6 +350,7 @@ nd
 noncentral
 nonnest
 overfitted
+parsnip
 patilindrajeets
 poisson
 preprint

tests/testthat/test-check_model.R

@@ -152,7 +152,7 @@
   expect_true("REQQ" %in% names(out))
   expect_length(out$REQQ, 1)
   expect_s3_class(out$REQQ[[1]], "data.frame")
   expect_equal(nrow(out$REQQ[[1]]), 2 * nrow(lme4::ranef(model)$Subject))
   expect_setequal(as.character(unique(out$REQQ[[1]]$facet)), c("(Intercept)", "Days"))
 })
 
@@ -187,6 +187,105 @@
   }
 })
 
+test_that("`check_model()` forwards `type` and `size_title` for simulated residuals", {
+  skip_if_not_installed("DHARMa")
+  data(mtcars)
+  m <- glm(am ~ wt, data = mtcars, family = binomial)
+  p <- glm(carb ~ wt, data = mtcars, family = poisson)
+  sim_m <- simulate_residuals(m)
+
+  # the default for binary and count responses is used, as for the glm itself
+  expect_identical(attr(check_model(sim_m), "type"), "discrete_interval")
+  expect_identical(attr(check_model(simulate_residuals(p)), "type"), "discrete_interval")
+  expect_identical(
+    attr(check_model(DHARMa::simulateResiduals(m)), "type"),
+    "discrete_interval"
+  )
+
+  # user values are kept
+  expect_identical(attr(check_model(sim_m, type = "density"), "type"), "density")
+  expect_identical(attr(check_model(sim_m, size_title = 20), "title_size"), 20)
+})
+
+test_that("`check_model()` forwards `type` and `size_title` for `model_fit` objects", {
+  data(mtcars)
+  m <- glm(am ~ wt, data = mtcars, family = binomial)
+  # the class that parsnip gives its fits
+  obj <- structure(list(fit = m), class = "model_fit")
+
+  expect_identical(attr(check_model(obj), "type"), "discrete_interval")
+  expect_identical(attr(check_model(obj, type = "density"), "type"), "density")
+  expect_identical(attr(check_model(obj, size_title = 20), "title_size"), 20)
+})
+
+test_that("`check_model()` forwards `type`, `size_title`, and `detrend` for Stan models", {
+  skip_if_not_installed("rstanarm")
+  skip_if_not_installed("DHARMa")
+  skip_if_not_installed("curl")
+  skip_if_not_installed("httr2")
+  skip_if_offline()
+  # bernoulli model of `vs ~ wt`; brms models use the same method
+  m <- insight::download_model("stanreg_glm_1")
+  skip_if(is.null(m))
+
+  out <- check_model(m)
+  expect_identical(attr(out, "type"), "discrete_interval")
+  # simulated residuals are not detrended by default
+  expect_false(attr(out, "detrend"))
+  expect_identical(attr(check_model(m, type = "density"), "type"), "density")
+  expect_identical(attr(check_model(m, size_title = 20), "title_size"), 20)
+  expect_true(attr(check_model(m, detrend = TRUE), "detrend"))
+
+  # the same when a `model_fit` object wraps the Stan model
+  out <- check_model(structure(list(fit = m), class = "model_fit"))
+  expect_identical(attr(out, "type"), "discrete_interval")
+  expect_false(attr(out, "detrend"))
+})
+
+test_that("`check_model()` forwards `detrend` for wrapped models", {
+  skip_if_not_installed("DHARMa")
+  data(mtcars)
+  m <- glm(am ~ wt, data = mtcars, family = binomial)
+  l <- lm(mpg ~ wt, data = mtcars)
+  sim_m <- simulate_residuals(m)
+
+  # simulated residuals are not detrended by default
+  expect_false(attr(check_model(sim_m), "detrend"))
+  expect_false(attr(check_model(DHARMa::simulateResiduals(m)), "detrend"))
+  expect_false(attr(check_model(simulate_residuals(l)), "detrend"))
+  expect_false(attr(check_model(l, residual_type = "simulated"), "detrend"))
+
+  # the defaults of the bare models, which `model_fit` objects now get too
+  expect_false(attr(check_model(m), "detrend"))
+  expect_true(attr(check_model(l), "detrend"))
+  expect_false(attr(
+    check_model(structure(list(fit = m), class = "model_fit")),
+    "detrend"
+  ))
+  expect_true(attr(check_model(structure(list(fit = l), class = "model_fit")), "detrend"))
+
+  # user values are kept
+  expect_true(attr(check_model(sim_m, detrend = TRUE), "detrend"))
+  expect_false(attr(
+    check_model(structure(list(fit = l), class = "model_fit"), detrend = FALSE),
+    "detrend"
+  ))
+})
+
+test_that("`check_model()` keeps the defaults for wrapped linear models", {
+  skip_if_not_installed("DHARMa")
+  data(mtcars)
+  l <- lm(mpg ~ wt, data = mtcars)
+  out <- list(
+    model_fit = check_model(structure(list(fit = l), class = "model_fit")),
+    simres = check_model(simulate_residuals(l))
+  )
+  for (x in out) {
+    expect_identical(attr(x, "type"), "density")
+    expect_identical(attr(x, "title_size"), 12)
+  }
+})
+
 test_that("every `check_model()` method has a `show_smooth` argument", {
   methods <- ls(asNamespace("performance"), pattern = "^check_model\\.")
   expect_gt(length(methods), 0)
@@ -364,6 +463,12 @@
   out <- suppressMessages(check_model(m, check = "vif", show_smooth = FALSE))
   expect_named(out, "VIF")
   expect_false(attr(out, "show_smooth"))
+
+  # the same when a `model_fit` object wraps the brms model
+  out <- suppressMessages(check_model(structure(list(fit = m), class = "model_fit")))
+  expect_named(out, c("VIF", "PP_CHECK"), ignore.order = TRUE)
+  expect_true(attr(out, "detrend"))
+  expect_identical(attr(out, "type"), "density")
 })
 
 test_that("`check_model()` fallback for brms models can be plotted", {
@@ -560,7 +665,7 @@
   out <- withCallingHandlers(
     check_model(m, response = "gear"),
     warning = function(w) {
       warnings <<- c(warnings, conditionMessage(w))
       # other warnings still reach the test output
       if (grepl("partial argument match", conditionMessage(w), fixed = TRUE)) {
         invokeRestart("muffleWarning")