Add a show_smooth argument to check_model() (#979)

Author: jmgirard

NEWS.md

@@ -44,6 +44,12 @@
 
 ## Changes
 
+* `check_model()` gets a `show_smooth` argument. With `show_smooth = FALSE`,
+  the Linearity and Homogeneity of Variance panels draw neither the LOESS
+  smoother nor the cell means, and the Influential Observations panel draws no
+  LOESS smoother. This needs *see* newer than 0.14.2. Older versions ignore the
+  setting.
+
 * `check_model()` and `check_predictions()` now work for multivariate models
   from package *brms*. Use the `response` argument to name the response to
   check. Without `response`, both functions give an error that lists the names

R/check_model.R

@@ -50,6 +50,10 @@
 #' @param show_ci Logical, if `TRUE`, confidence intervals in plots are shown.
 #' For models with only categorical predictors, confidence intervals are not shown
 #' by default, because in this case, these are usually on very large scales.
+#' @param show_smooth Logical, if `FALSE`, the Linearity and Homogeneity of
+#' Variance panels draw neither the LOESS smoother nor the cell means, and the
+#' Influential Observations panel draws no LOESS smoother. This needs **see**
+#' newer than 0.14.2. Older versions ignore the setting.
 #' @param maximum_dots Limits the number of data points for models with many
 #' observations, to reduce the time for rendering the plot. Defaults to a
 #' maximum of 2000 data points to render
@@ -286,6 +290,7 @@ check_model.default <- function(
   theme = see::theme_lucid(),
   verbose = FALSE,
   x = NULL,
+  show_smooth = TRUE,
   ...
 ) {
   ## TODO remove deprecation warning later
@@ -296,6 +301,8 @@ check_model.default <- function(
     model <- x
   }
 
+  .check_show_smooth(show_smooth)
+
   # check model formula
   if (verbose) {
     insight::formula_ok(model)
@@ -392,6 +399,7 @@ check_model.default <- function(
     type_missing = missing(type),
     show_dots = show_dots,
     show_ci = show_ci,
+    show_smooth = show_smooth,
     maximum_dots = maximum_dots,
     size_dot = size_dot,
     size_line = size_line,
@@ -423,6 +431,7 @@ check_model.default <- function(
   type_missing,
   show_dots,
   show_ci,
+  show_smooth,
   maximum_dots,
   size_dot,
   size_line,
@@ -478,6 +487,7 @@ check_model.default <- function(
   attr(assumptions_data, "dot_alpha") <- alpha_dot
   attr(assumptions_data, "show_dots") <- isTRUE(show_dots)
   attr(assumptions_data, "show_ci") <- isTRUE(show_ci)
+  attr(assumptions_data, "show_smooth") <- isTRUE(show_smooth)
   attr(assumptions_data, "detrend") <- detrend
   attr(assumptions_data, "colors") <- colors
   attr(assumptions_data, "theme") <- theme
@@ -492,6 +502,14 @@ check_model.default <- function(
 }
 
 
+# same check and message as in see::plot.see_check_model()
+.check_show_smooth <- function(show_smooth) {
+  if (!isTRUE(show_smooth) && !isFALSE(show_smooth)) {
+    insight::format_error("`show_smooth` must be either `TRUE` or `FALSE`.")
+  }
+}
+
+
 # methods ----------------------------------
 
 #' @export
@@ -537,6 +555,7 @@ check_model.stanreg <- function(
   verbose = FALSE,
   x = NULL,
   response = NULL,
+  show_smooth = TRUE,
   ...
 ) {
   ## TODO remove deprecation warning later
@@ -547,6 +566,8 @@ check_model.stanreg <- function(
     model <- x
   }
 
+  .check_show_smooth(show_smooth)
+
   # multivariate brms models need one response, see https://github.com/easystats/performance/issues/908
   resp <- .check_multivariate_resp(
     model,
@@ -589,6 +610,7 @@ check_model.stanreg <- function(
       type_missing = missing(type),
       show_dots = show_dots,
       show_ci = show_ci,
+      show_smooth = show_smooth,
       maximum_dots = maximum_dots,
       size_dot = size_dot,
       size_line = size_line,
@@ -620,6 +642,7 @@ check_model.stanreg <- function(
     detrend = detrend,
     show_dots = show_dots,
     show_ci = show_ci,
+    show_smooth = show_smooth,
     bandwidth = bandwidth,
     type = type,
     residual_type = residual_type,
@@ -650,6 +673,7 @@ check_model.brmsfit <- check_model.stanreg
   type_missing,
   show_dots,
   show_ci,
+  show_smooth,
   maximum_dots,
   size_dot,
   size_line,
@@ -740,6 +764,7 @@ check_model.brmsfit <- check_model.stanreg
     type_missing = type_missing,
     show_dots = show_dots,
     show_ci = show_ci,
+    show_smooth = show_smooth,
     maximum_dots = maximum_dots,
     size_dot = size_dot,
     size_line = size_line,
@@ -816,6 +841,7 @@ check_model.model_fit <- function(
   theme = see::theme_lucid(),
   verbose = FALSE,
   x = NULL,
+  show_smooth = TRUE,
   ...
 ) {
   ## TODO remove deprecation warning later
@@ -841,6 +867,7 @@ check_model.model_fit <- function(
     detrend = detrend,
     show_dots = show_dots,
     show_ci = show_ci,
+    show_smooth = show_smooth,
     maximum_dots = maximum_dots,
     bandwidth = bandwidth,
     type = type,
@@ -876,6 +903,7 @@ check_model.performance_simres <- function(
   theme = see::theme_lucid(),
   verbose = FALSE,
   x = NULL,
+  show_smooth = TRUE,
   ...
 ) {
   ## TODO remove deprecation warning later
@@ -901,6 +929,7 @@ check_model.performance_simres <- function(
     detrend = detrend,
     show_dots = show_dots,
     show_ci = show_ci,
+    show_smooth = show_smooth,
     maximum_dots = maximum_dots,
     bandwidth = bandwidth,
     type = type,

man/check_model.Rd

@@ -171,6 +171,46 @@ test_that("`check_model()` respects user-supplied `show_ci`", {
   expect_false(attr(check_model(m_numeric, show_ci = FALSE), "show_ci"))
 })
 
+test_that("`check_model()` stores `show_smooth`", {
+  data(mtcars)
+  models <- list(
+    lm = lm(mpg ~ wt, data = mtcars),
+    glm = glm(am ~ wt, family = binomial, data = mtcars)
+  )
+  # simulate_residuals() needs DHARMa
+  if (requireNamespace("DHARMa", quietly = TRUE)) {
+    models$simres <- simulate_residuals(lm(mpg ~ wt, data = mtcars))
+  }
+  for (m in models) {
+    expect_true(attr(check_model(m), "show_smooth"))
+    expect_false(attr(check_model(m, show_smooth = FALSE), "show_smooth"))
+  }
+})
+
+test_that("every `check_model()` method has a `show_smooth` argument", {
+  methods <- ls(asNamespace("performance"), pattern = "^check_model\\.")
+  expect_gt(length(methods), 0)
+  for (fun in methods) {
+    expect_true(
+      "show_smooth" %in%
+        names(formals(get(fun, envir = asNamespace("performance")))),
+      info = fun
+    )
+  }
+})
+
+test_that("`check_model()` checks `show_smooth`", {
+  data(mtcars)
+  m <- lm(mpg ~ wt, data = mtcars)
+  for (value in list(NA, 1, "no", c(TRUE, FALSE))) {
+    expect_error(
+      check_model(m, show_smooth = value),
+      "`show_smooth` must be either `TRUE` or `FALSE`.",
+      fixed = TRUE
+    )
+  }
+})
+
 test_that("`check_model()` warnings for tweedie", {
   skip_if_not_installed("glmmTMB")
   skip_if_not_installed("lme4")
@@ -319,9 +359,11 @@ test_that("`check_model()` falls back to Bayesian checks if brms conversion fail
   expect_identical(attr(out, "check"), "all")
   expect_identical(attr(out, "model_class"), "brmsfit")
   expect_false(is.null(attr(out, "model_info")))
+  expect_true(attr(out, "show_smooth"))
 
-  out <- suppressMessages(check_model(m, check = "vif"))
+  out <- suppressMessages(check_model(m, check = "vif", show_smooth = FALSE))
   expect_named(out, "VIF")
+  expect_false(attr(out, "show_smooth"))
 })
 
 test_that("`check_model()` fallback for brms models can be plotted", {