Merge branch 'master' into add-cmdstanr-to-gha

Author: jgabry

.github/workflows/pkgdown.yml

@@ -54,7 +54,7 @@ jobs:
         shell: Rscript {0}
 
       - name: Deploy to GitHub pages 🚀
-        uses: JamesIves/github-pages-deploy-action@v4.7.4
+        uses: JamesIves/github-pages-deploy-action@v4
         with:
           clean: false
           branch: gh-pages

.github/workflows/test-coverage.yaml

@@ -16,7 +16,7 @@ jobs:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
 
     steps:
-      - uses: actions/checkout@v6
+      - uses: actions/checkout@v4
 
       - uses: r-lib/actions/setup-r@v2
         with:
@@ -38,15 +38,16 @@ jobs:
             clean = FALSE,
             install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package")
           )
+          print(cov)
           covr::to_cobertura(cov)
         shell: Rscript {0}
 
-      - uses: codecov/codecov-action@v4
+      - uses: codecov/codecov-action@v5
         with:
           # Fail if error if not on PR, or if on PR and token is given
           fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }}
-          file: ./cobertura.xml
-          plugin: noop
+          files: ./cobertura.xml
+          plugins: noop
           disable_search: true
           token: ${{ secrets.CODECOV_TOKEN }}
 
@@ -59,7 +60,7 @@ jobs:
 
       - name: Upload test results
         if: failure()
-        uses: actions/upload-artifact@v5
+        uses: actions/upload-artifact@v4
         with:
           name: coverage-test-failures
           path: ${{ runner.temp }}/package

R/helpers-shared.R

@@ -44,3 +44,18 @@ check_ignored_arguments <- function(..., ok_args = character()) {
     }
   }
 }
+
+#' Validate bounds passed to stat_density/geom_density wrappers
+#' @noRd
+validate_density_bounds <- function(bounds) {
+  if (is.null(bounds)) {
+    return(NULL)
+  }
+  if (!is.numeric(bounds) || length(bounds) != 2 || anyNA(bounds)) {
+    abort("`bounds` must be a numeric vector of length 2.")
+  }
+  if (bounds[1] >= bounds[2]) {
+    abort("`bounds` must satisfy bounds[1] < bounds[2].")
+  }
+  bounds
+}

R/mcmc-diagnostics-nuts.R

@@ -19,8 +19,9 @@
 #' @param chain A positive integer for selecting a particular chain. The default
 #'   (`NULL`) is to merge the chains before plotting. If `chain = k`
 #'   then the plot for chain `k` is overlaid (in a darker shade but with
-#'   transparency) on top of the plot for all chains. The `chain` argument
-#'   is not used by `mcmc_nuts_energy()`.
+#'   transparency) on top of the plot for all chains. For `mcmc_nuts_stepsize()`,
+#'   chains are always plotted separately, and `chain` simply highlights the
+#'   selected chain. The `chain` argument is not used by `mcmc_nuts_energy()`.
 #' @param ... Currently ignored.
 #'
 #' @return A gtable object (the result of calling
@@ -285,7 +286,6 @@ mcmc_nuts_divergence <- function(x, lp, chain = NULL, ...) {
   as_bayesplot_grid(nuts_plot)
 }
 
-
 #' @rdname MCMC-nuts
 #' @export
 mcmc_nuts_stepsize <- function(x, lp, chain = NULL, ...) {
@@ -369,13 +369,25 @@ mcmc_nuts_treedepth <- function(x, lp, chain = NULL, ...) {
     yaxis_ticks(FALSE)
 
   violin_lp_data <- data.frame(treedepth, lp = lp$Value)
+
+  # Only keep treedepth values that occur more than once for violin plot
+  value_counts <- table(violin_lp_data$Value)
+  keep_values <- names(value_counts[value_counts > 1])
+  violin_lp_data <- violin_lp_data[violin_lp_data$Value %in% keep_values, ]
+
   violin_lp <-
     ggplot(violin_lp_data, aes(x = factor(.data$Value), y = .data$lp)) +
     geom_violin(fill = get_color("l"), color = get_color("lh")) +
     labs(x = "treedepth__", y = "lp__") +
     bayesplot_theme_get()
 
   violin_accept_stat_data <- data.frame(treedepth, as = accept_stat$Value)
+
+  # Only keep treedepth values that occur more than once for violin plot
+  value_counts <- table(violin_accept_stat_data$Value)
+  keep_values <- names(value_counts[value_counts > 1])
+  violin_accept_stat_data <- violin_accept_stat_data[violin_accept_stat_data$Value %in% keep_values, ]
+
   violin_accept_stat <-
     ggplot(violin_accept_stat_data, aes(x = factor(.data$Value), y = .data$as)) +
     geom_violin(fill = get_color("l"), color = get_color("lh")) +
@@ -409,7 +421,6 @@ mcmc_nuts_treedepth <- function(x, lp, chain = NULL, ...) {
   as_bayesplot_grid(nuts_plot)
 }
 
-
 #' @rdname MCMC-nuts
 #' @export
 #' @param alpha For `mcmc_nuts_energy()` only, the transparency (alpha) level

R/mcmc-distributions.R

@@ -151,6 +151,7 @@ mcmc_dens <- function(
   adjust = NULL,
   kernel = NULL,
   n_dens = NULL,
+  bounds = NULL,
   alpha = 1
 ) {
   check_ignored_arguments(...)
@@ -166,6 +167,7 @@ mcmc_dens <- function(
     adjust = adjust,
     kernel = kernel,
     n_dens = n_dens,
+    bounds = bounds,
     alpha = alpha,
     ...
   )
@@ -216,7 +218,8 @@ mcmc_dens_overlay <- function(
   bw = NULL,
   adjust = NULL,
   kernel = NULL,
-  n_dens = NULL
+  n_dens = NULL,
+  bounds = NULL
 ) {
   check_ignored_arguments(...)
   .mcmc_dens(
@@ -232,6 +235,7 @@ mcmc_dens_overlay <- function(
     adjust = adjust,
     kernel = kernel,
     n_dens = n_dens,
+    bounds = bounds,
     ...
   )
 }
@@ -250,7 +254,8 @@ mcmc_dens_chains <- function(
   bw = NULL,
   adjust = NULL,
   kernel = NULL,
-  n_dens = NULL
+  n_dens = NULL,
+  bounds = NULL
 ) {
   check_ignored_arguments(...)
   data <- mcmc_dens_chains_data(
@@ -261,7 +266,8 @@ mcmc_dens_chains <- function(
     bw = bw,
     adjust = adjust,
     kernel = kernel,
-    n_dens = n_dens
+    n_dens = n_dens,
+    bounds = bounds
   )
 
   n_chains <- length(unique(data$chain))
@@ -314,9 +320,11 @@ mcmc_dens_chains_data <- function(
   transformations = list(),
   ...,
   bw = NULL, adjust = NULL, kernel = NULL,
-  n_dens = NULL
+  n_dens = NULL,
+  bounds = NULL
 ) {
   check_ignored_arguments(...)
+  bounds <- validate_density_bounds(bounds)
 
   x %>%
     prepare_mcmc_array(
@@ -329,7 +337,8 @@ mcmc_dens_chains_data <- function(
       group_vars = c("Parameter", "Chain"),
       value_var = "Value",
       interval_width = 1,
-      bw = bw, adjust = adjust, kernel = kernel, n_dens = n_dens
+      bw = bw, adjust = adjust, kernel = kernel,
+      bounds = bounds, n_dens = n_dens
     ) %>%
     mutate(Chain = factor(.data$Chain)) %>%
     rlang::set_names(tolower) %>%
@@ -441,19 +450,21 @@ mcmc_violin <- function(
   color_chains = FALSE,
   geom = c("density", "violin"),
   probs = c(0.1, 0.5, 0.9),
-  trim = FALSE,
-  alpha = 1,
-  bw = NULL,
-  adjust = NULL,
-  kernel = NULL,
-  n_dens = NULL,
-  ...
-) {
+    trim = FALSE,
+    alpha = 1,
+    bw = NULL,
+    adjust = NULL,
+    kernel = NULL,
+    n_dens = NULL,
+    bounds = NULL,
+    ...
+  ) {
 
   bw <- bw %||% "nrd0"
   adjust <- adjust %||% 1
   kernel <- kernel %||% "gaussian"
   n_dens <- n_dens %||% 1024
+  bounds <- validate_density_bounds(bounds)
 
   x <- prepare_mcmc_array(x, pars, regex_pars, transformations)
   data <- melt_mcmc.mcmc_array(x)
@@ -475,12 +486,20 @@ mcmc_violin <- function(
   geom_args <- list(linewidth = 0.5, na.rm = TRUE, alpha = alpha)
   if (violin) {
     geom_args[["draw_quantiles"]] <- probs
+    if (utils::packageVersion("ggplot2") >= "4.0.0") {
+      geom_args[["draw_quantiles"]] <- NULL
+      geom_args[["quantiles"]] <- probs
+      geom_args[["quantile.linetype"]] <- 1
+    }
   } else {
     geom_args[["trim"]] <- trim
     geom_args[["bw"]] <- bw
     geom_args[["adjust"]] <- adjust
     geom_args[["kernel"]] <- kernel
     geom_args[["n"]] <- n_dens
+    if (!is.null(bounds)) {
+      geom_args[["bounds"]] <- bounds
+    }
   }
   if (by_chain) {
     # aes_mapping[["color"]] <- ~ Chain

R/mcmc-intervals.R

@@ -301,15 +301,17 @@ mcmc_areas <- function(x,
                        bw = NULL,
                        adjust = NULL,
                        kernel = NULL,
-                       n_dens = NULL) {
+                       n_dens = NULL,
+                       bounds = NULL) {
   check_ignored_arguments(...)
   area_method <- match.arg(area_method)
 
   data <- mcmc_areas_data(
     x, pars, regex_pars, transformations,
     prob = prob, prob_outer = prob_outer,
     point_est = point_est, rhat = rhat,
-    bw = bw, adjust = adjust, kernel = kernel, n_dens = n_dens
+    bw = bw, adjust = adjust, kernel = kernel,
+    n_dens = n_dens, bounds = bounds
   )
   datas <- split(data, data$interval)
 
@@ -474,13 +476,14 @@ mcmc_areas_ridges <- function(x,
                              prob = 1,
                              border_size = NULL,
                              bw = NULL, adjust = NULL, kernel = NULL,
-                             n_dens = NULL) {
+                             n_dens = NULL,
+                             bounds = NULL) {
   check_ignored_arguments(...)
   data <- mcmc_areas_ridges_data(x, pars = pars, regex_pars = regex_pars,
                                  transformations = transformations,
                                  prob = prob, prob_outer = prob_outer,
                                  bw = bw, adjust = adjust, kernel = kernel,
-                                 n_dens = n_dens)
+                                 n_dens = n_dens, bounds = bounds)
 
   datas <- data %>%
     split(data$interval)
@@ -668,8 +671,10 @@ mcmc_areas_data <- function(x,
                             bw = NULL,
                             adjust = NULL,
                             kernel = NULL,
-                            n_dens = NULL) {
+                            n_dens = NULL,
+                            bounds = NULL) {
   probs <- check_interval_widths(prob, prob_outer)
+  bounds <- validate_density_bounds(bounds)
 
   # First compute normal intervals so we know the width of the data, point
   # estimates, and have prepared rhat values.
@@ -699,6 +704,7 @@ mcmc_areas_data <- function(x,
       bw = bw,
       adjust = adjust,
       kernel = kernel,
+      bounds = bounds,
       n_dens = n_dens) %>%
     mutate(interval = "inner")
 
@@ -710,6 +716,7 @@ mcmc_areas_data <- function(x,
       bw = bw,
       adjust = adjust,
       kernel = kernel,
+      bounds = bounds,
       n_dens = n_dens) %>%
     mutate(interval = "outer")
 
@@ -777,12 +784,14 @@ mcmc_areas_ridges_data <- function(x,
                                    prob = 1,
                                    bw = NULL,
                                    adjust = NULL, kernel = NULL,
-                                   n_dens = NULL) {
+                                   n_dens = NULL,
+                                   bounds = NULL) {
   check_ignored_arguments(...)
   mcmc_areas_data(x, pars = pars, regex_pars = regex_pars,
                   transformations = transformations,
                   prob = prob, prob_outer = prob_outer, point_est = "none",
-                  bw = bw, adjust = adjust, kernel = kernel, n_dens = n_dens)
+                  bw = bw, adjust = adjust, kernel = kernel,
+                  n_dens = n_dens, bounds = bounds)
 }
 
 
@@ -841,15 +850,24 @@ compute_column_density <- function(df, group_vars, value_var, ...) {
 
 # Given a vector of values, compute a density dataframe.
 compute_interval_density <- function(x, interval_width = 1, n_dens = 1024,
-                                     bw = NULL, adjust = NULL, kernel = NULL) {
+                                     bw = NULL, adjust = NULL, kernel = NULL,
+                                     bounds = NULL) {
   n_dens <- n_dens %||% 1024
 
   tail_width <- (1 - interval_width) / 2
   qs <- quantile(x, probs = c(tail_width, 1 - tail_width))
+  support <- range(qs)
+  if (!is.null(bounds)) {
+    support[1] <- max(bounds[1], support[1])
+    support[2] <- min(bounds[2], support[2])
+    if (!(support[1] < support[2])) {
+      support <- range(qs)
+    }
+  }
 
   args <- c(
     # can't be null
-    list(x = x, from = min(qs), to = max(qs), n = n_dens),
+    list(x = x, from = support[1], to = support[2], n = n_dens),
     # might be null
     bw = bw, adjust = adjust, kernel = kernel)