Keep the y axis of the outliers panel on the residuals

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: see
 Title: Model Visualisation Toolbox for 'easystats' and 'ggplot2'
-Version: 0.15.0.4
+Version: 0.15.0.5
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

NEWS.md

@@ -39,6 +39,12 @@
   shades quantile intervals behind the points, for example
   `shade = c(0.5, 0.8, 0.95)`. It needs the *ggdist* package (#135).
 
+* The y axis of the outliers panel in `check_model()` and in `plot()` for
+  `check_outliers()` now follows the standardized residuals. Before, the
+  Cook's distance contour lines set it, so it grew with the number of
+  observations. The contour lines are now cut at the range of the residuals,
+  and the subtitle says so when no line is left (easystats/performance#894).
+
 ## Bug fixes
 
 * `plot()` for `bayestestR::equivalence_test()` of a data frame failed with

R/plot.check_outliers.dots.R

@@ -89,6 +89,9 @@
         alpha = alpha_dot,
         size = size_point
       )
+  } else {
+    # keep the y axis on the residuals
+    p <- p + ggplot2::geom_blank()
   }
 
   p <- p +
@@ -154,61 +157,107 @@
 
   if (length(cook.levels)) {
     .hat <- sort(plot_data$Hat)
-    .cook_ref <- lapply(cook.levels, function(crit) {
-      sqrt(crit * n_params * (1 - .hat) / .hat)
-    })
-
     .hat80 <- min(.hat) + diff(range(.hat)) * 0.8
-    .cook_labels <- c("Cook's D = ", rep("", length(cook.levels) - 1))
-    .cook_lines <- c(
-      lapply(seq_along(cook.levels), function(.level) {
-        ggplot2::annotate(
-          geom = "line",
-          x = .hat,
-          y = .cook_ref[[.level]],
-          color = colors[1],
-          linetype = ref.linetype,
-          linewidth = size_line
-        )
-      }),
-      lapply(seq_along(cook.levels), function(.level) {
+
+    # cut contour lines at the range of the residuals, so they don't set the
+    # y axis (drawn in full if no residual is finite)
+    .res <- plot_data$Std_Residuals[is.finite(plot_data$Std_Residuals)]
+    .bounds <- if (length(.res)) c(max(.res), -min(.res)) else c(Inf, Inf)
+
+    .cook_ref <- function(crit, hat) sqrt(crit * n_params * (1 - hat) / hat)
+
+    # part of a contour line up to `bound`, or NULL if none is inside
+    .cook_line <- function(crit, bound) {
+      y <- .cook_ref(crit, .hat)
+      keep <- !is.na(y) & y <= bound
+      if (!any(keep)) {
+        return(NULL)
+      }
+      x <- .hat[keep]
+      y <- y[keep]
+      if (is.finite(bound)) {
+        h_cross <- crit * n_params / (bound^2 + crit * n_params)
+        if (h_cross > min(.hat) && h_cross < x[1]) {
+          x <- c(h_cross, x)
+          y <- c(bound, y)
+        }
+      }
+      # a single point draws no line
+      if (length(x) < 2) {
+        return(NULL)
+      }
+      list(x = x, y = y)
+    }
+
+    .sides <- c(upper = 1, lower = -1)
+    .pieces <- list(
+      upper = lapply(cook.levels, .cook_line, bound = .bounds[1]),
+      lower = lapply(cook.levels, .cook_line, bound = .bounds[2])
+    )
+
+    .cook_lines <- lapply(names(.sides), function(.s) {
+      lapply(.pieces[[.s]], function(.piece) {
+        if (is.null(.piece)) {
+          return(NULL)
+        }
         ggplot2::annotate(
           geom = "line",
-          x = .hat,
-          y = -1 * .cook_ref[[.level]],
+          x = .piece$x,
+          y = .sides[[.s]] * .piece$y,
           color = colors[1],
           linetype = ref.linetype,
           linewidth = size_line
         )
-      }),
+      })
+    })
+
+    # labels at 80% of the leverage range, or at the largest leverage if the
+    # cut line starts right of it; labels of cut lines on the inner side
+    .cook_text <- lapply(names(.sides), function(.s) {
       lapply(seq_along(cook.levels), function(.level) {
+        .piece <- .pieces[[.s]][[.level]]
+        if (is.null(.piece)) {
+          return(NULL)
+        }
+        .x <- if (.piece$x[1] <= .hat80) .hat80 else max(.hat)
+        .cut <- .piece$x[1] > min(.hat)
+        .vjust <- if (xor(.cut, .s == "lower")) 1.5 else -1
         ggplot2::annotate(
           geom = "text",
           label = insight::format_value(cook.levels[.level], digits = 1),
-          x = .hat80,
-          y = sqrt(cook.levels[.level] * n_params * (1 - .hat80) / .hat80),
+          x = .x,
+          y = .sides[[.s]] * .cook_ref(cook.levels[.level], .x),
           hjust = "right",
-          vjust = -1,
+          vjust = .vjust,
           color = colors[1],
           size = size_text
         )
-      }),
-      lapply(seq_along(cook.levels), function(.level) {
-        ggplot2::annotate(
-          geom = "text",
-          label = insight::format_value(cook.levels[.level], digits = 1),
-          x = .hat80,
-          y = -1 * sqrt(cook.levels[.level] * n_params * (1 - .hat80) / .hat80),
-          color = colors[1],
-          hjust = "right",
-          vjust = 1.5,
-          size = size_text
-        )
       })
-    )
+    })
+
+    .cook_lines <- unlist(.cook_lines, recursive = FALSE)
+    .cook_text <- unlist(.cook_text, recursive = FALSE)
+    .cook_lines <- Filter(Negate(is.null), .cook_lines)
+    .cook_text <- Filter(Negate(is.null), .cook_text)
+
+    # check all Cook's distances, also of rows left out by the sampling above
+    .computable <- length(.res) > 0 &&
+      length(.hat) > 0 &&
+      length(n_params) == 1 &&
+      isTRUE(is.finite(n_params)) &&
+      any(is.finite(cook.levels))
+    .all_inside <- .computable &&
+      all(x$Cooks_Distance < min_cook_level, na.rm = TRUE)
+    if (.all_inside && !length(.cook_lines)) {
+      p <- p +
+        ggplot2::labs(
+          subtitle = "All points are inside the contour lines (outside the plot area)"
+        )
+    }
 
     p <- p +
       .cook_lines +
+      .cook_text +
       theme +
       ggplot2::guides(colour = "none", text = "none")
   }