diff --git a/DESCRIPTION b/DESCRIPTION index 8181d1f0..6706fea1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -4,7 +4,7 @@ Title: Plotting for Bayesian Models Version: 1.13.0.9000 Date: 2025-06-18 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/NEWS.md b/NEWS.md index 95ea6ab7..4f30cd1a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # bayesplot (development version) +* 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) diff --git a/R/bayesplot-helpers.R b/R/bayesplot-helpers.R index 573835aa..d3d86ec3 100644 --- a/R/bayesplot-helpers.R +++ b/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 +} + + + 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 510e95f9..d038aa70 100644 --- a/R/ppc-errors.R +++ b/R/ppc-errors.R @@ -10,6 +10,10 @@ #' @template args-group #' @template args-facet_args #' @param ... Currently unused. +#' @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 @@ -209,6 +213,7 @@ ppc_error_scatter_avg <- function(y, yrep, ..., + stat = "mean", size = 2.5, alpha = 0.8) { check_ignored_arguments(...) @@ -216,14 +221,18 @@ ppc_error_scatter_avg <- y <- validate_y(y) yrep <- validate_predictions(yrep, length(y)) errors <- compute_errors(y, yrep) + + stat <- as_tagged_function({{ stat }}) + ppc_scatter_avg( y = y, yrep = errors, size = size, alpha = alpha, - ref_line = FALSE + ref_line = FALSE, + stat = stat ) + - labs(x = error_avg_label(), y = y_label()) + labs(x = error_avg_label(stat), y = y_label()) } @@ -234,6 +243,7 @@ ppc_error_scatter_avg_grouped <- yrep, group, ..., + stat = "mean", facet_args = list(), size = 2.5, alpha = 0.8) { @@ -241,6 +251,8 @@ ppc_error_scatter_avg_grouped <- y <- validate_y(y) yrep <- validate_predictions(yrep, length(y)) + stat <- as_tagged_function({{ stat }}) + errors <- compute_errors(y, yrep) ppc_scatter_avg_grouped( y = y, @@ -249,9 +261,10 @@ ppc_error_scatter_avg_grouped <- size = size, alpha = alpha, facet_args = facet_args, - ref_line = FALSE + ref_line = FALSE, + stat = stat ) + - labs(x = error_avg_label(), y = y_label()) + labs(x = error_avg_label(stat), y = y_label()) } @@ -260,29 +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, - ..., - 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) - errors <- compute_errors(y, yrep) - ppc_scatter_avg( - y = x, - yrep = errors, - size = size, - alpha = alpha, - ref_line = FALSE + 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(), y = expression(italic(x))) + - coord_flip() - } + coord_flip() +} #' @rdname PPC-errors @@ -414,8 +435,21 @@ 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 }}, fallback = "stat") + e <- attr(stat, "tagged_expr") + if (attr(stat, "is_anonymous_function")) { + e <- sym("stat") + } + de <- deparse1(e) + + # create some dummy variables to pass the R package check for + # global variables in the expression below + 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 dd16620d..50802f82 100644 --- a/R/ppc-scatterplots.R +++ b/R/ppc-scatterplots.R @@ -11,6 +11,11 @@ #' @template args-group #' @template args-facet_args #' @param ... Currently unused. +#' @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 @@ -31,10 +36,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 a 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 +64,9 @@ #' p1 + lims #' p2 + lims #' +#' # "average" function is customizable +#' 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 #' group <- example_group_data() @@ -116,16 +124,19 @@ ppc_scatter_avg <- function(y, yrep, ..., + stat = "mean", size = 2.5, alpha = 0.8, ref_line = TRUE) { dots <- list(...) + stat <- as_tagged_function({{ stat }}) + if (!from_grouped(dots)) { check_ignored_arguments(...) dots$group <- NULL } - data <- ppc_scatter_avg_data(y, yrep, group = dots$group) + 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." @@ -143,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() } @@ -155,6 +166,7 @@ ppc_scatter_avg_grouped <- yrep, group, ..., + stat = "mean", facet_args = list(), size = 2.5, alpha = 0.8, @@ -184,16 +196,19 @@ 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, 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 }}) - data <- ppc_scatter_data(y = y, yrep = t(colMeans(yrep))) + data <- ppc_scatter_data(y = y, yrep = t(apply(yrep, 2, FUN = stat))) data$rep_id <- NA_integer_ - levels(data$rep_label) <- "mean(italic(y)[rep]))" + levels(data$rep_label) <- yrep_avg_label(stat) |> + as.expression() |> + as.character() if (!is.null(group)) { data <- tibble::add_column(data, @@ -206,7 +221,22 @@ ppc_scatter_avg_data <- function(y, yrep, group = NULL) { } # internal ---------------------------------------------------------------- -yrep_avg_label <- function() expression(paste("Average ", italic(y)[rep])) + +yrep_avg_label <- function(stat = NULL) { + stat <- as_tagged_function({{ stat }}, fallback = "stat") + e <- attr(stat, "tagged_expr") + if (attr(stat, "is_anonymous_function")) { + e <- sym("stat") + } + de <- deparse1(e) + + # create some dummy variables to pass the R package check for + # global variables in the expression below + italic <- sym("italic") + y <- sym("y") + + expr(paste((!!de))*(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 88610f8b..047590bf 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, ..., stat = "mean", size = 2.5, alpha = 0.8) ppc_error_scatter_avg_grouped( y, yrep, group, ..., + stat = "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, + ..., + stat = "mean", + size = 2.5, + alpha = 0.8 +) ppc_error_binned( y, @@ -106,6 +115,11 @@ 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{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 variable.} } diff --git a/man/PPC-scatterplots.Rd b/man/PPC-scatterplots.Rd index 64963c40..2c22bbd3 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, + ..., + stat = "mean", + size = 2.5, + alpha = 0.8, + ref_line = TRUE +) ppc_scatter_avg_grouped( y, yrep, group, ..., + stat = "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, stat = "mean") } \arguments{ \item{y}{A vector of observations. See \strong{Details}.} @@ -61,6 +70,12 @@ 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{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. Each value in \code{group} is interpreted as the group level pertaining @@ -92,10 +107,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 a 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 +136,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, stat = "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() 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: 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) diff --git a/tests/testthat/test-convenience-functions.R b/tests/testthat/test-convenience-functions.R index 7389973e..068e24a9 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 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", { + 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 }}) + f_inner(stat_outer) + } + f_inner <- function(stat_inner) { + stat_inner <- as_tagged_function({{ 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") + + # All the non-standard evaluation still provides a callable function + f_outer(my_function_name)(1:10) |> + expect_equal(1:10) +}) 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 ------------------------------------------------------------