Merge branch 'master' of github.com:stan-dev/bayesplot into add_ppc_calibration

Author: TeemuSailynoja

.Rbuildignore

@@ -15,3 +15,4 @@ book/*
 docs/*
 Rplots.pdf
 ^\.github$
+^release-prep\.R$

.github/workflows/recheck.yaml

@@ -0,0 +1,21 @@
+on:
+  workflow_dispatch:
+    inputs:
+      which:
+        type: choice
+        description: Which dependents to check
+        options:
+          - strong
+          - most
+
+name: Reverse dependency check
+
+jobs:
+  revdep_check:
+    name: Reverse check ${{ inputs.which }} dependents
+    uses: r-devel/recheck/.github/workflows/recheck.yml@v1
+    with:
+      which: ${{ inputs.which }}
+      subdirectory: '' # set if your R package is in a subdir of the git repo
+      repository: '' # set to recheck an R package from another git repo
+      ref: '' # set to recheck a custom tag/branch from another repo

.gitignore

@@ -12,3 +12,4 @@ cran-comments.md
 revdep/*
 CRAN-RELEASE
 CRAN-SUBMISSION
+release-prep.R

DESCRIPTION

@@ -1,10 +1,10 @@
 Package: bayesplot
 Type: Package
 Title: Plotting for Bayesian Models
-Version: 1.12.0.9000
-Date: 2025-04-09
+Version: 1.13.0.9000
+Date: 2025-06-18
 Authors@R: c(person("Jonah", "Gabry", role = c("aut", "cre"), email = "[email protected]"),
-             person("Tristan", "Mahr", role = "aut"),
+             person("Tristan", "Mahr", role = "aut", comment = c(ORCID = "0000-0002-8890-5116")),
              person("Paul-Christian", "Bürkner", role = "ctb"),
              person("Martin", "Modrák", role = "ctb"),
              person("Malcolm", "Barrett", role = "ctb"),
@@ -26,7 +26,7 @@ URL: https://mc-stan.org/bayesplot/
 BugReports: https://github.com/stan-dev/bayesplot/issues/
 SystemRequirements: pandoc (>= 1.12.3), pandoc-citeproc
 Depends:
-    R (>= 3.1.0)
+    R (>= 4.1.0)
 Imports:
     dplyr (>= 0.8.0),
     ggplot2 (>= 3.4.0),
@@ -41,6 +41,7 @@ Imports:
     tidyselect,
     utils
 Suggests:
+    ggdist,
     ggfortify,
     gridExtra (>= 2.2.1),
     hexbin,

NAMESPACE

@@ -127,6 +127,7 @@ export(ppc_data)
 export(ppc_dens)
 export(ppc_dens_overlay)
 export(ppc_dens_overlay_grouped)
+export(ppc_dots)
 export(ppc_ecdf_overlay)
 export(ppc_ecdf_overlay_grouped)
 export(ppc_error_binned)
@@ -176,6 +177,7 @@ export(ppd_boxplot)
 export(ppd_data)
 export(ppd_dens)
 export(ppd_dens_overlay)
+export(ppd_dots)
 export(ppd_ecdf_overlay)
 export(ppd_freqpoly)
 export(ppd_freqpoly_grouped)

NEWS.md

@@ -1,7 +1,16 @@
 # bayesplot (development version)
 
-* Add possibility for left-truncation to `ppc_km_overlay()` and `ppc_km_overlay_grouped()` by @Sakuski
-* Added `ppc_loo_pit_ecdf()` by @TeemuSailynoja
+* PPC "avg" functions (`ppc_scatter_avg()`, `ppc_error_scatter_avg()`, etc.) gain a `stat` argument to set the averaging function. (Suggestion of #348, @kruschke).
+* `ppc_error_scatter_avg_vs_x(x = some_expression)` labels the *x* axis with `some_expression`.
+
+# bayesplot 1.13.0
+
+* Add `ppc_loo_pit_ecdf()` by @TeemuSailynoja (#345)
+* Add possibility for left-truncation to `ppc_km_overlay()` and `ppc_km_overlay_grouped()` by @Sakuski (#347)
+* Give user control over extrapolation in `ppc_km_overlay()` and `ppc_km_overlay_grouped()` by @Sakuski (#353)
+* Allow passing `moment_match` via `...`  for loo functions by @n-kall (#351)
+* Skip some tests when missing Suggests by @MichaelChirico (#344)
+* Remove a test that will fail with next ggplot2 release (#356)
 
 # bayesplot 1.12.0
 

R/bayesplot-helpers.R

@@ -469,3 +469,53 @@ grid_lines_y <- function(color = "gray50", size = 0.2) {
 overlay_function <- function(...) {
   stat_function(..., inherit.aes = FALSE)
 }
+
+
+
+# Resolve a function name and store the expression passed in by the user
+#' @noRd
+#' @param f a function-like thing: a string naming a function, a function
+#'   object, an anonymous function object, a formula-based lambda, and `NULL`.
+#' @param fallback character string providing a fallback function name
+#' @return the function named in `f` with an added `"tagged_expr"` attribute
+#' containing the expression to represent the function name and an
+#' `"is_anonymous_function"` attribute to flag if the expression is a call to
+#' `function()`.
+as_tagged_function <- function(f = NULL, fallback = "func") {
+  qf <- enquo(f)
+  f <- eval_tidy(qf)
+  if (!is.null(attr(f, "tagged_expr"))) return(f)
+
+  f_expr <- quo_get_expr(qf)
+  f_fn <- f
+
+  if (is_character(f)) {        # f = "mean"
+    # using sym() on the evaluated `f` means that a variable that names a
+    # function string `x <- "mean"; as_tagged_function(x)` will be lost
+    # but that seems okay
+    f_expr <- sym(f)
+    f_fn <- match.fun(f)
+  } else if (is_null(f)) {      # f = NULL
+    f_fn <- identity
+    f_expr <- sym(fallback)
+  } else if (is_callable(f)) {  # f = mean or f = function(x) mean(x)
+    f_expr <- f_expr            # or f = ~mean(.x)
+    f_fn <- as_function(f)
+  }
+
+  # Setting attributes on primitive functions is deprecated, so wrap them
+  # and then tag
+  if (is_primitive(f_fn)) {
+    f_fn_old <- f_fn
+    f_factory <- function(f) { function(...) f(...) }
+    f_fn <- f_factory(f_fn_old)
+  }
+
+  attr(f_fn, "tagged_expr") <- f_expr
+  attr(f_fn, "is_anonymous_function") <-
+    is_call(f_expr, name = "function") || is_formula(f_expr)
+  f_fn
+}
+
+
+

R/bayesplot-package.R

@@ -1,6 +1,5 @@
 #' **bayesplot**: Plotting for Bayesian Models
 #'
-#' @docType package
 #' @name bayesplot-package
 #' @aliases bayesplot
 #'
@@ -96,7 +95,7 @@
 #' ppd_hist(ypred[1:8, ])
 #' }
 #'
-NULL
+"_PACKAGE"
 
 
 # internal ----------------------------------------------------------------

R/mcmc-distributions.R

@@ -472,7 +472,7 @@ mcmc_violin <- function(
     }
   }
 
-  geom_args <- list(size = 0.5, na.rm = TRUE, alpha = alpha)
+  geom_args <- list(linewidth = 0.5, na.rm = TRUE, alpha = alpha)
   if (violin) {
     geom_args[["draw_quantiles"]] <- probs
   } else {

R/ppc-censoring.R

@@ -24,11 +24,12 @@
 #' @section Plot Descriptions:
 #' \describe{
 #'   \item{`ppc_km_overlay()`}{
-#'    Empirical CCDF estimates of each dataset (row) in `yrep` are overlaid,
-#'    with the Kaplan-Meier estimate (Kaplan and Meier, 1958) for `y` itself on
-#'    top (and in a darker shade). This is a PPC suitable for right-censored
-#'    `y`. Note that the replicated data from `yrep` is assumed to be
-#'    uncensored.
+#'   Empirical CCDF estimates of each dataset (row) in `yrep` are overlaid, with
+#'   the Kaplan-Meier estimate (Kaplan and Meier, 1958) for `y` itself on top
+#'   (and in a darker shade). This is a PPC suitable for right-censored `y`.
+#'   Note that the replicated data from `yrep` is assumed to be uncensored. Left
+#'   truncation (delayed entry) times for `y` can be specified using
+#'   `left_truncation_y`.
 #'   }
 #'   \item{`ppc_km_overlay_grouped()`}{
 #'    The same as `ppc_km_overlay()`, but with separate facets by `group`.
@@ -40,24 +41,33 @@
 #' @template reference-km
 #'
 #' @examples
+#' \donttest{
 #' color_scheme_set("brightblue")
-#' y <- example_y_data()
+#'
 #' # For illustrative purposes, (right-)censor values y > 110:
+#' y <- example_y_data()
 #' status_y <- as.numeric(y <= 110)
 #' y <- pmin(y, 110)
+#'
 #' # In reality, the replicated data (yrep) would be obtained from a
 #' # model which takes the censoring of y properly into account. Here,
 #' # for illustrative purposes, we simply use example_yrep_draws():
 #' yrep <- example_yrep_draws()
 #' dim(yrep)
-#' \donttest{
+#'
+#' # Overlay 25 curves
 #' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y)
-#' }
+#'
+#' # With extrapolation_factor = 1 (no extrapolation)
+#' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, extrapolation_factor = 1)
+#'
+#' # With extrapolation_factor = Inf (show all posterior predictive draws)
+#' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, extrapolation_factor = Inf)
+#'
 #' # With separate facets by group:
 #' group <- example_group_data()
-#' \donttest{
 #' ppc_km_overlay_grouped(y, yrep[1:25, ], group = group, status_y = status_y)
-#' }
+#'
 #' # With left-truncation (delayed entry) times:
 #' min_vals <- pmin(y, apply(yrep, 2, min))
 #' left_truncation_y <- rep(0, length(y))
@@ -66,7 +76,6 @@
 #'   runif(sum(condition), min = 0.6, max = 0.99) * y[condition],
 #'   min_vals[condition] - 0.001
 #' )
-#' \donttest{
 #' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y,
 #'               left_truncation_y = left_truncation_y)
 #' }
@@ -78,15 +87,23 @@ NULL
 #'   be a numeric vector of the same length as `y` with values in \{0, 1\} (0 =
 #'   right censored, 1 = event).
 #' @param left_truncation_y Optional parameter that specifies left-truncation
-#'   (delayed entry) times for the observations from `y`. This must
-#'   be a numeric vector of the same length as `y`. If `NULL` (default),
-#'   no left-truncation is assumed.
+#'   (delayed entry) times for the observations from `y`. This must be a numeric
+#'   vector of the same length as `y`. If `NULL` (default), no left-truncation
+#'   is assumed.
+#' @param extrapolation_factor A numeric value (>=1) that controls how far the
+#'   plot is extended beyond the largest observed value in `y`. The default
+#'   value is 1.2, which corresponds to 20 % extrapolation. Note that all
+#'   posterior predictive draws may not be shown by default because of the
+#'   controlled extrapolation. To display all posterior predictive draws, set
+#'   `extrapolation_factor = Inf`.
+#'
 ppc_km_overlay <- function(
   y,
   yrep,
   ...,
   status_y,
   left_truncation_y = NULL,
+  extrapolation_factor = 1.2,
   size = 0.25,
   alpha = 0.7
 ) {
@@ -97,15 +114,25 @@ ppc_km_overlay <- function(
   suggested_package("ggfortify")
 
   if (!is.numeric(status_y) || length(status_y) != length(y) || !all(status_y %in% c(0, 1))) {
-    stop("`status_y` must be a numeric vector of 0s and 1s the same length as `y`.")
+    stop("`status_y` must be a numeric vector of 0s and 1s the same length as `y`.", call. = FALSE)
   }
 
   if (!is.null(left_truncation_y)) {
     if (!is.numeric(left_truncation_y) || length(left_truncation_y) != length(y)) {
-      stop("`left_truncation_y` must be a numeric vector of the same length as `y`.")
+      stop("`left_truncation_y` must be a numeric vector of the same length as `y`.", call. = FALSE)
     }
   }
 
+  if (extrapolation_factor < 1) {
+    stop("`extrapolation_factor` must be greater than or equal to 1.", call. = FALSE)
+  }
+  if (extrapolation_factor == 1.2) {
+    message(
+      "Note: `extrapolation_factor` now defaults to 1.2 (20%).\n",
+      "To display all posterior predictive draws, set `extrapolation_factor = Inf`."
+    )
+  }
+
   data <- ppc_data(y, yrep, group = status_y)
 
   # Modify the status indicator:
@@ -149,6 +176,10 @@ ppc_km_overlay <- function(
   fsf$is_y_size <- ifelse(fsf$is_y_color == "yrep", size, 1)
   fsf$is_y_alpha <- ifelse(fsf$is_y_color == "yrep", alpha, 1)
 
+  max_time_y <- max(y, na.rm = TRUE)
+  fsf <- fsf %>%
+    dplyr::filter(.data$is_y_color != "yrep" | .data$time <= max_time_y * extrapolation_factor)
+
   # Ensure that the observed data gets plotted last by reordering the
   # levels of the factor "strata"
   fsf$strata <- factor(fsf$strata, levels = rev(levels(fsf$strata)))
@@ -194,6 +225,7 @@ ppc_km_overlay_grouped <- function(
   ...,
   status_y,
   left_truncation_y = NULL,
+  extrapolation_factor = 1.2,
   size = 0.25,
   alpha = 0.7
 ) {
@@ -207,7 +239,8 @@ ppc_km_overlay_grouped <- function(
     status_y = status_y,
     left_truncation_y = left_truncation_y,
     size = size,
-    alpha = alpha
+    alpha = alpha,
+    extrapolation_factor = extrapolation_factor
   )
 
   p_overlay +