{"spec_id":"diagnostic-regression-panel","library":"ggplot2","language":"r","code":"#' anyplot.ai\n#' diagnostic-regression-panel: Regression Diagnostic Panel (Four-Plot Display)\n#' Library: ggplot2 3.5.1 | R 4.4.1\n#' Quality: 90/100 | Created: 2026-09-05\n\nlibrary(ggplot2)\nlibrary(scales)\nlibrary(ragg)\nlibrary(gridExtra)\n\ngrDevices::pdf(NULL)  # null device so building text grobs pre-render doesn't leave a stray Rplots.pdf\nset.seed(42)\n\n# --- Theme tokens ------------------------------------------------------\nTHEME    <- Sys.getenv(\"ANYPLOT_THEME\", \"light\")\nPAGE_BG  <- if (THEME == \"light\") \"#FAF8F1\" else \"#1A1A17\"\nINK      <- if (THEME == \"light\") \"#1A1A17\" else \"#F0EFE8\"\nINK_SOFT <- if (THEME == \"light\") \"#4A4A44\" else \"#B8B7B0\"\n\nIMPRINT_PALETTE <- c(\"#009E73\", \"#C475FD\", \"#4467A3\", \"#BD8233\",\n                     \"#AE3030\", \"#2ABCCD\", \"#954477\", \"#99B314\")\nANYPLOT_AMBER <- \"#DDCC77\"\n\nPOINT_COLOR       <- IMPRINT_PALETTE[1]  # regular observations (brand green)\nINFLUENTIAL_COLOR <- IMPRINT_PALETTE[5]  # top Cook's distance points (semantic: outlier/error -> red)\nSMOOTH_COLOR      <- IMPRINT_PALETTE[3]  # LOWESS trend\nCONTOUR_COLOR     <- ANYPLOT_AMBER       # Cook's distance contours (warning threshold)\n\n# --- Data: apartment rent regressed on floor area, with a deliberately ------\n# misspecified linear fit (true relation has mild curvature and the noise\n# scales with size) so the diagnostics show realistic non-linearity and\n# heteroscedasticity instead of a textbook-clean fit.\nn_obs <- 150\nfloor_area_m2 <- runif(n_obs, 35, 160)\nnoise_sd <- 25 + 0.9 * floor_area_m2\nmonthly_rent <- 320 + 9.4 * floor_area_m2 + 0.028 * floor_area_m2^2 +\n  rnorm(n_obs, mean = 0, sd = noise_sd)\n\nlistings <- tibble::tibble(floor_area_m2 = floor_area_m2, monthly_rent = monthly_rent)\nmodel <- lm(monthly_rent ~ floor_area_m2, data = listings)\n\ndiagnostics <- tibble::tibble(\n  obs_id        = seq_len(n_obs),\n  fitted        = fitted(model),\n  residuals     = resid(model),\n  std_residuals = rstandard(model),\n  leverage      = hatvalues(model),\n  cooks_d       = cooks.distance(model)\n)\n\nn_labeled <- 3\ninfluential_ids <- diagnostics$obs_id[order(diagnostics$cooks_d, decreasing = TRUE)][1:n_labeled]\ndiagnostics$is_influential <- diagnostics$obs_id %in% influential_ids\ninfluential_points <- diagnostics[diagnostics$is_influential, ]\n\n# Spread the 3 index labels apart along each panel's x-axis, AND stack them at\n# different heights (vjust) by rank — horizontal nudging alone isn't enough\n# when two influential points have close fitted/leverage values (their x-nudges\n# land near each other), so the perpendicular vjust offset guarantees the\n# labels never visually cluster.\nlabel_spread <- 0.09\ninfluential_points$nudge_fitted <-\n  (rank(influential_points$fitted) - (n_labeled + 1) / 2) *\n  label_spread * diff(range(diagnostics$fitted))\ninfluential_points$nudge_leverage <-\n  (rank(influential_points$leverage) - (n_labeled + 1) / 2) *\n  label_spread * diff(range(diagnostics$leverage))\ninfluential_points$vjust_fitted <-\n  -0.9 - (rank(influential_points$fitted) - 1) * 0.35\ninfluential_points$vjust_leverage <-\n  -0.9 - (rank(influential_points$leverage) - 1) * 0.35\n\n# --- Title -------------------------------------------------------------\ntitle_text <- \"diagnostic-regression-panel · r · ggplot2 · anyplot.ai\"\ntitle_fontsize <- if (nchar(title_text) > 67) round(12 * 67 / nchar(title_text)) else 12\ntitle_fontsize <- max(title_fontsize, 8)\n\n# --- Shared chrome -------------------------------------------------------\nanyplot_theme <- theme_minimal(base_size = 7) +\n  theme(\n    plot.background   = element_rect(fill = PAGE_BG, color = PAGE_BG),\n    panel.background  = element_rect(fill = PAGE_BG, color = NA),\n    panel.grid.minor  = element_blank(),\n    panel.grid.major  = element_line(color = alpha(INK, 0.12), linewidth = 0.4),\n    axis.line         = element_line(color = INK_SOFT, linewidth = 0.35),\n    axis.ticks        = element_blank(),\n    axis.title        = element_text(color = INK, size = 9),\n    axis.text         = element_text(color = INK_SOFT, size = 7),\n    plot.title        = element_text(color = INK, size = 10, face = \"plain\"),\n    plot.margin       = margin(t = 10, r = 14, b = 8, l = 10),\n    legend.position   = \"none\"\n  )\n\npoint_size  <- 2.5\npoint_alpha <- 0.6\n\n# --- Panel 1: Residuals vs Fitted --------------------------------------\np_resid_fitted <- ggplot(diagnostics, aes(x = fitted, y = residuals)) +\n  geom_hline(yintercept = 0, linetype = \"dashed\", color = INK_SOFT, linewidth = 0.4) +\n  geom_point(color = POINT_COLOR, size = point_size, alpha = point_alpha) +\n  geom_smooth(method = \"loess\", formula = y ~ x, se = FALSE,\n              color = SMOOTH_COLOR, linewidth = 0.9) +\n  geom_point(data = influential_points, color = INFLUENTIAL_COLOR, size = point_size + 0.6) +\n  geom_text(data = influential_points,\n            aes(x = fitted + nudge_fitted, label = obs_id, vjust = vjust_fitted),\n            color = INK, size = 2.8, fontface = \"plain\") +\n  scale_y_continuous(expand = expansion(mult = c(0.05, 0.20))) +\n  labs(title = \"Residuals vs Fitted\", x = \"Fitted Values ($/month)\", y = \"Residuals\") +\n  anyplot_theme\n\n# --- Panel 2: Normal Q-Q -------------------------------------------------\nqq_order <- order(diagnostics$std_residuals)\nqq_data <- tibble::tibble(\n  obs_id      = qq_order,\n  theoretical = qnorm(ppoints(n_obs)),\n  sample      = diagnostics$std_residuals[qq_order]\n)\nqq_influential <- qq_data[qq_data$obs_id %in% influential_ids, ]\nqq_influential$nudge_theoretical <-\n  (rank(qq_influential$theoretical) - (n_labeled + 1) / 2) *\n  label_spread * diff(range(qq_data$theoretical))\nqq_influential$vjust_theoretical <-\n  -0.9 - (rank(qq_influential$theoretical) - 1) * 0.35\n\nqq_probs      <- c(0.25, 0.75)\nqq_slope      <- diff(quantile(diagnostics$std_residuals, qq_probs)) / diff(qnorm(qq_probs))\nqq_intercept  <- quantile(diagnostics$std_residuals, qq_probs[1]) - qq_slope * qnorm(qq_probs[1])\n\np_qq <- ggplot(qq_data, aes(x = theoretical, y = sample)) +\n  geom_abline(slope = qq_slope, intercept = qq_intercept,\n              linetype = \"dashed\", color = INK_SOFT, linewidth = 0.4) +\n  geom_point(color = POINT_COLOR, size = point_size, alpha = point_alpha) +\n  geom_point(data = qq_influential, color = INFLUENTIAL_COLOR, size = point_size + 0.6) +\n  geom_text(data = qq_influential,\n            aes(x = theoretical + nudge_theoretical, label = obs_id, vjust = vjust_theoretical),\n            color = INK, size = 2.8, fontface = \"plain\") +\n  scale_y_continuous(expand = expansion(mult = c(0.05, 0.20))) +\n  labs(title = \"Normal Q-Q\", x = \"Theoretical Quantiles\", y = \"Standardized Residuals\") +\n  anyplot_theme\n\n# --- Panel 3: Scale-Location ---------------------------------------------\ndiagnostics$sqrt_abs_std_resid <- sqrt(abs(diagnostics$std_residuals))\ninfluential_points$sqrt_abs_std_resid <- sqrt(abs(influential_points$std_residuals))\n\np_scale_location <- ggplot(diagnostics, aes(x = fitted, y = sqrt_abs_std_resid)) +\n  geom_point(color = POINT_COLOR, size = point_size, alpha = point_alpha) +\n  geom_smooth(method = \"loess\", formula = y ~ x, se = FALSE,\n              color = SMOOTH_COLOR, linewidth = 0.9) +\n  geom_point(data = influential_points, color = INFLUENTIAL_COLOR, size = point_size + 0.6) +\n  geom_text(data = influential_points,\n            aes(x = fitted + nudge_fitted, label = obs_id, vjust = vjust_fitted),\n            color = INK, size = 2.8, fontface = \"plain\") +\n  scale_y_continuous(expand = expansion(mult = c(0.05, 0.20))) +\n  labs(title = \"Scale-Location\", x = \"Fitted Values ($/month)\",\n       y = expression(sqrt(\"|Standardized Residuals|\"))) +\n  anyplot_theme\n\n# --- Panel 4: Residuals vs Leverage (with Cook's distance contours) ------\np_params <- length(coef(model))  # intercept + slope = 2\nmax_leverage <- max(diagnostics$leverage)\nleverage_grid <- seq(max_leverage * 0.02, max_leverage * 1.15, length.out = 200)\n\n# Both contours are decreasing functions of leverage, so their lowest values\n# over the plotted range are reached at max leverage — the y-axis must extend\n# at least that far or the contour is invisible. Size the axis off the\n# stricter D=1.0 threshold so it's always visibly reachable (not just D=0.5),\n# even though this widens the axis and shrinks the primary point cloud a bit.\ncook_1_floor <- sqrt(1.0 * p_params * (1 - max_leverage) / max_leverage)\ny_limit <- max(4, max(abs(diagnostics$std_residuals)) * 1.3, cook_1_floor * 1.15)\n\ncook_contours <- tibble::tibble(\n  leverage      = rep(leverage_grid, 4),\n  std_residuals = c(\n    sqrt(0.5 * p_params * (1 - leverage_grid) / leverage_grid),\n    -sqrt(0.5 * p_params * (1 - leverage_grid) / leverage_grid),\n    sqrt(1.0 * p_params * (1 - leverage_grid) / leverage_grid),\n    -sqrt(1.0 * p_params * (1 - leverage_grid) / leverage_grid)\n  ),\n  # each sign/level combination is its own monotonic branch — sharing a group\n  # between the positive and negative halves of the same level would make\n  # geom_line zigzag between the two branches instead of drawing two curves\n  branch = rep(c(\"0.5-upper\", \"0.5-lower\", \"1.0-upper\", \"1.0-lower\"), each = length(leverage_grid))\n)\n\n# Place both labels close to max leverage (where each curve is lowest) so\n# their required height stays near the axis's data-driven floor; staggering\n# the leverage position also keeps \"D=0.5\" and \"D=1.0\" from colliding in x.\ncook_label_leverage <- max_leverage * c(0.82, 1.00)\ncook_labels <- tibble::tibble(\n  leverage      = cook_label_leverage,\n  std_residuals = c(\n    sqrt(0.5 * p_params * (1 - cook_label_leverage[1]) / cook_label_leverage[1]),\n    sqrt(1.0 * p_params * (1 - cook_label_leverage[2]) / cook_label_leverage[2])\n  ),\n  label = c(\"D=0.5\", \"D=1.0\")\n)\ncook_labels <- cook_labels[cook_labels$std_residuals <= y_limit, ]\n\np_resid_leverage <- ggplot(diagnostics, aes(x = leverage, y = std_residuals)) +\n  geom_line(data = cook_contours, aes(group = branch),\n            color = CONTOUR_COLOR, linetype = \"dashed\", linewidth = 0.6) +\n  geom_text(data = cook_labels, aes(label = label),\n            color = CONTOUR_COLOR, size = 2.6, hjust = 0.5, vjust = -1.0) +\n  geom_hline(yintercept = 0, linetype = \"dashed\", color = INK_SOFT, linewidth = 0.4) +\n  geom_point(color = POINT_COLOR, size = point_size, alpha = point_alpha) +\n  geom_smooth(method = \"loess\", formula = y ~ x, se = FALSE,\n              color = SMOOTH_COLOR, linewidth = 0.9) +\n  geom_point(data = influential_points, color = INFLUENTIAL_COLOR, size = point_size + 0.6) +\n  geom_text(data = influential_points,\n            aes(x = leverage + nudge_leverage, label = obs_id, vjust = vjust_leverage),\n            color = INK, size = 2.8, fontface = \"plain\") +\n  coord_cartesian(xlim = range(diagnostics$leverage) * c(0.9, 1.1),\n                   ylim = c(-y_limit, y_limit)) +\n  labs(title = \"Residuals vs Leverage\", x = \"Leverage\", y = \"Standardized Residuals\") +\n  anyplot_theme\n\n# --- Combine into a 2x2 grid with a shared title and legend caption ------\ncombined <- arrangeGrob(\n  p_resid_fitted, p_qq, p_scale_location, p_resid_leverage,\n  ncol = 2, nrow = 2,\n  top = grid::textGrob(title_text, gp = grid::gpar(col = INK, fontsize = title_fontsize)),\n  bottom = grid::textGrob(\n    \"Green = observation  ·  Red = top 3 by Cook's distance  ·  Blue = LOESS trend\\nAmber (panel 4) = Cook's distance contours at D=0.5 and D=1.0\",\n    gp = grid::gpar(col = INK_SOFT, fontsize = 8, lineheight = 1.3)\n  )\n)\n\n# --- Save ----------------------------------------------------------------\nggsave(\n  filename = sprintf(\"plot-%s.png\", THEME),\n  plot     = combined,\n  device   = ragg::agg_png,\n  width    = 6,\n  height   = 6,\n  units    = \"in\",\n  dpi      = 400,\n  bg       = PAGE_BG\n)\n"}