From c96c7d6ba25c00e151845116f358dd28af408992 Mon Sep 17 00:00:00 2001 From: Tristan Mahr Date: Tue, 13 May 2025 14:40:48 -0500 Subject: [PATCH 1/8] add fun_avg to ppc_avg functions --- NEWS.md | 1 + R/ppc-errors.R | 14 +++++++++++--- R/ppc-scatterplots.R | 27 +++++++++++++++++++-------- man/PPC-errors.Rd | 16 ++++++++++++++-- man/PPC-scatterplots.Rd | 27 +++++++++++++++++++++------ 5 files changed, 66 insertions(+), 19 deletions(-) diff --git a/NEWS.md b/NEWS.md index c4baf42a..1d1e4bc3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ * 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 `fun_arg` argument to set the averaging function. (Suggestion of #348, @kruschke). # bayesplot 1.12.0 diff --git a/R/ppc-errors.R b/R/ppc-errors.R index 510e95f9..0f977ec3 100644 --- a/R/ppc-errors.R +++ b/R/ppc-errors.R @@ -10,6 +10,8 @@ #' @template args-group #' @template args-facet_args #' @param ... Currently unused. +#' @param fun_avg Function to apply to compute the posterior average. +#' Defaults to `"mean"`. #' @param size,alpha For scatterplots, arguments passed to #' [ggplot2::geom_point()] to control the appearance of the points. For the #' binned error plot, arguments controlling the size of the outline and @@ -209,6 +211,7 @@ ppc_error_scatter_avg <- function(y, yrep, ..., + fun_avg = "mean", size = 2.5, alpha = 0.8) { check_ignored_arguments(...) @@ -221,7 +224,8 @@ ppc_error_scatter_avg <- yrep = errors, size = size, alpha = alpha, - ref_line = FALSE + ref_line = FALSE, + fun_avg = fun_avg ) + labs(x = error_avg_label(), y = y_label()) } @@ -234,6 +238,7 @@ ppc_error_scatter_avg_grouped <- yrep, group, ..., + fun_avg = "mean", facet_args = list(), size = 2.5, alpha = 0.8) { @@ -249,7 +254,8 @@ ppc_error_scatter_avg_grouped <- size = size, alpha = alpha, facet_args = facet_args, - ref_line = FALSE + ref_line = FALSE, + fun_avg = fun_avg ) + labs(x = error_avg_label(), y = y_label()) } @@ -265,6 +271,7 @@ ppc_error_scatter_avg_vs_x <- yrep, x, ..., + fun_avg = "mean", size = 2.5, alpha = 0.8) { check_ignored_arguments(...) @@ -278,7 +285,8 @@ ppc_error_scatter_avg_vs_x <- yrep = errors, size = size, alpha = alpha, - ref_line = FALSE + ref_line = FALSE, + fun_avg = fun_avg ) + labs(x = error_avg_label(), y = expression(italic(x))) + coord_flip() diff --git a/R/ppc-scatterplots.R b/R/ppc-scatterplots.R index dd16620d..3d0df608 100644 --- a/R/ppc-scatterplots.R +++ b/R/ppc-scatterplots.R @@ -11,6 +11,8 @@ #' @template args-group #' @template args-facet_args #' @param ... Currently unused. +#' @param fun_avg Function to apply to compute the posterior average. +#' Defaults to `"mean"`. #' @param size,alpha Arguments passed to [ggplot2::geom_point()] to control the #' appearance of the points. #' @param ref_line If `TRUE` (the default) a dashed line with intercept 0 and @@ -31,10 +33,10 @@ #' } #' \item{`ppc_scatter_avg()`}{ #' A single scatterplot of `y` against the average values of `yrep`, i.e., -#' the points `(x,y) = (mean(yrep[, n]), y[n])`, where each `yrep[, n]` is -#' a vector of length equal to the number of posterior draws. Unlike -#' for `ppc_scatter()`, for `ppc_scatter_avg()` `yrep` should contain many -#' draws (rows). +#' the points `(x,y) = (average(yrep[, n]), y[n])`, where each `yrep[, n]` is +#' a vector of length equal to the number of posterior draws and `average()` +#' is summary statistic. Unlike for `ppc_scatter()`, for `ppc_scatter_avg()` +#' `yrep` should contain many draws (rows). #' } #' \item{`ppc_scatter_avg_grouped()`}{ #' The same as `ppc_scatter_avg()`, but a separate plot is generated for @@ -59,6 +61,9 @@ #' p1 + lims #' p2 + lims #' +#' # "average" function is customizable +#' ppc_scatter_avg(y, yrep, fun_avg = "median", ref_line = FALSE) +#' #' # for ppc_scatter_avg_grouped the default is to allow the facets #' # to have different x and y axes #' group <- example_group_data() @@ -116,6 +121,7 @@ ppc_scatter_avg <- function(y, yrep, ..., + fun_avg = "mean", size = 2.5, alpha = 0.8, ref_line = TRUE) { @@ -125,7 +131,7 @@ ppc_scatter_avg <- dots$group <- NULL } - data <- ppc_scatter_avg_data(y, yrep, group = dots$group) + data <- ppc_scatter_avg_data(y, yrep, group = dots$group, fun_avg = fun_avg) if (is.null(dots$group) && nrow(yrep) == 1) { inform( "With only 1 row in 'yrep' ppc_scatter_avg is the same as ppc_scatter." @@ -155,6 +161,7 @@ ppc_scatter_avg_grouped <- yrep, group, ..., + fun_avg = "mean", facet_args = list(), size = 2.5, alpha = 0.8, @@ -184,16 +191,20 @@ ppc_scatter_data <- function(y, yrep) { #' @rdname PPC-scatterplots #' @export -ppc_scatter_avg_data <- function(y, yrep, group = NULL) { +ppc_scatter_avg_data <- function(y, yrep, group = NULL, fun_avg = "mean") { y <- validate_y(y) yrep <- validate_predictions(yrep, length(y)) if (!is.null(group)) { group <- validate_group(group, length(y)) } - data <- ppc_scatter_data(y = y, yrep = t(colMeans(yrep))) + data <- ppc_scatter_data(y = y, yrep = t(apply(yrep, 2, FUN = fun_avg))) data$rep_id <- NA_integer_ - levels(data$rep_label) <- "mean(italic(y)[rep]))" + if (is.character(fun_avg)) { + levels(data$rep_label) <- sprintf("%s(italic(y)[rep]))", fun_avg) + } else { + levels(data$rep_label) <- "Average(italic(y)[rep]))" + } if (!is.null(group)) { data <- tibble::add_column(data, diff --git a/man/PPC-errors.Rd b/man/PPC-errors.Rd index 88610f8b..84050531 100644 --- a/man/PPC-errors.Rd +++ b/man/PPC-errors.Rd @@ -37,19 +37,28 @@ ppc_error_hist_grouped( ppc_error_scatter(y, yrep, ..., facet_args = list(), size = 2.5, alpha = 0.8) -ppc_error_scatter_avg(y, yrep, ..., size = 2.5, alpha = 0.8) +ppc_error_scatter_avg(y, yrep, ..., fun_avg = "mean", size = 2.5, alpha = 0.8) ppc_error_scatter_avg_grouped( y, yrep, group, ..., + fun_avg = "mean", facet_args = list(), size = 2.5, alpha = 0.8 ) -ppc_error_scatter_avg_vs_x(y, yrep, x, ..., size = 2.5, alpha = 0.8) +ppc_error_scatter_avg_vs_x( + y, + yrep, + x, + ..., + fun_avg = "mean", + size = 2.5, + alpha = 0.8 +) ppc_error_binned( y, @@ -106,6 +115,9 @@ to the corresponding observation.} binned error plot, arguments controlling the size of the outline and opacity of the shaded region indicating the 2-SE bounds.} +\item{fun_avg}{Function to apply to compute the posterior average. +Defaults to \code{"mean"}.} + \item{x}{A numeric vector the same length as \code{y} to use as the x-axis variable.} } diff --git a/man/PPC-scatterplots.Rd b/man/PPC-scatterplots.Rd index 64963c40..9f853a32 100644 --- a/man/PPC-scatterplots.Rd +++ b/man/PPC-scatterplots.Rd @@ -19,13 +19,22 @@ ppc_scatter( ref_line = TRUE ) -ppc_scatter_avg(y, yrep, ..., size = 2.5, alpha = 0.8, ref_line = TRUE) +ppc_scatter_avg( + y, + yrep, + ..., + fun_avg = "mean", + size = 2.5, + alpha = 0.8, + ref_line = TRUE +) ppc_scatter_avg_grouped( y, yrep, group, ..., + fun_avg = "mean", facet_args = list(), size = 2.5, alpha = 0.8, @@ -34,7 +43,7 @@ ppc_scatter_avg_grouped( ppc_scatter_data(y, yrep) -ppc_scatter_avg_data(y, yrep, group = NULL) +ppc_scatter_avg_data(y, yrep, group = NULL, fun_avg = "mean") } \arguments{ \item{y}{A vector of observations. See \strong{Details}.} @@ -61,6 +70,9 @@ appearance of the points.} \item{ref_line}{If \code{TRUE} (the default) a dashed line with intercept 0 and slope 1 is drawn behind the scatter plot.} +\item{fun_avg}{Function to apply to compute the posterior average. +Defaults to \code{"mean"}.} + \item{group}{A grouping variable of the same length as \code{y}. Will be coerced to \link[base:factor]{factor} if not already a factor. Each value in \code{group} is interpreted as the group level pertaining @@ -92,10 +104,10 @@ small number of rows. } \item{\code{ppc_scatter_avg()}}{ A single scatterplot of \code{y} against the average values of \code{yrep}, i.e., -the points \verb{(x,y) = (mean(yrep[, n]), y[n])}, where each \code{yrep[, n]} is -a vector of length equal to the number of posterior draws. Unlike -for \code{ppc_scatter()}, for \code{ppc_scatter_avg()} \code{yrep} should contain many -draws (rows). +the points \verb{(x,y) = (average(yrep[, n]), y[n])}, where each \code{yrep[, n]} is +a vector of length equal to the number of posterior draws and \code{average()} +is summary statistic. Unlike for \code{ppc_scatter()}, for \code{ppc_scatter_avg()} +\code{yrep} should contain many draws (rows). } \item{\code{ppc_scatter_avg_grouped()}}{ The same as \code{ppc_scatter_avg()}, but a separate plot is generated for @@ -121,6 +133,9 @@ lims <- ggplot2::lims(x = c(0, 160), y = c(0, 160)) p1 + lims p2 + lims +# "average" function is customizable +ppc_scatter_avg(y, yrep, fun_avg = "median", ref_line = FALSE) + # for ppc_scatter_avg_grouped the default is to allow the facets # to have different x and y axes group <- example_group_data() From ffe723f1142f2bb4f154563997ac5da56fb53a98 Mon Sep 17 00:00:00 2001 From: Tristan Mahr Date: Wed, 14 May 2025 15:15:36 -0500 Subject: [PATCH 2/8] forward "stat" to axis labels in ppc --- NEWS.md | 2 +- R/bayesplot-helpers.R | 44 +++++++++++++ R/ppc-errors.R | 40 +++++++---- R/ppc-scatterplots.R | 43 +++++++----- man/PPC-errors.Rd | 10 +-- man/PPC-scatterplots.Rd | 15 +++-- tests/testthat/test-convenience-functions.R | 73 +++++++++++++++++++++ tests/testthat/test-ppc-scatterplots.R | 9 +++ 8 files changed, 197 insertions(+), 39 deletions(-) diff --git a/NEWS.md b/NEWS.md index 1d1e4bc3..41b7eac5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,7 @@ * 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 `fun_arg` argument to set the averaging function. (Suggestion of #348, @kruschke). +* PPC "avg" functions (`ppc_scatter_avg()`, `ppc_error_scatter_avg()`, etc.) gain a `stat` argument to set the averaging function. (Suggestion of #348, @kruschke). # bayesplot 1.12.0 diff --git a/R/bayesplot-helpers.R b/R/bayesplot-helpers.R index 573835aa..4e61a474 100644 --- a/R/bayesplot-helpers.R +++ b/R/bayesplot-helpers.R @@ -469,3 +469,47 @@ 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 object +#' @param f_expr (optional) expression to provide. We need this value when +#' constructing tagged function inside of a function function. +#' @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. +as_tagged_function <- function(f, f_expr = NULL, fallback = "func") { + if (is.null(f_expr)) f_expr <- enexpr(f) + if (!is.null(attr(f, "tagged_expr"))) return(f) + + if (rlang::is_character(f)) { # f = "mean" + f_expr <- rlang::sym(f) + f_fn <- match.fun(f) + } else if (is_null(f)) { # f = NULL + f_fn <- identity + f_expr <- rlang::sym(fallback) + } else if (is_expression(f)) { # f = quote(mean) + f_expr <- f + f_fn <- rlang::eval_tidy(f_expr) + } else if (is_callable(f)) { # f = mean or f = function(x) mean(x) + f_expr <- f_expr + f_fn <- 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") + f_fn +} + + + diff --git a/R/ppc-errors.R b/R/ppc-errors.R index 0f977ec3..f9faedbb 100644 --- a/R/ppc-errors.R +++ b/R/ppc-errors.R @@ -10,8 +10,10 @@ #' @template args-group #' @template args-facet_args #' @param ... Currently unused. -#' @param fun_avg Function to apply to compute the posterior average. -#' Defaults to `"mean"`. +#' @param stat A function or a string naming a function for computing the +#' posterior average. In both cases, the function should take a vector input and +#' return a scalar statistic. The function name is displayed in the axis-label. +#' Defaults to `"mean"`. #' @param size,alpha For scatterplots, arguments passed to #' [ggplot2::geom_point()] to control the appearance of the points. For the #' binned error plot, arguments controlling the size of the outline and @@ -211,7 +213,7 @@ ppc_error_scatter_avg <- function(y, yrep, ..., - fun_avg = "mean", + stat = "mean", size = 2.5, alpha = 0.8) { check_ignored_arguments(...) @@ -219,15 +221,17 @@ ppc_error_scatter_avg <- y <- validate_y(y) yrep <- validate_predictions(yrep, length(y)) errors <- compute_errors(y, yrep) + stat <- as_tagged_function(stat, enexpr(stat)) + ppc_scatter_avg( y = y, yrep = errors, size = size, alpha = alpha, ref_line = FALSE, - fun_avg = fun_avg + stat = stat ) + - labs(x = error_avg_label(), y = y_label()) + labs(x = error_avg_label(stat), y = y_label()) } @@ -238,7 +242,7 @@ ppc_error_scatter_avg_grouped <- yrep, group, ..., - fun_avg = "mean", + stat = "mean", facet_args = list(), size = 2.5, alpha = 0.8) { @@ -246,6 +250,8 @@ ppc_error_scatter_avg_grouped <- y <- validate_y(y) yrep <- validate_predictions(yrep, length(y)) + stat <- as_tagged_function(stat, enexpr(stat)) + errors <- compute_errors(y, yrep) ppc_scatter_avg_grouped( y = y, @@ -255,9 +261,9 @@ ppc_error_scatter_avg_grouped <- alpha = alpha, facet_args = facet_args, ref_line = FALSE, - fun_avg = fun_avg + stat = stat ) + - labs(x = error_avg_label(), y = y_label()) + labs(x = error_avg_label(stat), y = y_label()) } @@ -271,7 +277,7 @@ ppc_error_scatter_avg_vs_x <- yrep, x, ..., - fun_avg = "mean", + stat = "mean", size = 2.5, alpha = 0.8) { check_ignored_arguments(...) @@ -279,6 +285,7 @@ ppc_error_scatter_avg_vs_x <- y <- validate_y(y) yrep <- validate_predictions(yrep, length(y)) x <- validate_x(x, y) + stat <- as_tagged_function(stat, enexpr(stat)) errors <- compute_errors(y, yrep) ppc_scatter_avg( y = x, @@ -286,9 +293,9 @@ ppc_error_scatter_avg_vs_x <- size = size, alpha = alpha, ref_line = FALSE, - fun_avg = fun_avg + stat = stat ) + - labs(x = error_avg_label(), y = expression(italic(x))) + + labs(x = error_avg_label(stat), y = expression(italic(x))) + coord_flip() } @@ -422,8 +429,15 @@ error_hist_facets <- error_label <- function() { expression(italic(y) - italic(y)[rep]) } -error_avg_label <- function() { - expression(paste("Average ", italic(y) - italic(y)[rep])) + +error_avg_label <- function(stat = NULL) { + stat <- as_tagged_function(stat, enexpr(stat), fallback = "Average") + e <- if (attr(stat, "is_anonymous_function")) { + expr("Average") + } else { + attr(stat, "tagged_expr") + } + expr(plain((!!e))(italic(y) - italic(y)[rep])) } diff --git a/R/ppc-scatterplots.R b/R/ppc-scatterplots.R index 3d0df608..f0120cbe 100644 --- a/R/ppc-scatterplots.R +++ b/R/ppc-scatterplots.R @@ -11,8 +11,11 @@ #' @template args-group #' @template args-facet_args #' @param ... Currently unused. -#' @param fun_avg Function to apply to compute the posterior average. -#' Defaults to `"mean"`. +#' @param stat A function or a string naming a function for computing the +#' posterior average. In both cases, the function should take a vector input +#' and return a scalar statistic. The function name is displayed in the +#' axis-label, and the underlying `$rep_label` for `ppc_scatter_avg_data()` +#' includes the function name. Defaults to `"mean"`. #' @param size,alpha Arguments passed to [ggplot2::geom_point()] to control the #' appearance of the points. #' @param ref_line If `TRUE` (the default) a dashed line with intercept 0 and @@ -62,7 +65,7 @@ #' p2 + lims #' #' # "average" function is customizable -#' ppc_scatter_avg(y, yrep, fun_avg = "median", ref_line = FALSE) +#' ppc_scatter_avg(y, yrep, stat = "median", ref_line = FALSE) #' #' # for ppc_scatter_avg_grouped the default is to allow the facets #' # to have different x and y axes @@ -121,17 +124,19 @@ ppc_scatter_avg <- function(y, yrep, ..., - fun_avg = "mean", + stat = "mean", size = 2.5, alpha = 0.8, ref_line = TRUE) { dots <- list(...) + stat <- as_tagged_function(stat, enexpr(stat)) + if (!from_grouped(dots)) { check_ignored_arguments(...) dots$group <- NULL } - data <- ppc_scatter_avg_data(y, yrep, group = dots$group, fun_avg = fun_avg) + data <- ppc_scatter_avg_data(y, yrep, group = dots$group, stat = stat) if (is.null(dots$group) && nrow(yrep) == 1) { inform( "With only 1 row in 'yrep' ppc_scatter_avg is the same as ppc_scatter." @@ -149,7 +154,7 @@ ppc_scatter_avg <- # ppd instead of ppc (see comment in ppc_scatter) scale_color_ppd() + scale_fill_ppd() + - labs(x = yrep_avg_label(), y = y_label()) + + labs(x = yrep_avg_label(stat), y = y_label()) + bayesplot_theme_get() } @@ -161,7 +166,7 @@ ppc_scatter_avg_grouped <- yrep, group, ..., - fun_avg = "mean", + stat = "mean", facet_args = list(), size = 2.5, alpha = 0.8, @@ -191,20 +196,19 @@ ppc_scatter_data <- function(y, yrep) { #' @rdname PPC-scatterplots #' @export -ppc_scatter_avg_data <- function(y, yrep, group = NULL, fun_avg = "mean") { +ppc_scatter_avg_data <- function(y, yrep, group = NULL, stat = "mean") { y <- validate_y(y) yrep <- validate_predictions(yrep, length(y)) if (!is.null(group)) { group <- validate_group(group, length(y)) } + stat <- as_tagged_function(stat, enexpr(stat)) - data <- ppc_scatter_data(y = y, yrep = t(apply(yrep, 2, FUN = fun_avg))) + data <- ppc_scatter_data(y = y, yrep = t(apply(yrep, 2, FUN = stat))) data$rep_id <- NA_integer_ - if (is.character(fun_avg)) { - levels(data$rep_label) <- sprintf("%s(italic(y)[rep]))", fun_avg) - } else { - levels(data$rep_label) <- "Average(italic(y)[rep]))" - } + levels(data$rep_label) <- yrep_avg_label(stat) |> + as.expression() |> + as.character() if (!is.null(group)) { data <- tibble::add_column(data, @@ -217,7 +221,16 @@ ppc_scatter_avg_data <- function(y, yrep, group = NULL, fun_avg = "mean") { } # internal ---------------------------------------------------------------- -yrep_avg_label <- function() expression(paste("Average ", italic(y)[rep])) + +yrep_avg_label <- function(stat = NULL) { + stat <- as_tagged_function(stat, enexpr(stat), fallback = "Average") + e <- if (attr(stat, "is_anonymous_function")) { + expr("Average") + } else { + attr(stat, "tagged_expr") + } + expr(plain((!!e)) (italic(y)[rep])) +} scatter_aes <- function(...) { aes(x = .data$value, y = .data$y_obs, ...) diff --git a/man/PPC-errors.Rd b/man/PPC-errors.Rd index 84050531..047590bf 100644 --- a/man/PPC-errors.Rd +++ b/man/PPC-errors.Rd @@ -37,14 +37,14 @@ ppc_error_hist_grouped( ppc_error_scatter(y, yrep, ..., facet_args = list(), size = 2.5, alpha = 0.8) -ppc_error_scatter_avg(y, yrep, ..., fun_avg = "mean", size = 2.5, alpha = 0.8) +ppc_error_scatter_avg(y, yrep, ..., stat = "mean", size = 2.5, alpha = 0.8) ppc_error_scatter_avg_grouped( y, yrep, group, ..., - fun_avg = "mean", + stat = "mean", facet_args = list(), size = 2.5, alpha = 0.8 @@ -55,7 +55,7 @@ ppc_error_scatter_avg_vs_x( yrep, x, ..., - fun_avg = "mean", + stat = "mean", size = 2.5, alpha = 0.8 ) @@ -115,7 +115,9 @@ to the corresponding observation.} binned error plot, arguments controlling the size of the outline and opacity of the shaded region indicating the 2-SE bounds.} -\item{fun_avg}{Function to apply to compute the posterior average. +\item{stat}{A function or a string naming a function for computing the +posterior average. In both cases, the function should take a vector input and +return a scalar statistic. The function name is displayed in the axis-label. Defaults to \code{"mean"}.} \item{x}{A numeric vector the same length as \code{y} to use as the x-axis diff --git a/man/PPC-scatterplots.Rd b/man/PPC-scatterplots.Rd index 9f853a32..c78edf81 100644 --- a/man/PPC-scatterplots.Rd +++ b/man/PPC-scatterplots.Rd @@ -23,7 +23,7 @@ ppc_scatter_avg( y, yrep, ..., - fun_avg = "mean", + stat = "mean", size = 2.5, alpha = 0.8, ref_line = TRUE @@ -34,7 +34,7 @@ ppc_scatter_avg_grouped( yrep, group, ..., - fun_avg = "mean", + stat = "mean", facet_args = list(), size = 2.5, alpha = 0.8, @@ -43,7 +43,7 @@ ppc_scatter_avg_grouped( ppc_scatter_data(y, yrep) -ppc_scatter_avg_data(y, yrep, group = NULL, fun_avg = "mean") +ppc_scatter_avg_data(y, yrep, group = NULL, stat = "mean") } \arguments{ \item{y}{A vector of observations. See \strong{Details}.} @@ -70,8 +70,11 @@ appearance of the points.} \item{ref_line}{If \code{TRUE} (the default) a dashed line with intercept 0 and slope 1 is drawn behind the scatter plot.} -\item{fun_avg}{Function to apply to compute the posterior average. -Defaults to \code{"mean"}.} +\item{stat}{A function or a string naming a function for computing the +posterior average. In both cases, the function should take a vector input +and return a scalar statistic. The function name is displayed in the +axis-label, and the underlying \verb{$rep_label} for \code{ppc_scatter_avg_data()} +includes the function name. Defaults to \code{"mean"}.} \item{group}{A grouping variable of the same length as \code{y}. Will be coerced to \link[base:factor]{factor} if not already a factor. @@ -134,7 +137,7 @@ p1 + lims p2 + lims # "average" function is customizable -ppc_scatter_avg(y, yrep, fun_avg = "median", ref_line = FALSE) +ppc_scatter_avg(y, yrep, stat = "median", ref_line = FALSE) # for ppc_scatter_avg_grouped the default is to allow the facets # to have different x and y axes diff --git a/tests/testthat/test-convenience-functions.R b/tests/testthat/test-convenience-functions.R index 7389973e..15bd03dd 100644 --- a/tests/testthat/test-convenience-functions.R +++ b/tests/testthat/test-convenience-functions.R @@ -187,3 +187,76 @@ test_that("overlay_function returns the correct object", { a$constructor <- b$constructor <- NULL expect_equal(a, b, check.environment = FALSE) }) + + +# tagged functions ------------------------------------------------------- + +test_that("as_tagged_function handles bare function (symbol)", { + fn <- as_tagged_function(mean) + expect_type(fn, "closure") + expect_equal(fn(1:10), mean(1:10)) + expect_equal(attr(fn, "tagged_expr"), rlang::expr(mean)) + + # primitive functions are wrapped then tagged + fn <- as_tagged_function(max) + expect_equal(fn(1:10), 10) + expect_equal(attr(fn, "tagged_expr"), rlang::expr(max)) +}) + +test_that("as_tagged_function handles string input", { + fn <- as_tagged_function("mean") + expect_type(fn, "closure") + expect_equal(fn(1:10), mean(1:10)) + expect_equal(attr(fn, "tagged_expr"), rlang::sym("mean")) +}) + +test_that("as_tagged_function handles quoted symbol", { + fn <- as_tagged_function(quote(mean)) + expect_type(fn, "closure") + expect_equal(fn(1:10), mean(1:10)) + expect_equal(attr(fn, "tagged_expr"), quote(mean)) +}) + +test_that("as_tagged_function handles anonymous function", { + fn <- as_tagged_function(function(x) mean(x^2)) + expect_type(fn, "closure") + expect_equal(fn(1:3), mean((1:3)^2)) + expect_equal(attr(fn, "tagged_expr"), rlang::expr( function(x) mean(x^2))) +}) + +test_that("as_tagged_function handles NULL with fallback name", { + fn <- as_tagged_function(NULL, fallback = "my_func") + expect_type(fn, "closure") + expect_equal(fn(1:5), 1:5) + expect_equal(attr(fn, "tagged_expr"), rlang::sym("my_func")) +}) + +test_that("as_tagged_function doesn't lose previous tags", { + fn1 <- as_tagged_function(mean) + fn2 <- as_tagged_function(fn1) + expect_identical(fn1, fn2) + expect_equal(attr(fn2, "tagged_expr"), rlang::expr(mean)) + + f_outer <- function(stat_outer) { + stat_outer <- as_tagged_function(stat_outer, enexpr(stat_outer)) + f_inner(stat_outer) + } + f_inner <- function(stat_inner) { + stat_inner <- as_tagged_function(stat_inner, enexpr(stat_inner)) + stat_inner + } + + # We don't want the tagged expressions to be stat_outer or stat_inner + my_function_name <- identity + f_inner(my_function_name) |> + attr("tagged_expr") |> + deparse() |> + expect_equal("my_function_name") + + f_outer(my_function_name) |> + attr("tagged_expr") |> + deparse() |> + expect_equal("my_function_name") + + +}) diff --git a/tests/testthat/test-ppc-scatterplots.R b/tests/testthat/test-ppc-scatterplots.R index 2640472e..9116b115 100644 --- a/tests/testthat/test-ppc-scatterplots.R +++ b/tests/testthat/test-ppc-scatterplots.R @@ -28,6 +28,15 @@ test_that("ppc_scatter_avg_grouped returns a ggplot object", { expect_gg(ppc_scatter_avg_grouped(y, yrep, as.integer(group))) }) +test_that("ppc_scatter_avg_data can take a custom fun_avg", { + # using the colMeans() and colSums() to avoid using apply(yrep, 2, fun) + # because apply() is used in ppc_scatter_avg_data() + means <- ppc_scatter_avg_data(y, yrep) + expect_equal(means$value, colMeans(yrep)) + sums <- ppc_scatter_avg_data(y, yrep, stat = "sum") + expect_equal(sums$value, colSums(yrep)) +}) + # Visual tests ------------------------------------------------------------ From c647d6924b89e91dce08f3265070c610048341cd Mon Sep 17 00:00:00 2001 From: Tristan Mahr Date: Wed, 14 May 2025 15:34:21 -0500 Subject: [PATCH 3/8] fix docs --- R/bayesplot-helpers.R | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/R/bayesplot-helpers.R b/R/bayesplot-helpers.R index 4e61a474..26270f6d 100644 --- a/R/bayesplot-helpers.R +++ b/R/bayesplot-helpers.R @@ -474,12 +474,17 @@ overlay_function <- function(...) { # Resolve a function name and store the expression passed in by the user #' @noRd -#' @param f a function-like object -#' @param f_expr (optional) expression to provide. We need this value when -#' constructing tagged function inside of a function function. +#' @param f a function-like thing: a string naming a function, a function +#' object, a `quote()`-ed function name, an anonymous function object, and +#' `NULL`. +#' @param f_expr (optional) expression to record. Inside of a function we would +#' write `as_tagged_function(stat, enexpr(stat))` to make sure that the user's +#' expression is the tagged expression. #' @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. +#' 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, f_expr = NULL, fallback = "func") { if (is.null(f_expr)) f_expr <- enexpr(f) if (!is.null(attr(f, "tagged_expr"))) return(f) From 23865df222eb7b21efe9e2fb965eae201da0352e Mon Sep 17 00:00:00 2001 From: TJ Mahr Date: Thu, 15 May 2025 15:29:20 -0500 Subject: [PATCH 4/8] simplify as_tagged_function() --- R/bayesplot-helpers.R | 20 ++++++++++---------- R/ppc-errors.R | 19 ++++++++++--------- R/ppc-scatterplots.R | 16 ++++++++-------- tests/testthat/test-convenience-functions.R | 15 +++++---------- 4 files changed, 33 insertions(+), 37 deletions(-) diff --git a/R/bayesplot-helpers.R b/R/bayesplot-helpers.R index 26270f6d..36eaa3d1 100644 --- a/R/bayesplot-helpers.R +++ b/R/bayesplot-helpers.R @@ -475,29 +475,29 @@ overlay_function <- function(...) { # 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, a `quote()`-ed function name, an anonymous function object, and -#' `NULL`. -#' @param f_expr (optional) expression to record. Inside of a function we would -#' write `as_tagged_function(stat, enexpr(stat))` to make sure that the user's -#' expression is the tagged expression. +#' object, an anonymous function object, 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, f_expr = NULL, fallback = "func") { - if (is.null(f_expr)) f_expr <- enexpr(f) +as_tagged_function <- function(f, 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 (rlang::is_character(f)) { # f = "mean" + # using sym() on the evaluated `f` that a variable that names a + # function string `x <- "mean"; as_tagged_function(x)` will be lost + # but that seems okay! f_expr <- rlang::sym(f) f_fn <- match.fun(f) } else if (is_null(f)) { # f = NULL f_fn <- identity f_expr <- rlang::sym(fallback) - } else if (is_expression(f)) { # f = quote(mean) - f_expr <- f - f_fn <- rlang::eval_tidy(f_expr) } else if (is_callable(f)) { # f = mean or f = function(x) mean(x) f_expr <- f_expr f_fn <- f diff --git a/R/ppc-errors.R b/R/ppc-errors.R index f9faedbb..93db3b24 100644 --- a/R/ppc-errors.R +++ b/R/ppc-errors.R @@ -221,7 +221,8 @@ ppc_error_scatter_avg <- y <- validate_y(y) yrep <- validate_predictions(yrep, length(y)) errors <- compute_errors(y, yrep) - stat <- as_tagged_function(stat, enexpr(stat)) + + stat <- as_tagged_function({{ stat }}) ppc_scatter_avg( y = y, @@ -250,7 +251,7 @@ ppc_error_scatter_avg_grouped <- y <- validate_y(y) yrep <- validate_predictions(yrep, length(y)) - stat <- as_tagged_function(stat, enexpr(stat)) + stat <- as_tagged_function({{ stat }}) errors <- compute_errors(y, yrep) ppc_scatter_avg_grouped( @@ -285,7 +286,7 @@ ppc_error_scatter_avg_vs_x <- y <- validate_y(y) yrep <- validate_predictions(yrep, length(y)) x <- validate_x(x, y) - stat <- as_tagged_function(stat, enexpr(stat)) + stat <- as_tagged_function({{ stat }}) errors <- compute_errors(y, yrep) ppc_scatter_avg( y = x, @@ -431,13 +432,13 @@ error_label <- function() { } error_avg_label <- function(stat = NULL) { - stat <- as_tagged_function(stat, enexpr(stat), fallback = "Average") - e <- if (attr(stat, "is_anonymous_function")) { - expr("Average") - } else { - attr(stat, "tagged_expr") + stat <- as_tagged_function({{ stat }}, fallback = "Average") + e <- attr(stat, "tagged_expr") + de <- deparse1(e) + if (attr(stat, "is_anonymous_function")) { + de <- paste0("(", de, ")") } - expr(plain((!!e))(italic(y) - italic(y)[rep])) + expr(paste((!!de))(italic(y) - italic(y)[rep])) } diff --git a/R/ppc-scatterplots.R b/R/ppc-scatterplots.R index f0120cbe..d1307c74 100644 --- a/R/ppc-scatterplots.R +++ b/R/ppc-scatterplots.R @@ -129,7 +129,7 @@ ppc_scatter_avg <- alpha = 0.8, ref_line = TRUE) { dots <- list(...) - stat <- as_tagged_function(stat, enexpr(stat)) + stat <- as_tagged_function({{ stat }}) if (!from_grouped(dots)) { check_ignored_arguments(...) @@ -202,7 +202,7 @@ ppc_scatter_avg_data <- function(y, yrep, group = NULL, stat = "mean") { if (!is.null(group)) { group <- validate_group(group, length(y)) } - stat <- as_tagged_function(stat, enexpr(stat)) + stat <- as_tagged_function({{ stat }}) data <- ppc_scatter_data(y = y, yrep = t(apply(yrep, 2, FUN = stat))) data$rep_id <- NA_integer_ @@ -223,13 +223,13 @@ ppc_scatter_avg_data <- function(y, yrep, group = NULL, stat = "mean") { # internal ---------------------------------------------------------------- yrep_avg_label <- function(stat = NULL) { - stat <- as_tagged_function(stat, enexpr(stat), fallback = "Average") - e <- if (attr(stat, "is_anonymous_function")) { - expr("Average") - } else { - attr(stat, "tagged_expr") + stat <- as_tagged_function({{ stat }}, fallback = "Average") + e <- attr(stat, "tagged_expr") + de <- deparse1(e) + if (attr(stat, "is_anonymous_function")) { + de <- paste0("(", de, ")") } - expr(plain((!!e)) (italic(y)[rep])) + expr(paste((!!de))(italic(y)[rep])) } scatter_aes <- function(...) { diff --git a/tests/testthat/test-convenience-functions.R b/tests/testthat/test-convenience-functions.R index 15bd03dd..4777d063 100644 --- a/tests/testthat/test-convenience-functions.R +++ b/tests/testthat/test-convenience-functions.R @@ -210,13 +210,6 @@ test_that("as_tagged_function handles string input", { expect_equal(attr(fn, "tagged_expr"), rlang::sym("mean")) }) -test_that("as_tagged_function handles quoted symbol", { - fn <- as_tagged_function(quote(mean)) - expect_type(fn, "closure") - expect_equal(fn(1:10), mean(1:10)) - expect_equal(attr(fn, "tagged_expr"), quote(mean)) -}) - test_that("as_tagged_function handles anonymous function", { fn <- as_tagged_function(function(x) mean(x^2)) expect_type(fn, "closure") @@ -238,11 +231,11 @@ test_that("as_tagged_function doesn't lose previous tags", { expect_equal(attr(fn2, "tagged_expr"), rlang::expr(mean)) f_outer <- function(stat_outer) { - stat_outer <- as_tagged_function(stat_outer, enexpr(stat_outer)) + stat_outer <- as_tagged_function({{ stat_outer }}) f_inner(stat_outer) } f_inner <- function(stat_inner) { - stat_inner <- as_tagged_function(stat_inner, enexpr(stat_inner)) + stat_inner <- as_tagged_function({{ stat_inner }}) stat_inner } @@ -258,5 +251,7 @@ test_that("as_tagged_function doesn't lose previous tags", { deparse() |> expect_equal("my_function_name") - + # All the non-standard evaluation still provides a callable function + f_outer(my_function_name)(1:10) |> + expect_equal(1:10) }) From 27c17d68ed3be2167a8d59df5dbdba07d5f524d1 Mon Sep 17 00:00:00 2001 From: TJ Mahr Date: Thu, 15 May 2025 15:34:52 -0500 Subject: [PATCH 5/8] use "stat" for anon functions. support formulas --- R/bayesplot-helpers.R | 15 ++++++++------- R/ppc-errors.R | 6 +++--- R/ppc-scatterplots.R | 6 +++--- tests/testthat/test-convenience-functions.R | 7 ++++++- 4 files changed, 20 insertions(+), 14 deletions(-) diff --git a/R/bayesplot-helpers.R b/R/bayesplot-helpers.R index 36eaa3d1..19f23d3d 100644 --- a/R/bayesplot-helpers.R +++ b/R/bayesplot-helpers.R @@ -475,13 +475,13 @@ overlay_function <- function(...) { # 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, and `NULL`. +#' 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, fallback = "func") { +as_tagged_function <- function(f = NULL, fallback = "func") { qf <- enquo(f) f <- eval_tidy(qf) if (!is.null(attr(f, "tagged_expr"))) return(f) @@ -490,17 +490,17 @@ as_tagged_function <- function(f, fallback = "func") { f_fn <- f if (rlang::is_character(f)) { # f = "mean" - # using sym() on the evaluated `f` that a variable that names a + # 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! + # but that seems okay f_expr <- rlang::sym(f) f_fn <- match.fun(f) } else if (is_null(f)) { # f = NULL f_fn <- identity f_expr <- rlang::sym(fallback) } else if (is_callable(f)) { # f = mean or f = function(x) mean(x) - f_expr <- f_expr - f_fn <- f + f_expr <- f_expr # or f = ~mean(.x) + f_fn <- as_function(f) } # Setting attributes on primitive functions is deprecated, so wrap them @@ -512,7 +512,8 @@ as_tagged_function <- function(f, fallback = "func") { } attr(f_fn, "tagged_expr") <- f_expr - attr(f_fn, "is_anonymous_function") <- is_call(f_expr, name = "function") + attr(f_fn, "is_anonymous_function") <- is_call(f_expr, name = "function") || + is_formula(f_expr) f_fn } diff --git a/R/ppc-errors.R b/R/ppc-errors.R index 93db3b24..f7bc1d14 100644 --- a/R/ppc-errors.R +++ b/R/ppc-errors.R @@ -432,12 +432,12 @@ error_label <- function() { } error_avg_label <- function(stat = NULL) { - stat <- as_tagged_function({{ stat }}, fallback = "Average") + stat <- as_tagged_function({{ stat }}, fallback = "stat") e <- attr(stat, "tagged_expr") - de <- deparse1(e) if (attr(stat, "is_anonymous_function")) { - de <- paste0("(", de, ")") + e <- sym("stat") } + de <- deparse1(e) expr(paste((!!de))(italic(y) - italic(y)[rep])) } diff --git a/R/ppc-scatterplots.R b/R/ppc-scatterplots.R index d1307c74..1e350f76 100644 --- a/R/ppc-scatterplots.R +++ b/R/ppc-scatterplots.R @@ -223,12 +223,12 @@ ppc_scatter_avg_data <- function(y, yrep, group = NULL, stat = "mean") { # internal ---------------------------------------------------------------- yrep_avg_label <- function(stat = NULL) { - stat <- as_tagged_function({{ stat }}, fallback = "Average") + stat <- as_tagged_function({{ stat }}, fallback = "stat") e <- attr(stat, "tagged_expr") - de <- deparse1(e) if (attr(stat, "is_anonymous_function")) { - de <- paste0("(", de, ")") + e <- sym("stat") } + de <- deparse1(e) expr(paste((!!de))(italic(y)[rep])) } diff --git a/tests/testthat/test-convenience-functions.R b/tests/testthat/test-convenience-functions.R index 4777d063..068e24a9 100644 --- a/tests/testthat/test-convenience-functions.R +++ b/tests/testthat/test-convenience-functions.R @@ -210,11 +210,16 @@ test_that("as_tagged_function handles string input", { expect_equal(attr(fn, "tagged_expr"), rlang::sym("mean")) }) -test_that("as_tagged_function handles anonymous function", { +test_that("as_tagged_function handles anonymous functions", { fn <- as_tagged_function(function(x) mean(x^2)) expect_type(fn, "closure") expect_equal(fn(1:3), mean((1:3)^2)) expect_equal(attr(fn, "tagged_expr"), rlang::expr( function(x) mean(x^2))) + + fn <- as_tagged_function(~mean(.x^2)) + expect_type(fn, "closure") + expect_equal(fn(1:3), mean((1:3)^2)) + expect_equal(attr(fn, "tagged_expr"), rlang::expr( ~mean(.x^2))) }) test_that("as_tagged_function handles NULL with fallback name", { From 2deeca9da838b53624ceb930fe85c701660aa484 Mon Sep 17 00:00:00 2001 From: TJ Mahr Date: Fri, 16 May 2025 12:06:14 -0500 Subject: [PATCH 6/8] use x expression as axis label --- NEWS.md | 1 + R/ppc-errors.R | 55 ++- R/ppc-scatterplots.R | 2 +- .../ppc-error-scatter-avg-default.svg | 276 +++++------ .../ppc-error-scatter-avg-grouped-default.svg | 450 +++++++++--------- .../ppc-error-scatter-avg-vs-x-default.svg | 274 +++++------ .../ppc-scatter-avg-default.svg | 262 +++++----- .../ppc-scatter-avg-grouped-default.svg | 438 ++++++++--------- ...catter-avg-grouped-size-alpha-ref-line.svg | 430 ++++++++--------- .../ppc-scatter-avg-size-alpha.svg | 262 +++++----- 10 files changed, 1235 insertions(+), 1215 deletions(-) diff --git a/NEWS.md b/NEWS.md index 41b7eac5..592cfb95 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ * 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.12.0 diff --git a/R/ppc-errors.R b/R/ppc-errors.R index f7bc1d14..5e4dfc8f 100644 --- a/R/ppc-errors.R +++ b/R/ppc-errors.R @@ -273,32 +273,37 @@ ppc_error_scatter_avg_grouped <- #' @param x A numeric vector the same length as `y` to use as the x-axis #' variable. #' -ppc_error_scatter_avg_vs_x <- - function(y, - yrep, - x, - ..., - stat = "mean", - size = 2.5, - alpha = 0.8) { - check_ignored_arguments(...) +ppc_error_scatter_avg_vs_x <- function( + y, + yrep, + x, + ..., + stat = "mean", + size = 2.5, + alpha = 0.8 +) { + check_ignored_arguments(...) - y <- validate_y(y) - yrep <- validate_predictions(yrep, length(y)) - x <- validate_x(x, y) - stat <- as_tagged_function({{ stat }}) - errors <- compute_errors(y, yrep) - ppc_scatter_avg( - y = x, - yrep = errors, - size = size, - alpha = alpha, - ref_line = FALSE, - stat = stat + y <- validate_y(y) + yrep <- validate_predictions(yrep, length(y)) + qx <- enquo(x) + x <- validate_x(x, y) + stat <- as_tagged_function({{ stat }}) + errors <- compute_errors(y, yrep) + ppc_scatter_avg( + y = x, + yrep = errors, + size = size, + alpha = alpha, + ref_line = FALSE, + stat = stat + ) + + labs( + x = error_avg_label(stat), + y = as_label((qx)) ) + - labs(x = error_avg_label(stat), y = expression(italic(x))) + - coord_flip() - } + coord_flip() +} #' @rdname PPC-errors @@ -438,7 +443,7 @@ error_avg_label <- function(stat = NULL) { e <- sym("stat") } de <- deparse1(e) - expr(paste((!!de))(italic(y) - italic(y)[rep])) + expr(paste((!!de))*(italic(y) - italic(y)[rep])) } diff --git a/R/ppc-scatterplots.R b/R/ppc-scatterplots.R index 1e350f76..1db7fb5f 100644 --- a/R/ppc-scatterplots.R +++ b/R/ppc-scatterplots.R @@ -229,7 +229,7 @@ yrep_avg_label <- function(stat = NULL) { e <- sym("stat") } de <- deparse1(e) - expr(paste((!!de))(italic(y)[rep])) + expr(paste((!!de))*(italic(y)[rep])) } scatter_aes <- function(...) { diff --git a/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-default.svg b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-default.svg index 445e86d6..516b7bdb 100644 --- a/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-default.svg +++ b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-default.svg @@ -20,147 +20,149 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - --2 --1 -0 -1 -2 -3 - - - - - - - - - - - - - --2 --1 -0 -1 -2 -3 -Average -y -− -y -r -e -p -y + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 +3 +mean +( +y +− +y +r +e +p +) +y ppc_error_scatter_avg (default) diff --git a/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-grouped-default.svg b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-grouped-default.svg index 6eb818c0..306ec994 100644 --- a/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-grouped-default.svg +++ b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-grouped-default.svg @@ -20,166 +20,166 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - -C + +C - - + + - -D + +D @@ -202,102 +202,104 @@ B - - - - - - --2 --1 -0 -1 -2 - - - - - --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - - - --2 --1 -0 -1 -2 -3 - --2 --1 -0 -1 -2 -3 - - - - - - - --1 -0 -1 -2 - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - -Average -y -− -y -r -e -p -y + + + + + + +-2 +-1 +0 +1 +2 + + + + + +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + +-2 +-1 +0 +1 +2 +3 + +-2 +-1 +0 +1 +2 +3 + + + + + + + +-1 +0 +1 +2 + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +mean +( +y +− +y +r +e +p +) +y ppc_error_scatter_avg_grouped (default) diff --git a/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-vs-x-default.svg b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-vs-x-default.svg index 8adb4a27..a3d03288 100644 --- a/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-vs-x-default.svg +++ b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-vs-x-default.svg @@ -20,145 +20,147 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - --2 --1 -0 -1 -2 -3 - - - - - - - - - - - - -0 -25 -50 -75 -100 -x -Average -y -− -y -r -e -p -ppc_error_scatter_avg_vs_x (default) + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + + + +0 +25 +50 +75 +100 +seq_along(vdiff_y) +mean +( +y +− +y +r +e +p +) +ppc_error_scatter_avg_vs_x (default) diff --git a/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-default.svg b/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-default.svg index 67f900cb..0596082a 100644 --- a/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-default.svg +++ b/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-default.svg @@ -20,140 +20,142 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - --2 --1 -0 -1 -2 -3 - - - - - - - - - - --0.25 -0.00 -0.25 -Average -y -r -e -p -y + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + +-0.25 +0.00 +0.25 +mean +( +y +r +e +p +) +y ppc_scatter_avg (default) diff --git a/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-default.svg b/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-default.svg index ef927ddb..f613d159 100644 --- a/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-default.svg +++ b/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-default.svg @@ -20,170 +20,170 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - -C + +C - - + + - -D + +D @@ -206,92 +206,94 @@ B - - - - - --0.4 --0.2 -0.0 -0.2 - - - - - --0.2 -0.0 -0.2 -0.4 - - - - --0.25 -0.00 -0.25 - - - - - - --0.4 --0.2 -0.0 -0.2 -0.4 - --2 --1 -0 -1 -2 -3 - - - - - - - --1 -0 -1 -2 - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - -Average -y -r -e -p -y + + + + + +-0.4 +-0.2 +0.0 +0.2 + + + + + +-0.2 +0.0 +0.2 +0.4 + + + + +-0.25 +0.00 +0.25 + + + + + + +-0.4 +-0.2 +0.0 +0.2 +0.4 + +-2 +-1 +0 +1 +2 +3 + + + + + + + +-1 +0 +1 +2 + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +mean +( +y +r +e +p +) +y ppc_scatter_avg_grouped (default) diff --git a/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-size-alpha-ref-line.svg b/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-size-alpha-ref-line.svg index 9e142966..86af1d39 100644 --- a/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-size-alpha-ref-line.svg +++ b/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-size-alpha-ref-line.svg @@ -20,166 +20,166 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - -C + +C - - + + - -D + +D @@ -202,92 +202,94 @@ B - - - - - --0.4 --0.2 -0.0 -0.2 - - - - - --0.2 -0.0 -0.2 -0.4 - - - - --0.25 -0.00 -0.25 - - - - - - --0.4 --0.2 -0.0 -0.2 -0.4 - --2 --1 -0 -1 -2 -3 - - - - - - - --1 -0 -1 -2 - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - -Average -y -r -e -p -y + + + + + +-0.4 +-0.2 +0.0 +0.2 + + + + + +-0.2 +0.0 +0.2 +0.4 + + + + +-0.25 +0.00 +0.25 + + + + + + +-0.4 +-0.2 +0.0 +0.2 +0.4 + +-2 +-1 +0 +1 +2 +3 + + + + + + + +-1 +0 +1 +2 + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +mean +( +y +r +e +p +) +y ppc_scatter_avg_grouped (size, alpha, ref_line) diff --git a/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-size-alpha.svg b/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-size-alpha.svg index 3bc59a66..743c0dae 100644 --- a/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-size-alpha.svg +++ b/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-size-alpha.svg @@ -20,140 +20,142 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - --2 --1 -0 -1 -2 -3 - - - - - - - - - - --0.25 -0.00 -0.25 -Average -y -r -e -p -y + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + +-0.25 +0.00 +0.25 +mean +( +y +r +e +p +) +y ppc_scatter_avg (size, alpha) From 1acd544349e531771fe53531bb93af6c46c1fb59 Mon Sep 17 00:00:00 2001 From: TJ Mahr Date: Fri, 16 May 2025 12:15:22 -0500 Subject: [PATCH 7/8] bump r version to support native pipe (added 2021) --- DESCRIPTION | 4 ++-- man/bayesplot-package.Rd | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6a5d18ae..d0e07053 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -4,7 +4,7 @@ Title: Plotting for Bayesian Models Version: 1.12.0.9000 Date: 2025-04-09 Authors@R: c(person("Jonah", "Gabry", role = c("aut", "cre"), email = "jsg2201@columbia.edu"), - 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), diff --git a/man/bayesplot-package.Rd b/man/bayesplot-package.Rd index 9da7e946..f7404672 100644 --- a/man/bayesplot-package.Rd +++ b/man/bayesplot-package.Rd @@ -119,7 +119,7 @@ for plotting. Authors: \itemize{ - \item Tristan Mahr + \item Tristan Mahr (\href{https://orcid.org/0000-0002-8890-5116}{ORCID}) } Other contributors: From 4293eb89ec53dd696f9638ed828599bfb7d29d76 Mon Sep 17 00:00:00 2001 From: TJ Mahr Date: Fri, 16 May 2025 12:22:39 -0500 Subject: [PATCH 8/8] - fixed roxygen warning - avoid global for y, italic --- R/bayesplot-package.R | 3 +-- R/ppc-errors.R | 3 +++ R/ppc-scatterplots.R | 3 +++ 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/R/bayesplot-package.R b/R/bayesplot-package.R index 1b0f0817..a2d4531d 100644 --- a/R/bayesplot-package.R +++ b/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 ---------------------------------------------------------------- diff --git a/R/ppc-errors.R b/R/ppc-errors.R index 5e4dfc8f..911cb009 100644 --- a/R/ppc-errors.R +++ b/R/ppc-errors.R @@ -443,6 +443,9 @@ error_avg_label <- function(stat = NULL) { e <- sym("stat") } de <- deparse1(e) + # dummy globals to pass R check for globals + italic <- sym("italic") + y <- sym("y") expr(paste((!!de))*(italic(y) - italic(y)[rep])) } diff --git a/R/ppc-scatterplots.R b/R/ppc-scatterplots.R index 1db7fb5f..ed10c1d1 100644 --- a/R/ppc-scatterplots.R +++ b/R/ppc-scatterplots.R @@ -229,6 +229,9 @@ yrep_avg_label <- function(stat = NULL) { e <- sym("stat") } de <- deparse1(e) + # dummy globals to pass R check for globals + italic <- sym("italic") + y <- sym("y") expr(paste((!!de))*(italic(y)[rep])) }