diff --git a/.Rbuildignore b/.Rbuildignore index 66b11a74..d7d87c03 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,5 +13,5 @@ images/* book/* docs/* Rplots.pdf -tests/figs/* ^\.github$ +^tests/testthat/_snaps$ diff --git a/DESCRIPTION b/DESCRIPTION index 14b41152..345e2021 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,18 +7,18 @@ Authors@R: c(person("Jonah", "Gabry", role = c("aut", "cre"), email = "jsg2201@c person("Tristan", "Mahr", role = "aut"), person("Paul-Christian", "Bürkner", role = "ctb"), person("Martin", "Modrák", role = "ctb"), - person("Malcolm", "Barrett", role = "ctb"), + person("Malcolm", "Barrett", role = "ctb"), person("Frank", "Weber", role = "ctb"), person("Eduardo", "Coronado Sroka", role = "ctb"), person("Aki", "Vehtari", role = "ctb")) Maintainer: Jonah Gabry Description: Plotting functions for posterior analysis, MCMC diagnostics, - prior and posterior predictive checks, and other visualizations + prior and posterior predictive checks, and other visualizations to support the applied Bayesian workflow advocated in Gabry, Simpson, Vehtari, Betancourt, and Gelman (2019) . - The package is designed not only to provide convenient functionality - for users, but also a common set of functions that can be easily used by - developers working on a variety of R packages for Bayesian modeling, + The package is designed not only to provide convenient functionality + for users, but also a common set of functions that can be easily used by + developers working on a variety of R packages for Bayesian modeling, particularly (but not exclusively) packages interfacing with 'Stan'. License: GPL (>= 3) URL: https://mc-stan.org/bayesplot/ @@ -35,10 +35,10 @@ Imports: reshape2, rlang (>= 0.3.0), stats, - tibble, + tibble (>= 2.0.0), tidyselect, utils -Suggests: +Suggests: ggfortify, gridExtra (>= 2.2.1), hexbin, @@ -53,7 +53,7 @@ Suggests: shinystan (>= 2.3.0), survival, testthat (>= 2.0.0), - vdiffr + vdiffr (>= 1.0.2) RoxygenNote: 7.1.2 VignetteBuilder: knitr Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index c6f52b31..1717dd56 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,6 +24,7 @@ S3method(rhat,stanreg) export(abline_01) export(available_mcmc) export(available_ppc) +export(available_ppd) export(bayesplot_grid) export(bayesplot_theme_get) export(bayesplot_theme_replace) @@ -99,6 +100,7 @@ export(parcoord_style_np) export(plot_bg) export(pp_check) export(ppc_bars) +export(ppc_bars_data) export(ppc_bars_grouped) export(ppc_boxplot) export(ppc_data) @@ -108,10 +110,12 @@ export(ppc_dens_overlay_grouped) export(ppc_ecdf_overlay) export(ppc_ecdf_overlay_grouped) export(ppc_error_binned) +export(ppc_error_data) export(ppc_error_hist) export(ppc_error_hist_grouped) export(ppc_error_scatter) export(ppc_error_scatter_avg) +export(ppc_error_scatter_avg_grouped) export(ppc_error_scatter_avg_vs_x) export(ppc_freqpoly) export(ppc_freqpoly_grouped) @@ -133,12 +137,36 @@ export(ppc_ribbon_grouped) export(ppc_rootogram) export(ppc_scatter) export(ppc_scatter_avg) +export(ppc_scatter_avg_data) export(ppc_scatter_avg_grouped) +export(ppc_scatter_data) export(ppc_stat) export(ppc_stat_2d) +export(ppc_stat_data) +export(ppc_stat_freqpoly) export(ppc_stat_freqpoly_grouped) export(ppc_stat_grouped) export(ppc_violin_grouped) +export(ppd_boxplot) +export(ppd_data) +export(ppd_dens) +export(ppd_dens_overlay) +export(ppd_ecdf_overlay) +export(ppd_freqpoly) +export(ppd_freqpoly_grouped) +export(ppd_hist) +export(ppd_intervals) +export(ppd_intervals_data) +export(ppd_intervals_grouped) +export(ppd_ribbon) +export(ppd_ribbon_data) +export(ppd_ribbon_grouped) +export(ppd_stat) +export(ppd_stat_2d) +export(ppd_stat_data) +export(ppd_stat_freqpoly) +export(ppd_stat_freqpoly_grouped) +export(ppd_stat_grouped) export(rhat) export(scatter_style_np) export(theme_default) @@ -156,8 +184,10 @@ import(ggplot2) import(rlang) import(stats) importFrom(dplyr,"%>%") +importFrom(dplyr,across) importFrom(dplyr,arrange) importFrom(dplyr,count) +importFrom(dplyr,full_join) importFrom(dplyr,group_by) importFrom(dplyr,inner_join) importFrom(dplyr,left_join) diff --git a/NEWS.md b/NEWS.md index d6d21214..0ca43d5f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,42 @@ # bayesplot 1.8.1.9000 +* New module PPD (posterior/prior predictive distribution) with a lot of new +plotting functions with `ppd_` prefix. These functions plot draws from the prior +or posterior predictive distributions (PPD) without comparing to observed data +(i.e., no `y` argument). Because these are not "checks" against the observed +data we use PPD instead of PPC. These plots are essentially the same as the +corresponding PPC plots but without showing any observed data (e.g., +`ppd_intervals()` is like `ppc_intervals()` but without plotting `y`). See +`help("PPD-overview")` for details. (#151, #222) + +* All PPC categories now have one or more `_data()` functions that return the +data frame used for plotting (#97, #222). Many of these have already been in +previous releases, but the new ones in this release are: + - `ppc_bars_data()` + - `ppc_error_data()` + - `ppc_error_binnned_data()` + - `ppc_scatter_data()` + - `ppc_scatter_avg_data()` + - `ppc_stat_data()` + +* Many functions gain an argument `facet_args` for controlling ggplot2 faceting + (many other functions have had this argument for a long time). + The ones that just now got the argument are: + - `ppc_scatter()` + - `ppc_scatter_avg_grouped()` + - `ppc_error_hist()` + - `ppc_error_hist_grouped()` + - `ppc_error_scatter()` + - `ppc_error_binned()` + +* New plotting function `ppc_km_overlay_grouped()`, the grouped variant of + `ppc_km_overlay()`. (#260, @fweber144) + +* `ppc_scatter()`, `ppc_scatter_avg()`, and `ppc_scatter_avg_grouped()` gain an + argument `ref_line`, which can be set to `FALSE` to turn off the `x=y` line + drawn behind the scatterplot. + * `mcmc_*()` functions now support all draws formats from the **posterior** package. (#277, @Ozan147) * `mcmc_dens()` and `mcmc_dens_overlay()` gain arguments for controlling the @@ -12,9 +48,6 @@ * `mcmc_areas()` and `mcmc_areas_ridges()` gain an argument `border_size` for controlling the thickness of the ridgelines. (#224) -* New plotting function `ppc_km_overlay_grouped()`, the grouped variant of - `ppc_km_overlay()`. (#260, @fweber144) - # bayesplot 1.8.1 * Fix R cmd check error on linux for CRAN diff --git a/R/available-module-functions.R b/R/available-module-functions.R index 8bd88ed1..cd1400ea 100644 --- a/R/available-module-functions.R +++ b/R/available-module-functions.R @@ -1,11 +1,14 @@ -#' Get or view the names of available plotting functions +#' Get or view the names of available plotting or data functions #' #' @export #' @param pattern,fixed,invert Passed to [base::grep()]. +#' @param plots_only If `TRUE` (the default) only plotting functions are +#' searched for. If `FALSE` then functions that return data for plotting +#' (functions ending in `_data()`) are also included. #' @return A possibly empty character vector of function names with several #' additional attributes (for use by a custom print method). If `pattern` #' is missing then the returned object contains the names of all available -#' plotting functions in the [MCMC] or [PPC] module, depending on +#' plotting functions in the [MCMC], [PPC], or [PPD] module, depending on #' which function is called. If `pattern` is specified then a subset of #' function names is returned. #' @@ -13,24 +16,67 @@ #' available_mcmc() #' available_mcmc("nuts") #' available_mcmc("rhat|neff") +#' +#' available_ppc() #' available_ppc("grouped") #' available_ppc("grouped", invert = TRUE) #' -available_ppc <- function(pattern = NULL, fixed = FALSE, invert = FALSE) { - .list_module_functions("ppc", - .pattern = pattern, - fixed = fixed, - invert = invert) -} +#' available_ppd() +#' available_ppd("grouped") +#' +#' # can also see which functions that return data are available +#' available_ppc(plots_only = FALSE) +#' +#' # only show the _data functions +#' available_ppc("_data", plots_only = FALSE) +#' available_ppd("_data", plots_only = FALSE) +#' available_mcmc("_data", plots_only = FALSE) +#' +available_ppc <- + function(pattern = NULL, + fixed = FALSE, + invert = FALSE, + plots_only = TRUE) { + .list_module_functions( + .module = "ppc", + .pattern = pattern, + fixed = fixed, + invert = invert, + plots_only = plots_only + ) + } #' @rdname available_ppc #' @export -available_mcmc <- function(pattern = NULL, fixed = FALSE, invert = FALSE) { - .list_module_functions("mcmc", - .pattern = pattern, - fixed = fixed, - invert = invert) -} +available_ppd <- + function(pattern = NULL, + fixed = FALSE, + invert = FALSE, + plots_only = TRUE) { + .list_module_functions( + .module = "ppd", + .pattern = pattern, + fixed = fixed, + invert = invert, + plots_only = plots_only + ) + } + +#' @rdname available_ppc +#' @export +available_mcmc <- + function(pattern = NULL, + fixed = FALSE, + invert = FALSE, + plots_only = TRUE) { + .list_module_functions( + .module = "mcmc", + .pattern = pattern, + fixed = fixed, + invert = invert, + plots_only = plots_only + ) + } #' @export print.bayesplot_function_list <- function(x, ...) { @@ -48,10 +94,11 @@ print.bayesplot_function_list <- function(x, ...) { # internal ---------------------------------------------------------------- .list_module_functions <- - function(.module = c("ppc", "mcmc"), + function(.module = c("ppc", "ppd", "mcmc"), .pattern, fixed = FALSE, - invert = FALSE) { + invert = FALSE, + plots_only = TRUE) { .module <- match.arg(.module) @@ -62,6 +109,17 @@ print.bayesplot_function_list <- function(x, ...) { ) return_funs <- sort(all_funs) + if (plots_only) { + # drop _data() functions + return_funs <- + grep( + pattern = "_data()", + x = return_funs, + invert = TRUE, + value = TRUE + ) + } + if (!is.null(.pattern)) { return_funs <- grep( pattern = .pattern, @@ -71,6 +129,7 @@ print.bayesplot_function_list <- function(x, ...) { invert = invert ) } + structure( return_funs, class = c("bayesplot_function_list", "character"), diff --git a/R/bayesplot-colors.R b/R/bayesplot-colors.R index de06df9e..23b98d62 100644 --- a/R/bayesplot-colors.R +++ b/R/bayesplot-colors.R @@ -203,8 +203,11 @@ plot.bayesplot_scheme <- function(x, ...) { # internal ----------------------------------------------------------------- -# plot color scheme -# @param scheme A string (length 1) naming a scheme +#' Plot color scheme +#' @noRd +#' @param scheme A string (length 1) naming a scheme. If `NULL` the current +#' scheme is used. +#' @return A ggplot object. plot_scheme <- function(scheme = NULL) { if (is.null(scheme)) { x <- color_scheme_get() @@ -248,9 +251,8 @@ scheme_level_names <- function() { } #' Return a color scheme based on `scheme` argument specified as a string -#' #' @noRd -#' @param scheme A string (length 1) naming a scheme +#' @param scheme A string (length 1) naming a scheme. scheme_from_string <- function(scheme) { if (identical(substr(scheme, 1, 4), "mix-")) { # user specified a mixed scheme (e.g., "mix-blue-red") @@ -300,8 +302,8 @@ is_mixed_scheme <- function(x) { #' Access a subset of the current scheme colors #' @noRd -#' @param level A character vector of level names in `scheme_level_names()`. -#' The abbreviations "l", "lh", "m", "mh", "d", and "dh" can also be used +#' @param levels A character vector of level names in `scheme_level_names()`. +#' The abbreviations `"l", "lh", "m", "mh", "d", "dh"` can also be used #' instead of the full names. #' @return A character vector of color values. #' diff --git a/R/bayesplot-ggplot-themes.R b/R/bayesplot-ggplot-themes.R index c8144c3e..59d268f1 100644 --- a/R/bayesplot-ggplot-themes.R +++ b/R/bayesplot-ggplot-themes.R @@ -129,6 +129,9 @@ theme_default <- #' bayesplot_theme_set(theme_dark()) #' mcmc_hist(x) + panel_bg(fill = "black") #' +#' # reset +#' bayesplot_theme_set() +#' bayesplot_theme_get <- function() { if (!identical(.bayesplot_theme_env$gg_current, ggplot2::theme_get())) { .bayesplot_theme_env$current <- ggplot2::theme_get() diff --git a/R/bayesplot-package.R b/R/bayesplot-package.R index 999bb27e..c78a3896 100644 --- a/R/bayesplot-package.R +++ b/R/bayesplot-package.R @@ -9,7 +9,7 @@ #' #' @description #' \if{html}{ -#' \figure{stanlogo.png}{options: width="50px" alt="mc-stan.org"} +#' \figure{stanlogo.png}{options: width="50" alt="mc-stan.org"} #' } #' *Stan Development Team* #' @@ -36,11 +36,10 @@ #' Monte Carlo (MCMC) simulations generated by *any* MCMC algorithm #' as well as diagnostics. There are also additional functions specifically #' for use with models fit using the [No-U-Turn Sampler (NUTS)][NUTS]. -#' * [PPC][PPC-overview]: Graphical prior and posterior predictive +#' * [PPC][PPC-overview]: Graphical (posterior or prior) predictive #' checks (PPCs). -#' -#' In future releases modules will be added specifically for -#' forecasting/out-of-sample prediction and other inference-related tasks. +#' * [PPD][PPD-overview]: Plots of (posterior or prior) predictive +#' distributions without comparisons to observed data. #' #' @section Resources: #' * __Online documentation and vignettes__: Visit the __bayesplot__ website at @@ -88,6 +87,13 @@ #' color_scheme_set("pink") #' ppc_stat(y, yrep, stat = "median") + grid_lines() #' ppc_hist(y, yrep[1:8, ]) +#' +#' # Same plots but without y (using ppd_ instead of ppc_) +#' bayesplot_theme_set(ggplot2::theme_gray()) +#' ypred <- yrep +#' ppd_dens_overlay(ypred[1:50, ]) +#' ppd_stat(ypred, stat = "median") + grid_lines() +#' ppd_hist(ypred[1:8, ]) #' } #' NULL diff --git a/R/helpers-gg.R b/R/helpers-gg.R index b922ba4a..6bd0a585 100644 --- a/R/helpers-gg.R +++ b/R/helpers-gg.R @@ -103,3 +103,51 @@ set_hist_aes <- function(freq = TRUE, ...) { aes_(x = ~ value, y = ~ stat(density), ...) } } + +scale_color_ppc <- + function(name = NULL, + values = NULL, + labels = NULL, + ...) { + scale_color_manual( + name = name %||% "", + values = values %||% get_color(c("dh", "lh")), + labels = labels %||% c(y_label(), yrep_label()), + ... + ) + } + +scale_fill_ppc <- + function(name = NULL, + values = NULL, + labels = NULL, + ...) { + scale_fill_manual( + name = name %||% "", + values = values %||% get_color(c("d", "l")), + labels = labels %||% c(y_label(), yrep_label()), + ... + ) + } + +scale_color_ppd <- + function(name = NULL, + values = get_color("mh"), + labels = ypred_label(), + ...) { + scale_color_ppc(name = name, + values = values, + labels = labels, + ...) + } + +scale_fill_ppd <- + function(name = NULL, + values = get_color("m"), + labels = ypred_label(), + ...) { + scale_fill_ppc(name = name, + values = values, + labels = labels, + ...) + } diff --git a/R/helpers-ppc.R b/R/helpers-ppc.R index 1f8ee245..71c63e0e 100644 --- a/R/helpers-ppc.R +++ b/R/helpers-ppc.R @@ -1,3 +1,5 @@ +# input validation and type checking ---------------------------------------- + # Check if an object is a vector (but not list) or a 1-D array is_vector_or_1Darray <- function(x) { if (is.vector(x) && !is.list(x)) { @@ -7,6 +9,25 @@ is_vector_or_1Darray <- function(x) { isTRUE(is.array(x) && length(dim(x)) == 1) } +# Check if x consists of whole numbers (very close to integers) +# Implementation here follows example ?integer +is_whole_number <- function(x, tol = .Machine$double.eps) { + if (!is.numeric(x)) { + FALSE + } else { + abs(x - round(x)) < tol + } +} + +# Check if all values in x are whole numbers or counts (non-negative whole +# numbers) +all_whole_number <- function(x, ...) { + all(is_whole_number(x, ...)) +} +all_counts <- function(x, ...) { + all_whole_number(x, ...) && min(x) >= 0 +} + #' Validate y #' @@ -34,48 +55,64 @@ validate_y <- function(y) { } -#' Validate yrep +#' Validate predictions (`yrep` or `ypred`) #' -#' Checks that `yrep` is a numeric matrix, doesn't have any NAs, and has the -#' correct number of columns (equal to the length of `y`). +#' Checks that `predictions` is a numeric matrix, doesn't have any NAs, and has +#' the correct number of columns. #' -#' @param yrep,y The user's `yrep` object and the `y` object returned by `validate_y()`. +#' @param predictions The user's `yrep` or `ypred` object (SxN matrix). +#' @param `n_obs` The number of observations (columns) that `predictions` should +#' have, if applicable. #' @return Either throws an error or returns a numeric matrix. #' @noRd -validate_yrep <- function(yrep, y) { - stopifnot(is.matrix(yrep), is.numeric(yrep)) - if (is.integer(yrep)) { - if (nrow(yrep) == 1) { - yrep[1, ] <- as.numeric(yrep[1,, drop = FALSE]) +validate_predictions <- function(predictions, n_obs = NULL) { + # sanity checks + stopifnot(is.matrix(predictions), is.numeric(predictions)) + if (!is.null(n_obs)) { + stopifnot(length(n_obs) == 1, n_obs == as.integer(n_obs)) + } + + if (is.integer(predictions)) { + if (nrow(predictions) == 1) { + predictions[1, ] <- as.numeric(predictions[1,, drop = FALSE]) } else { - yrep <- apply(yrep, 2, as.numeric) + predictions <- apply(predictions, 2, as.numeric) } } - if (anyNA(yrep)) { - abort("NAs not allowed in 'yrep'.") + if (anyNA(predictions)) { + abort("NAs not allowed in predictions.") } - if (ncol(yrep) != length(y)) { + if (!is.null(n_obs) && (ncol(predictions) != n_obs)) { abort("ncol(yrep) must be equal to length(y).") } - unclass(unname(yrep)) + # get rid of names but keep them as an attribute in case we want them + obs_names <- colnames(predictions) + predictions <- unclass(unname(predictions)) + attr(predictions, "obs_names") <- obs_names + + predictions } #' Validate group #' -#' Checks that grouping variable has same length as `y` and is either a vector or -#' factor variable. +#' Checks that grouping variable has correct number of observations and is +#' either a factor variable or vector (which is coerced to factor). #' -#' @param group,y The user's `group` object and the `y` object returned by -#' `validate_y()`. +#' @param group The user's `group` argument. +#' @param n_obs The number of observations that `group` should contain (e.g., +#' `length(y)`, `ncol(yrepd)`, etc.). Unlike for `validate_predictions()`, +#' this is always required for `validate_group()`. #' @return Either throws an error or returns `group` (coerced to a factor). #' @noRd -validate_group <- function(group, y) { - stopifnot(is.vector(group) || is.factor(group)) +validate_group <- function(group, n_obs) { + # sanity checks + stopifnot(is.vector(group) || is.factor(group), + length(n_obs) == 1, n_obs == as.integer(n_obs)) if (!is.factor(group)) { group <- as.factor(group) @@ -85,8 +122,8 @@ validate_group <- function(group, y) { abort("NAs not allowed in 'group'.") } - if (length(group) != length(y)) { - abort("length(group) must be equal to length(y).") + if (length(group) != n_obs) { + abort("length(group) must be equal to the number of observations.") } unname(group) @@ -135,136 +172,103 @@ validate_x <- function(x = NULL, y, unique_x = FALSE) { } -#' Convert yrep matrix into a molten data frame +# Internals for grouped plots --------------------------------------------- + +#' Modify a call to a `_grouped` function to a call to the ungrouped version +#' @param fn The new function to call (a string). +#' @param call The original call (from `match.call(expand.dots = FALSE)`). +#' @return The new unevaluated call, with additional argument +#' `called_from_internal=TRUE` which can be detected by the function to be +#' called so it knows not to warn about the `group` and `facet_args` arguments. +#' @noRd +ungroup_call <- function(fn, call) { + args <- rlang::call_args(call) + args$called_from_internal <- TRUE + args[["..."]] <- NULL + rlang::call2(.fn = fn, !!!args, .ns = "bayesplot") +} + +#' Check if the `...` to a plotting function was passed from it's `_grouped` version +#' @param dots The `...` arguments already in a list, i.e., `list(...)`. +#' @return `TRUE` or `FALSE` +#' @noRd +from_grouped <- function(dots) { + isTRUE(dots[["called_from_internal"]]) && !is.null(dots[["group"]]) +} + + + +# reshaping --------------------------------------------------- + +#' Convert matrix of predictions into a molten data frame #' -#' @param yrep A matrix, already validated using `validate_yrep()`. -#' @return A data frame with 4 columns: -#' 1. `y_id`: integer indicating the observation number (`yrep` column). -#' 1. `rep_id`: integer indicating the simulation number (`yrep` row). -#' 1. `rep_label`: factor with S levels, where S is `nrow(yrep)`, i.e. the -#' number of simulations included in `yrep`. -#' 1. `value`: the simulation values. +#' @param predictions A matrix (`yrep` or `ypred`), already validated using +#' `validate_predictions()`. +#' @return A data frame with columns: +#' * `y_id`: integer indicating the observation number (`predictions` column). +#' * `rep_id`: integer indicating the simulation number (`predictions` row). +#' * `rep_label`: factor with S levels, where S is `nrow(predictions)`, i.e. +#' the number of simulations included in `predictions`. +#' * `value`: the simulation values. #' @noRd -melt_yrep <- function(yrep) { - out <- yrep %>% +melt_predictions <- function(predictions) { + obs_names <- attr(predictions, "obs_names") + out <- predictions %>% reshape2::melt(varnames = c("rep_id", "y_id")) %>% tibble::as_tibble() - id <- create_yrep_ids(out$rep_id) - out$rep_label <- factor(id, levels = unique(id)) - out[c("y_id", "rep_id", "rep_label", "value")] + + rep_labels <- create_rep_ids(out$rep_id) + y_names <- obs_names[out$y_id] %||% out$y_id + out$rep_label <- factor(rep_labels, levels = unique(rep_labels)) + out$y_name <- factor(y_names, levels = unique(y_names)) + out[c("y_id", "y_name", "rep_id", "rep_label", "value")] } -#' Stack y below melted yrep data +#' Stack `y` below melted `yrep` data #' -#' @param y Validated y input. -#' @param yrep Validated yrep input. +#' @param y Validated `y` input. +#' @param yrep Validated `yrep` input. #' @return A data frame with the all the columns as the one returned by -#' `melt_yrep()`, plus additional columns: -#' 1. `is_y`: logical indicating whether the values are observations (`TRUE`) +#' `melt_predictions()`, plus additional columns: +#' * `is_y`: logical indicating whether the values are observations (`TRUE`) #' or simulations (`FALSE`). -#' 1. `is_y_label`: factor with levels `italic(y)` for observations and +#' * `is_y_label`: factor with levels `italic(y)` for observations and #' `italic(y)[rep]` for simulations. #' @noRd melt_and_stack <- function(y, yrep) { y_text <- as.character(y_label()) yrep_text <- as.character(yrep_label()) - molten_yrep <- melt_yrep(yrep) + molten_preds <- melt_predictions(yrep) # Add a level in the labels for the observed y values - levels(molten_yrep$rep_label) <- c(levels(molten_yrep$rep_label), y_text) + levels(molten_preds$rep_label) <- c(levels(molten_preds$rep_label), y_text) + + y_names <- attr(yrep, "obs_names") %||% seq_along(y) ydat <- tibble::tibble( - rep_label = factor(y_text, levels = levels(molten_yrep$rep_label)), + rep_label = factor(y_text, levels = levels(molten_preds$rep_label)), rep_id = NA_integer_, y_id = seq_along(y), + y_name = factor(y_names, levels = unique(y_names)), value = y) - data <- dplyr::bind_rows(molten_yrep, ydat) %>% + data <- dplyr::bind_rows(molten_preds, ydat) %>% mutate( rep_label = relevel(.data$rep_label, y_text), is_y = is.na(.data$rep_id), is_y_label = ifelse(.data$is_y, y_text, yrep_text) %>% factor(levels = c(y_text, yrep_text))) - data[c("y_id", "rep_id", "rep_label", "is_y", "is_y_label", "value")] -} - - -#' Prepare data for use in PPCs by group -#' -#' @param y,yrep,group Validated `y`, `yrep`, and `group` objects. -#' @param stat Either `NULL` or a string naming a function. -#' @return If `stat` is `NULL`, a molten data frame grouped by group and -#' variable. If `stat` specifies a function then a summary table created -#' by `dplyr::summarise()`. -#' @noRd -#' -#' @examples -#' y <- example_y_data() -#' yrep <- example_yrep_draws() -#' group <- example_group_data() -#' ppc_group_data(y, yrep, group) -#' ppc_group_data(y, yrep, group, median) -ppc_group_data <- function(y, yrep, group, stat = NULL) { - d <- data.frame( - group = factor(group), - y = y, - yrep = t(yrep) - ) - colnames(d) <- gsub(".", "_", colnames(d), fixed = TRUE) - molten_d <- reshape2::melt(d, id.vars = "group") - molten_d <- dplyr::group_by(molten_d, .data$group, .data$variable) - - # Default to identity function. - dplyr_fun <- dplyr::summarise - if (is.null(stat)) { - stat <- function(x) x - dplyr_fun <- dplyr::mutate - } - - stat <- match.fun(stat) - dplyr_fun(molten_d, value = stat(.data$value)) - - # todo: does this result need to be ungrouped. If mutating path, it has two - # grouping vars. It summarising path, it has one grouping var. -} - -# Check if x consists of whole numbers (very close to integers) -# Implementation here follows example ?integer -is_whole_number <- function(x, tol = .Machine$double.eps) { - if (!is.numeric(x)) { - FALSE - } else { - abs(x - round(x)) < tol - } + cols <- c("y_id", "y_name", "rep_id", "rep_label", + "is_y", "is_y_label", "value") + data[cols] } -# Check if all values in x are whole numbers or counts (non-negative whole -# numbers) -all_whole_number <- function(x, ...) { - all(is_whole_number(x, ...)) -} -all_counts <- function(x, ...) { - all_whole_number(x, ...) && min(x) >= 0 -} # labels ---------------------------------------------------------------- -create_yrep_ids <- function(ids) paste('italic(y)[rep] (', ids, ")") -yrep_label <- function() expression(italic(y)[rep]) -yrep_avg_label <- function() expression(paste("Average ", italic(y)[rep])) +create_rep_ids <- function(ids) paste('italic(y)[rep] (', ids, ")") y_label <- function() expression(italic(y)) -Ty_label <- function() expression(italic(T(italic(y)))) -Tyrep_label <- function() expression(italic(T)(italic(y)[rep])) -# Ty_label_2d <- function() { -# expression(bgroup( -# "(", list(italic(T)[1](italic(y)), -# italic(T)[2](italic(y))), ")" -# )) -# } -# Tyrep_label_2d <- function(k) { -# stopifnot(k == 1 || k == 2) -# if (k == 1) expression(paste(italic(T)[1](italic(y)[rep]))) -# else expression(paste(italic(T)[2](italic(y)[rep]))) -# } +yrep_label <- function() expression(italic(y)[rep]) +ypred_label <- function() expression(italic(y)[pred]) diff --git a/R/helpers-shared.R b/R/helpers-shared.R index 0065d3a7..9128e0f0 100644 --- a/R/helpers-shared.R +++ b/R/helpers-shared.R @@ -25,12 +25,17 @@ suggested_package <- function(pkg, min_version = NULL) { # Return x if not NULL, otherwise y `%||%` <- function(x, y) if (!is.null(x)) x else y -# Check for ignored arguments +#' Warn about ignored arguments +#' +#' @param ... The `...` arguments from the calling function. +#' @param ok_args A character vector of argument names to ignore. +#' @return Nothing, but a warning may be thrown. +#' @noRd check_ignored_arguments <- function(..., ok_args = character()) { dots <- list(...) + nms <- names(dots) if (length(dots)) { - unrecognized <- if (!length(ok_args)) - names(dots) else setdiff(names(dots), ok_args) + unrecognized <- if (!length(ok_args)) nms else setdiff(nms, ok_args) if (length(unrecognized)) { warn(paste( "The following arguments were unrecognized and ignored:", diff --git a/R/mcmc-traces.R b/R/mcmc-traces.R index c23f269b..285c7b37 100644 --- a/R/mcmc-traces.R +++ b/R/mcmc-traces.R @@ -1,6 +1,6 @@ -#' Trace plots of MCMC draws +#' Trace and rank plots of MCMC draws #' -#' Trace plot (or traceplot) of MCMC draws. See the **Plot Descriptions** +#' Trace and rank plots of MCMC draws. See the **Plot Descriptions** #' section, below, for details. #' #' @name MCMC-traces @@ -316,14 +316,14 @@ mcmc_rank_overlay <- function(x, } else { NULL } - + facet_call <- NULL if (n_param > 1) { facet_args$facets <- ~ parameter facet_args$scales <- facet_args$scales %||% "fixed" facet_call <- do.call("facet_wrap", facet_args) } - + ggplot(d_bin_counts) + aes_(x = ~ bin_start, y = ~ n, color = ~ chain) + geom_step() + @@ -473,7 +473,7 @@ mcmc_trace_data <- function(x, value_rank = rank(.data$value, ties.method = "average") ) %>% ungroup() %>% - select(!!! first_cols, dplyr::everything()) + select(!!! first_cols, tidyselect::everything()) data$highlight <- if (!is.null(highlight)) { data$chain == highlight diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index 9ebec63e..c2f94b72 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -76,12 +76,8 @@ ppc_km_overlay <- function( check_ignored_arguments(..., ok_args = "add_group") add_group <- list(...)$add_group - if(!requireNamespace("survival", quietly = TRUE)){ - abort("Package 'survival' required.") - } - if(!requireNamespace("ggfortify", quietly = TRUE)){ - abort("Package 'ggfortify' required.") - } + suggested_package("survival") + suggested_package("ggfortify") stopifnot(is.numeric(status_y)) stopifnot(all(status_y %in% c(0, 1))) @@ -150,7 +146,7 @@ ppc_km_overlay <- function( ) + scale_size_identity() + scale_alpha_identity() + - scale_color_ppc_dist() + + scale_color_ppc() + scale_y_continuous(breaks = c(0, 0.5, 1)) + xlab(y_label()) + yaxis_title(FALSE) + diff --git a/R/ppc-discrete.R b/R/ppc-discrete.R index af53a662..7f810490 100644 --- a/R/ppc-discrete.R +++ b/R/ppc-discrete.R @@ -14,20 +14,17 @@ #' @param ... Currently unused. #' @param prob A value between `0` and `1` indicating the desired probability #' mass to include in the `yrep` intervals. Set `prob=0` to remove the -#' intervals. For `ppc_rootogram()` these are intervals of the *square roots* -#' of the expected counts. -#' @param width For `ppc_bars()` and `ppc_bars_grouped()`, passed to -#' [ggplot2::geom_bar()] to control the bar width. -#' @param size,fatten For `ppc_bars()` and `ppc_bars_grouped()`, `size` and -#' `fatten` are passed to [ggplot2::geom_pointrange()] to control the -#' appearance of the `yrep` points and intervals. For `ppc_rootogram()` `size` -#' is passed to [ggplot2::geom_line()]. -#' @param freq For `ppc_bars()` and `ppc_bars_grouped()`, if `TRUE` (the -#' default) the y-axis will display counts. Setting `freq=FALSE` will put -#' proportions on the y-axis. +#' intervals. (Note: for rootograms these are intervals of the *square roots* +#' of the expected counts.) +#' @param width For bar plots only, passed to [ggplot2::geom_bar()] to control +#' the bar width. +#' @param size,fatten For bar plots, `size` and `fatten` are passed to +#' [ggplot2::geom_pointrange()] to control the appearance of the `yrep` points +#' and intervals. For rootograms `size` is passed to [ggplot2::geom_line()]. +#' @param freq For bar plots only, if `TRUE` (the default) the y-axis will +#' display counts. Setting `freq=FALSE` will put proportions on the y-axis. #' -#' -#' @template return-ggplot +#' @template return-ggplot-or-data #' #' @details For all of these plots `y` and `yrep` must be integers, although #' they need not be integers in the strict sense of \R's @@ -59,9 +56,9 @@ #' * _Suspended_: histogram of the differences between expected and #' observed counts. #' -#' **All of these are plotted on the square root scale**. See Kleiber and -#' Zeileis (2016) for advice on interpreting rootograms and selecting among -#' the different styles. +#' **All of the rootograms are plotted on the square root scale**. See Kleiber +#' and Zeileis (2016) for advice on interpreting rootograms and selecting +#' among the different styles. #' } #' } #' @@ -85,6 +82,40 @@ #' color_scheme_set("mix-blue-pink") #' ppc_bars_grouped(y, yrep, group, prob = 0.5, freq = FALSE) #' +#' \dontrun{ +#' # example for ordinal regression using rstanarm +#' library(rstanarm) +#' fit <- stan_polr( +#' tobgp ~ agegp, +#' data = esoph, +#' method = "probit", +#' prior = R2(0.2, "mean"), +#' init_r = 0.1, +#' seed = 12345, +#' # cores = 4, +#' refresh = 0 +#' ) +#' +#' # coded as character, so convert to integer +#' yrep_char <- posterior_predict(fit) +#' print(yrep_char[1, 1:4]) +#' +#' yrep_int <- sapply(data.frame(yrep_char, stringsAsFactors = TRUE), as.integer) +#' y_int <- as.integer(esoph$tobgp) +#' +#' ppc_bars(y_int, yrep_int) +#' +#' ppc_bars_grouped( +#' y = y_int, +#' yrep = yrep_int, +#' group = esoph$agegp, +#' freq=FALSE, +#' prob = 0.5, +#' fatten = 1, +#' size = 1.5 +#' ) +#' } +#' NULL #' @rdname PPC-discrete @@ -96,41 +127,56 @@ ppc_bars <- prob = 0.9, width = 0.9, size = 1, - fatten = 3, + fatten = 2.5, freq = TRUE) { - check_ignored_arguments(...) - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - if (!all_whole_number(y)) { - abort("ppc_bars expects 'y' to be discrete.") - } - if (!all_whole_number(yrep)) { - abort("ppc_bars expects 'yrep' to be discrete.") + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } + + data <- ppc_bars_data( + y = y, + yrep = yrep, + group = dots$group, + prob = prob, + freq = freq + ) + + if (!is.null(dots$group)) { + limits <- geom_ignore() + } else { + limits <- expand_limits(y = 1.05 * max(data[["h"]], na.rm = TRUE)) + } + + ggplot(data) + + geom_col( + data = dplyr::filter(data, !is.na(.data$y_obs)), + mapping = aes_(x = ~ x, y = ~ y_obs, fill = "y"), + color = get_color("lh"), + width = width + ) + + geom_pointrange( + mapping = intervals_inner_aes(needs_y = TRUE, color = "yrep"), + size = size, + fatten = fatten, + na.rm = TRUE + ) + + scale_color_ppc( + values = get_color("d"), + labels = yrep_label(), + guide = guide_legend(order = 1, override.aes = list(size = .75 * size)) + ) + + scale_fill_ppc(values = get_color("l"), labels = y_label()) + + scale_x_continuous(breaks = pretty) + + labs(x = NULL, y = if (freq) "Count" else "Proportion") + + dont_expand_y_axis() + + bayesplot_theme_get() + + limits + + reduce_legend_spacing(0.25) } - alpha <- (1 - prob) / 2 - probs <- sort(c(alpha, 0.5, 1 - alpha)) - yrep_data <- ppc_bars_yrep_data( - y, - yrep, - probs = probs, - freq = freq, - group = NULL - ) - - .ppc_bars( - y_data = data.frame(y = y), - yrep_data, - grouped = FALSE, - facet_args = list(), - width = width, - size = size, - fatten = fatten, - freq = freq - ) -} - #' @rdname PPC-discrete #' @export @@ -146,33 +192,17 @@ ppc_bars_grouped <- prob = 0.9, width = 0.9, size = 1, - fatten = 3, + fatten = 2.5, freq = TRUE) { - check_ignored_arguments(...) - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - group <- validate_group(group, y) - if (!all_whole_number(y)) { - abort("ppc_bars_grouped expects 'y' to be discrete.") + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppc_bars", call), parent.frame()) + if (fixed_y(facet_args)) { + g <- g + expand_limits(y = 1.05 * max(g$data[["h"]], na.rm = TRUE)) } - if (!all_whole_number(yrep)) { - abort("ppc_bars_grouped expects 'yrep' to be discrete.") - } - - alpha <- (1 - prob) / 2 - probs <- sort(c(alpha, 0.5, 1 - alpha)) - yrep_data <- ppc_bars_yrep_data(y, yrep, probs, freq = freq, group = group) - .ppc_bars( - y_data = data.frame(y, group), - yrep_data, - grouped = TRUE, - facet_args = facet_args, - width = width, - size = size, - fatten = fatten, - freq = freq - ) + g + + bars_group_facets(facet_args) + + force_axes_in_facets() } @@ -210,7 +240,7 @@ ppc_rootogram <- function(y, check_ignored_arguments(...) style <- match.arg(style) y <- validate_y(y) - yrep <- validate_yrep(yrep, y) + yrep <- validate_predictions(yrep, length(y)) if (!all_counts(y)) { abort("ppc_rootogram expects counts as inputs to 'y'.") } @@ -266,8 +296,9 @@ ppc_rootogram <- function(y, ) + bayesplot_theme_get() - if (style != "standing") + if (style != "standing") { graph <- graph + hline_0(size = 0.4) + } graph <- graph + geom_smooth( @@ -285,26 +316,63 @@ ppc_rootogram <- function(y, labs(x = expression(italic(y)), y = expression(sqrt(Count))) - if (style == "standing") + if (style == "standing") { graph <- graph + dont_expand_y_axis() + } graph + reduce_legend_spacing(0.25) } - +#' @rdname PPC-discrete +#' @export +ppc_bars_data <- + function(y, + yrep, + group = NULL, + prob = 0.9, + freq = TRUE) { + stopifnot(0 <= prob && prob <= 1, is.logical(freq)) + y <- validate_y(y) + yrep <- validate_predictions(yrep, length(y)) + if (!all_whole_number(y)) { + abort("ppc_bars expects 'y' to be discrete.") + } + if (!all_whole_number(yrep)) { + abort("ppc_bars expects 'yrep' to be discrete.") + } + if (!is.null(group)) { + group <- validate_group(group, length(y)) + } + .ppc_bars_data( + y = y, + yrep = yrep, + group = group, + prob = prob, + freq = freq + ) + } # internal ---------------------------------------------------------------- -#' @importFrom dplyr "%>%" ungroup count arrange mutate -ppc_bars_yrep_data <- function(y, yrep, probs, freq = TRUE, group = NULL) { +#' Internal function for `ppc_bars_data()` +#' +#' @noRd +#' @param y,yrep,group User's already validated `y`, `yrep`, and (if applicable) +#' `group` arguments. +#' @param prob,freq User's `prob` and `freq` arguments. +#' @importFrom dplyr "%>%" ungroup count arrange mutate summarise across full_join rename +.ppc_bars_data <- function(y, yrep, group = NULL, prob = 0.9, freq = TRUE) { + alpha <- (1 - prob) / 2 + probs <- sort(c(alpha, 0.5, 1 - alpha)) + # Prepare for final summary - sel <- ifelse(freq, "n", "proportion") lo <- function(x) quantile(x, probs[1]) mid <- function(x) quantile(x, probs[2]) hi <- function(x) quantile(x, probs[3]) - fs <- list(lo = lo, mid = mid, hi = hi) + summary_var <- ifelse(freq, "n", "proportion") + summary_funs <- list(l = lo, m = mid, h = hi) # use l,m,h like in our intervals data # Set a dummy group for ungrouped data if (is.null(group)) { @@ -314,87 +382,55 @@ ppc_bars_yrep_data <- function(y, yrep, probs, freq = TRUE, group = NULL) { was_null_group <- FALSE } - # FIXME: make sure that levels with zero counts are still plotted - yrep_data <- ppc_group_data(y, yrep, group = group, stat = NULL) %>% - dplyr::filter(.data$variable != "y") %>% - ungroup() %>% + tmp_data <- data.frame( + group = factor(group), + y = y, + yrep = t(yrep) + ) + data <- + reshape2::melt(tmp_data, id.vars = "group") %>% count(.data$group, .data$value, .data$variable) %>% group_by(.data$variable, .data$group) %>% mutate(proportion = .data$n / sum(.data$n)) %>% ungroup() %>% group_by(.data$group, .data$value) - summary_stats <- yrep_data %>% - dplyr::summarise_at(sel, fs) %>% - ungroup() - - # Drop dummy group - if (was_null_group) { - summary_stats$group <- NULL - } - - summary_stats %>% - rename(x = .data$value) -} - -.ppc_bars <- function(y_data, - yrep_data, - facet_args = list(), - grouped = FALSE, - width = 0.9, - size = 1, - fatten = 3, - freq = TRUE) { - - graph <- ggplot() + - geom_bar( - data = y_data, - mapping = - if (freq) - aes_(x = ~ y, fill = "y") - else - aes_(x = ~ y, y = ~ ..prop.., fill = "y"), - color = get_color("lh"), - width = width - ) + - geom_pointrange( - data = yrep_data, - mapping = aes_( - x = ~ x, - y = ~ mid, - ymin = ~ lo, - ymax = ~ hi, - color = "yrep" - ), - size = size, - fatten = fatten - ) + - scale_fill_manual("", values = get_color("l"), - labels = y_label()) + - scale_color_manual("", values = get_color("dh"), - labels = yrep_label()) + - guides(color = guide_legend(order = 1), - fill = guide_legend(order = 2)) + - labs(x = NULL, y = if (freq) "Count" else "Proportion") + - bayesplot_theme_get() + yrep_summary <- data %>% + dplyr::filter(!.data$variable == "y") %>% + summarise(across(summary_var, summary_funs, .names = "{.fn}")) %>% + ungroup() %>% + arrange(.data$group, .data$value) - if (grouped) { - facet_args[["facets"]] <- "group" - graph <- graph + do.call("facet_wrap", facet_args) - } + y_summary <- data %>% + dplyr::filter(.data$variable == "y") %>% + ungroup() %>% + rename(y_obs = .data[[summary_var]]) %>% + arrange(.data$group, .data$value) - graph <- graph + - scale_x_continuous(breaks = pretty) + - dont_expand_y_axis() + cols <- syms(c(if (!was_null_group) "group", "x", "y_obs", "l", "m", "h")) + # full join to keep empty cells + full_join(yrep_summary, y_summary, by = c("group", "value")) %>% + rename(x = .data$value) %>% + arrange(.data$x) %>% + select(!!!cols) +} - # add a little space between the max value plotted and the top of the plot - if (!grouped || !(isTRUE(facet_args[["scales"]] %in% c("free", "free_y")))) { - g <- ggplot_build(graph) - y_axis_max <- max(g$data[[1]][["ymax"]], g$data[[2]][["ymax"]]) - graph <- graph + expand_limits(y = 1.05 * y_axis_max) - } - graph + reduce_legend_spacing(0.25) +#' Create the facet layer for grouped bar plots +#' @param facet_args User's `facet_args` argument. +#' @param scales_default String to use for `scales` argument to `facet_wrap()` +#' if not specified by user. The default is `"fixed"` for bar plots. This is +#' the same as `ggplot2::facet_wrap()` but different than +#' `bayesplot::intervals_group_facets()`, which has a default of `"free"`. +#' @return Object returned by `facet_wrap()`. +#' @noRd +bars_group_facets <- function(facet_args, scales_default = "fixed") { + facet_args[["facets"]] <- "group" + facet_args[["scales"]] <- facet_args[["scales"]] %||% scales_default + do.call("facet_wrap", facet_args) } +fixed_y <- function(facet_args) { + !isTRUE(facet_args[["scales"]] %in% c("free", "free_y")) +} diff --git a/R/ppc-distributions.R b/R/ppc-distributions.R index 0cc24c7d..cadb62f1 100644 --- a/R/ppc-distributions.R +++ b/R/ppc-distributions.R @@ -1,19 +1,19 @@ #' PPC distributions #' -#' Compare the empirical distribution of the data `y` to the distributions -#' of simulated/replicated data `yrep` from the posterior predictive -#' distribution. See the **Plot Descriptions** section, below, -#' for details. +#' Compare the empirical distribution of the data `y` to the distributions of +#' simulated/replicated data `yrep` from the posterior predictive distribution. +#' See the **Plot Descriptions** section, below, for details. #' #' @name PPC-distributions #' @family PPCs #' #' @template args-y-yrep +#' @template args-group #' @template args-hist #' @template args-hist-freq #' @template args-dens #' @param size,alpha Passed to the appropriate geom to control the appearance of -#' the `yrep` distributions. +#' the predictive distributions. #' @param ... Currently unused. #' #' @template details-binomial @@ -78,12 +78,13 @@ #' ppc_dens(y, yrep[200:202, ]) #' } #' +#' # frequency polygons #' ppc_freqpoly(y, yrep[1:3,], alpha = 0.1, size = 1, binwidth = 5) #' -#' # if groups are different sizes then the 'freq' argument can be useful #' group <- example_group_data() #' ppc_freqpoly_grouped(y, yrep[1:3,], group) + yaxis_text() #' \donttest{ +#' # if groups are different sizes then the 'freq' argument can be useful #' ppc_freqpoly_grouped(y, yrep[1:3,], group, freq = FALSE) + yaxis_text() #' } #' @@ -107,224 +108,70 @@ NULL - #' @rdname PPC-distributions #' @export ppc_data <- function(y, yrep, group = NULL) { y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - data <- melt_and_stack(y, yrep) - + N <- length(y) + yrep <- validate_predictions(yrep, N) if (!is.null(group)) { - group <- validate_group(group, y) - group_indices <- tibble::tibble(group, y_id = seq_along(group)) - data <- data %>% - left_join(group_indices, by = "y_id") %>% - select(.data$group, dplyr::everything()) + group <- validate_group(group, N) } - - data -} - - - -#' @rdname PPC-distributions -#' @export -ppc_hist <- function(y, yrep, ..., binwidth = NULL, breaks = NULL, - freq = TRUE) { - check_ignored_arguments(...) - data <- ppc_data(y, yrep) - aes_list <- set_hist_aes(freq, fill = ~ is_y_label, color = ~ is_y_label) - - ggplot(data) + - aes_list + - geom_histogram(size = 0.25, binwidth = binwidth, breaks = breaks) + - scale_fill_ppc_dist() + - scale_color_ppc_dist() + - facet_wrap_parsed("rep_label") + - force_axes_in_facets() + - dont_expand_y_axis() + - bayesplot_theme_get() + - space_legend_keys() + - yaxis_text(FALSE) + - yaxis_title(FALSE) + - yaxis_ticks(FALSE) + - xaxis_title(FALSE) + - facet_text(FALSE) + - facet_bg(FALSE) + # see R/ppd-distributions.R + .ppd_data(predictions = yrep, y = y, group = group) } - #' @rdname PPC-distributions #' @export -#' @param notch A logical scalar passed to [ggplot2::geom_boxplot()]. -#' Unlike for `geom_boxplot()`, the default is `notch=TRUE`. -#' -ppc_boxplot <- function(y, yrep, ..., notch = TRUE, size = 0.5, alpha = 1) { - check_ignored_arguments(...) - data <- ppc_data(y, yrep) - - ggplot(data) + - aes_(x = ~ rep_label, y = ~ value, - fill = ~ is_y_label, color = ~ is_y_label) + - geom_boxplot( - notch = notch, - size = size, - alpha = alpha, - outlier.alpha = 2 / 3) + - scale_fill_ppc_dist() + - scale_color_ppc_dist() + - bayesplot_theme_get() + - yaxis_title(FALSE) + - xaxis_ticks(FALSE) + - xaxis_text(FALSE) + - xaxis_title(FALSE) -} - - - -#' @rdname PPC-distributions -#' @export -ppc_freqpoly <- function(y, yrep, ..., - binwidth = NULL, - freq = TRUE, - size = 0.25, - alpha = 1) { - check_ignored_arguments(...) - data <- ppc_data(y, yrep) - aes_list <- set_hist_aes(freq, fill = ~ is_y_label, color = ~ is_y_label) - - ggplot(data) + - aes_list + - aes_(x = ~ value, fill = ~ is_y_label, color = ~ is_y_label) + - geom_area(stat = "bin", binwidth = binwidth, size = size, alpha = alpha) + - scale_fill_ppc_dist() + - scale_color_ppc_dist() + - facet_wrap_parsed("rep_label") + - bayesplot_theme_get() + - force_axes_in_facets() + - dont_expand_y_axis() + - space_legend_keys() + - yaxis_text(FALSE) + - yaxis_title(FALSE) + - yaxis_ticks(FALSE) + - xaxis_title(FALSE) + - facet_text(FALSE) + - facet_bg(FALSE) -} - -#' @rdname PPC-distributions -#' @export -#' @template args-group -#' -ppc_freqpoly_grouped <- function(y, yrep, group, ..., binwidth = NULL, - freq = TRUE, size = 0.25, alpha = 1) { +#' @template args-density-controls +ppc_dens_overlay <- + function(y, + yrep, + ..., + size = 0.25, + alpha = 0.7, + trim = FALSE, + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + n_dens = 1024) { check_ignored_arguments(...) - data <- ppc_data(y, yrep, group) - aes_list <- set_hist_aes(freq) - - ggplot(data) + - aes_list + - geom_area(aes_(color = ~ is_y_label, fill = ~ is_y_label), - stat = "bin", size = size, alpha = alpha, - binwidth = binwidth, na.rm = TRUE) + - facet_grid(rep_label ~ group, scales = "free") + - scale_fill_ppc_dist() + - scale_color_ppc_dist() + - dont_expand_y_axis(c(0.005, 0)) + + + data <- ppc_data(y, yrep) + ggplot(data, mapping = aes_(x = ~ value)) + + overlay_ppd_densities( + mapping = aes_(group = ~ rep_id, color = "yrep"), + data = function(x) dplyr::filter(x, !.data$is_y), + size = size, + alpha = alpha, + trim = trim, + bw = bw, + adjust = adjust, + kernel = kernel, + n = n_dens + ) + + overlay_ppd_densities( + mapping = aes_(color = "y"), + data = function(x) dplyr::filter(x, .data$is_y), + lineend = "round", + size = 1, + trim = trim, + bw = bw, + adjust = adjust, + kernel = kernel, + n = n_dens + ) + + scale_color_ppc() + bayesplot_theme_get() + - force_axes_in_facets() + - space_legend_keys() + + dont_expand_axes() + + yaxis_title(FALSE) + xaxis_title(FALSE) + yaxis_text(FALSE) + - yaxis_ticks(FALSE) + - yaxis_title(FALSE) + - facet_bg(FALSE) + - theme(strip.text.y = element_blank()) + yaxis_ticks(FALSE) } -#' @rdname PPC-distributions -#' @export -ppc_dens <- function(y, yrep, ..., trim = FALSE, size = 0.5, alpha = 1) { - check_ignored_arguments(...) - data <- ppc_data(y, yrep) - - ggplot(data) + - aes_(x = ~ value, fill = ~ is_y_label, color = ~ is_y_label) + - geom_density(size = size, alpha = alpha, trim = trim) + - scale_fill_ppc_dist() + - scale_color_ppc_dist() + - bayesplot_theme_get() + - facet_wrap_parsed("rep_label") + - force_axes_in_facets() + - dont_expand_y_axis() + - space_legend_keys() + - yaxis_text(FALSE) + - yaxis_title(FALSE) + - yaxis_ticks(FALSE) + - xaxis_title(FALSE) + - facet_text(FALSE) + - facet_bg(FALSE) -} - -#' @rdname PPC-distributions -#' @export -#' @template args-density-controls -ppc_dens_overlay <- function( - y, - yrep, - ..., - size = 0.25, - alpha = 0.7, - trim = FALSE, - bw = "nrd0", - adjust = 1, - kernel = "gaussian", - n_dens = 1024 -) { - check_ignored_arguments(...) - data <- ppc_data(y, yrep) - - ggplot(data) + - aes_(x = ~ value) + - stat_density( - aes_(group = ~ rep_id, color = "yrep"), - data = function(x) dplyr::filter(x, !.data$is_y), - geom = "line", - position = "identity", - size = size, - alpha = alpha, - trim = trim, - bw = bw, - adjust = adjust, - kernel = kernel, - n = n_dens - ) + - stat_density( - aes_(color = "y"), - data = function(x) dplyr::filter(x, .data$is_y), - geom = "line", - position = "identity", - lineend = "round", - size = 1, - trim = trim, - bw = bw, - adjust = adjust, - kernel = kernel, - n = n_dens - ) + - scale_color_ppc_dist() + - bayesplot_theme_get() + - xlab(y_label()) + - dont_expand_axes() + - yaxis_title(FALSE) + - xaxis_title(FALSE) + - yaxis_text(FALSE) + - yaxis_ticks(FALSE) -} - #' @rdname PPC-distributions #' @export #' @template args-density-controls @@ -373,6 +220,7 @@ ppc_dens_overlay_grouped <- function( #' passed to [ggplot2::stat_ecdf()]. If `discrete` is set to #' `TRUE` then `geom="step"` is used. #' @param pad A logical scalar passed to [ggplot2::stat_ecdf()]. +#' ppc_ecdf_overlay <- function( y, yrep, @@ -414,14 +262,12 @@ ppc_ecdf_overlay <- function( size = 1, pad = pad ) + - scale_color_ppc_dist() + - xlab(y_label()) + - scale_y_continuous(breaks = c(0, 0.5, 1)) + - yaxis_title(FALSE) + - xaxis_title(FALSE) + - yaxis_ticks(FALSE) + - bayesplot_theme_get() -} + scale_color_ppc() + + scale_y_continuous(breaks = c(0, 0.5, 1)) + + bayesplot_theme_get() + + yaxis_title(FALSE) + + xaxis_title(FALSE) + } #' @export #' @rdname PPC-distributions @@ -457,9 +303,193 @@ ppc_ecdf_overlay_grouped <- function( } +#' @rdname PPC-distributions +#' @export +ppc_dens <- + function(y, + yrep, + ..., + trim = FALSE, + size = 0.5, + alpha = 1) { + check_ignored_arguments(...) + data <- ppc_data(y, yrep) + ggplot(data, mapping = aes_( + x = ~ value, + fill = ~ is_y_label, + color = ~ is_y_label + )) + + geom_density( + size = size, + alpha = alpha, + trim = trim + ) + + scale_fill_ppc() + + scale_color_ppc() + + bayesplot_theme_get() + + facet_wrap_parsed("rep_label") + + force_axes_in_facets() + + dont_expand_y_axis() + + space_legend_keys() + + yaxis_text(FALSE) + + yaxis_title(FALSE) + + yaxis_ticks(FALSE) + + xaxis_title(FALSE) + + facet_text(FALSE) + + facet_bg(FALSE) + } + + +#' @rdname PPC-distributions +#' @export +ppc_hist <- + function(y, + yrep, + ..., + binwidth = NULL, + breaks = NULL, + freq = TRUE) { + check_ignored_arguments(...) + + data <- ppc_data(y, yrep) + ggplot(data, mapping = set_hist_aes( + freq = freq, + fill = ~ is_y_label, + color = ~ is_y_label + )) + + geom_histogram( + size = 0.25, + binwidth = binwidth, + breaks = breaks + ) + + scale_fill_ppc() + + scale_color_ppc() + + facet_wrap_parsed("rep_label") + + force_axes_in_facets() + + dont_expand_y_axis() + + bayesplot_theme_get() + + space_legend_keys() + + yaxis_text(FALSE) + + yaxis_title(FALSE) + + yaxis_ticks(FALSE) + + xaxis_title(FALSE) + + facet_text(FALSE) + + facet_bg(FALSE) + } + + +#' @rdname PPC-distributions +#' @export +ppc_freqpoly <- + function(y, + yrep, + ..., + binwidth = NULL, + freq = TRUE, + size = 0.5, + alpha = 1) { + + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } + + data <- ppc_data(y, yrep, group = dots$group) + ggplot(data, mapping = set_hist_aes( + freq = freq, + fill = ~ is_y_label, + color = ~ is_y_label + )) + + geom_area( + stat = "bin", + binwidth = binwidth, + size = size, + alpha = alpha + ) + + scale_fill_ppc() + + scale_color_ppc() + + facet_wrap_parsed("rep_label") + + bayesplot_theme_get() + + force_axes_in_facets() + + dont_expand_y_axis() + + space_legend_keys() + + yaxis_text(FALSE) + + yaxis_title(FALSE) + + yaxis_ticks(FALSE) + + xaxis_title(FALSE) + + facet_text(FALSE) + } + + +#' @rdname PPC-distributions +#' @export +ppc_freqpoly_grouped <- + function(y, + yrep, + group, + ..., + binwidth = NULL, + freq = TRUE, + size = 0.5, + alpha = 1) { + check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppc_freqpoly", call), parent.frame()) + g + + facet_grid( + rep_label ~ group, + scales = "free", + labeller = label_parsed + ) + + force_axes_in_facets() + + facet_text() + + theme(strip.text.y = element_blank()) + } + +#' @rdname PPC-distributions #' @export +#' @param notch For the box plot, a logical scalar passed to +#' [ggplot2::geom_boxplot()]. Note: unlike `geom_boxplot()`, the default is +#' `notch=TRUE`. +#' +ppc_boxplot <- + function(y, + yrep, + ..., + notch = TRUE, + size = 0.5, + alpha = 1) { + check_ignored_arguments(...) + + data <- ppc_data(y, yrep) + ggplot(data, mapping = aes_( + x = ~ rep_label, + y = ~ value, + fill = ~ is_y_label, + color = ~ is_y_label + )) + + geom_boxplot( + notch = notch, + size = size, + alpha = alpha, + outlier.alpha = 2/3, + outlier.size = 1 + ) + + scale_x_discrete(labels = function(x) parse(text=x)) + + scale_fill_ppc() + + scale_color_ppc() + + bayesplot_theme_get() + + yaxis_title(FALSE) + + xaxis_ticks(FALSE) + + xaxis_text(FALSE) + + xaxis_title(FALSE) + } + + #' @rdname PPC-distributions +#' @export #' @param probs A numeric vector passed to [ggplot2::geom_violin()]'s #' `draw_quantiles` argument to specify at which quantiles to draw #' horizontal lines. Set to `NULL` to remove the lines. @@ -471,76 +501,65 @@ ppc_ecdf_overlay_grouped <- function( #' to control the appearance of `y` points. The default of `y_jitter=NULL` #' will let **ggplot2** determine the amount of jitter. #' -ppc_violin_grouped <- function(y, yrep, group, ..., probs = c(0.1, 0.5, 0.9), - size = 1, alpha = 1, - y_draw = c("violin", "points", "both"), - y_size = 1, y_alpha = 1, y_jitter = 0.1) { - check_ignored_arguments(...) - data <- ppc_data(y, yrep, group) - - y_draw <- match.arg(y_draw) - y_violin <- y_draw %in% c("violin", "both") - y_points <- y_draw %in% c("points", "both") - - args_violin_yrep <- list( - data = function(x) dplyr::filter(x, !.data$is_y), - aes_(fill = "yrep", color = "yrep"), - draw_quantiles = probs, - alpha = alpha, - size = size - ) - - args_violin_y <- list( - data = function(x) dplyr::filter(x, .data$is_y), - aes_(fill = "y", color = "y"), - show.legend = FALSE, - alpha = 0 - ) - - args_jitter_y <- list( - data = function(x) dplyr::filter(x, .data$is_y), - aes_(fill = "y", color = "y"), - shape = 21, - alpha = y_alpha, - size = y_size, - width = y_jitter, - height = 0, - show.legend = FALSE - ) +ppc_violin_grouped <- + function(y, + yrep, + group, + ..., + probs = c(0.1, 0.5, 0.9), + size = 1, + alpha = 1, + y_draw = c("violin", "points", "both"), + y_size = 1, + y_alpha = 1, + y_jitter = 0.1) { + check_ignored_arguments(...) - violin_y_func <- if (y_violin) geom_violin else geom_ignore - jitter_y_func <- if (y_points) geom_jitter else geom_ignore + y_draw <- match.arg(y_draw) + y_violin <- y_draw %in% c("violin", "both") + y_points <- y_draw %in% c("points", "both") - layer_violin_yrep <- do.call(geom_violin, args_violin_yrep) - layer_violin_y <- do.call(violin_y_func, args_violin_y) - layer_jitter_y <- do.call(jitter_y_func, args_jitter_y) + args_violin_yrep <- list( + data = function(x) dplyr::filter(x,!.data$is_y), + aes_(fill = "yrep", color = "yrep"), + draw_quantiles = probs, + alpha = alpha, + size = size + ) - ggplot(data) + - aes_(x = ~ group, y = ~ value) + - layer_violin_yrep + - layer_violin_y + - layer_jitter_y + - scale_fill_ppc_dist(values = c(NA, get_color("l"))) + - scale_color_ppc_dist() + - labs(x = "Group", y = yrep_label()) + - yaxis_title(FALSE) + - xaxis_title(FALSE) + - bayesplot_theme_get() -} + args_violin_y <- list( + data = function(x) dplyr::filter(x, .data$is_y), + aes_(fill = "y", color = "y"), + show.legend = FALSE, + alpha = 0 + ) + args_jitter_y <- list( + data = function(x) dplyr::filter(x, .data$is_y), + aes_(fill = "y", color = "y"), + shape = 21, + alpha = y_alpha, + size = y_size, + width = y_jitter, + height = 0, + show.legend = FALSE + ) + + violin_y_func <- if (y_violin) geom_violin else geom_ignore + jitter_y_func <- if (y_points) geom_jitter else geom_ignore + + layer_violin_yrep <- do.call(geom_violin, args_violin_yrep) + layer_violin_y <- do.call(violin_y_func, args_violin_y) + layer_jitter_y <- do.call(jitter_y_func, args_jitter_y) -# internal ---------------------------------------------------------------- -scale_color_ppc_dist <- function(name = NULL, values = NULL, labels = NULL) { - scale_color_manual( - name = name %||% "", - values = values %||% get_color(c("dh", "lh")), - labels = labels %||% c(y_label(), yrep_label()) - ) -} -scale_fill_ppc_dist <- function(name = NULL, values = NULL, labels = NULL) { - scale_fill_manual( - name = name %||% "", - values = values %||% get_color(c("d", "l")), - labels = labels %||% c(y_label(), yrep_label()) - ) -} + data <- ppc_data(y, yrep, group) + ggplot(data, mapping = aes_(x = ~ group, y = ~ value)) + + layer_violin_yrep + + layer_violin_y + + layer_jitter_y + + scale_fill_ppc(values = c(NA, get_color("l"))) + + scale_color_ppc() + + yaxis_title(FALSE) + + xaxis_title(FALSE) + + bayesplot_theme_get() + } diff --git a/R/ppc-errors.R b/R/ppc-errors.R index 3f84d9b4..25cb69be 100644 --- a/R/ppc-errors.R +++ b/R/ppc-errors.R @@ -7,6 +7,8 @@ #' @family PPCs #' #' @template args-y-yrep +#' @template args-group +#' @template args-facet_args #' @param ... Currently unused. #' @param size,alpha For scatterplots, arguments passed to #' [ggplot2::geom_point()] to control the appearance of the points. For the @@ -28,8 +30,8 @@ #' \describe{ #' \item{`ppc_error_hist()`}{ #' A separate histogram is plotted for the predictive errors computed from -#' `y` and each dataset (row) in `yrep`. For this plot `yrep` -#' should have only a small number of rows. +#' `y` and each dataset (row) in `yrep`. For this plot `yrep` should have +#' only a small number of rows. #' } #' \item{`ppc_error_hist_grouped()`}{ #' Like `ppc_error_hist()`, except errors are computed within levels of a @@ -39,20 +41,18 @@ #' } #' \item{`ppc_error_scatter()`}{ #' A separate scatterplot is displayed for `y` vs. the predictive errors -#' computed from `y` and each dataset (row) in `yrep`. For this -#' plot `yrep` should have only a small number of rows. +#' computed from `y` and each dataset (row) in `yrep`. For this plot `yrep` +#' should have only a small number of rows. #' } #' \item{`ppc_error_scatter_avg()`}{ -#' A single scatterplot of `y` vs. the average of the errors computed -#' from `y` and each dataset (row) in `yrep`. For each individual -#' data point `y[n]` the average error is the average of the -#' errors for `y[n]` computed over the the draws from the posterior -#' predictive distribution. +#' A single scatterplot of `y` vs. the average of the errors computed from +#' `y` and each dataset (row) in `yrep`. For each individual data point +#' `y[n]` the average error is the average of the errors for `y[n]` computed +#' over the the draws from the posterior predictive distribution. #' } #' \item{`ppc_error_scatter_avg_vs_x()`}{ #' Same as `ppc_error_scatter_avg()`, except the average is plotted on the -#' \eqn{y}-axis and a a predictor variable `x` is plotted on the -#' \eqn{x}-axis. +#' y-axis and a predictor variable `x` is plotted on the x-axis. #' } #' \item{`ppc_error_binned()`}{ #' Intended for use with binomial data. A separate binned error plot (similar @@ -89,8 +89,8 @@ #' x <- example_x_data() #' ppc_error_scatter_avg_vs_x(y, yrep, x) #' -#' # ppc_error_binned with binomial model from rstanarm #' \dontrun{ +#' # binned error plot with binomial model from rstanarm #' library(rstanarm) #' example("example_model", package = "rstanarm") #' formula(example_model) @@ -113,31 +113,23 @@ NULL #' @export #' @template args-hist #' @template args-hist-freq -#' ppc_error_hist <- function(y, yrep, ..., + facet_args = list(), binwidth = NULL, breaks = NULL, freq = TRUE) { - check_ignored_arguments(...) - - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - if (nrow(yrep) == 1) { - errors <- data.frame(value = y - as.vector(yrep)) - graph <- ggplot(errors, set_hist_aes(freq)) - } else { - errors <- compute_errors(y, yrep) - graph <- - ggplot(melt_yrep(errors), set_hist_aes(freq)) + - labs(y = NULL, x = expression(italic(y) - italic(y)[rep])) + - facet_wrap(facets = ~ rep_id) + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL } - graph + + data <- ppc_error_data(y, yrep, group = dots$group) + ggplot(data, set_hist_aes(freq)) + geom_histogram( fill = get_color("l"), color = get_color("lh"), @@ -145,54 +137,40 @@ ppc_error_hist <- binwidth = binwidth, breaks = breaks ) + + xlab(error_label()) + bayesplot_theme_get() + - xlab(expression(italic(y) - italic(y)[rep])) + dont_expand_y_axis() + + error_hist_facets( + facet_args, + grouped = FALSE, + ignore = nrow(yrep) == 1 + ) + force_axes_in_facets() + yaxis_title(FALSE) + yaxis_text(FALSE) + yaxis_ticks(FALSE) + - facet_text(FALSE) + - facet_bg(FALSE) + facet_text(FALSE) } #' @rdname PPC-errors #' @export -#' @template args-group -#' ppc_error_hist_grouped <- function(y, yrep, group, ..., + facet_args = list(), binwidth = NULL, breaks = NULL, freq = TRUE) { - check_ignored_arguments(...) - - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - group <- validate_group(group, y) - errors <- grouped_error_data(y, yrep, group) - ggplot(errors, set_hist_aes(freq)) + - geom_histogram( - fill = get_color("l"), - color = get_color("lh"), - size = 0.25, - binwidth = binwidth, - breaks = breaks - ) + - facet_grid(rep_id ~ group, scales = "free") + - bayesplot_theme_get() + - xlab(expression(italic(y) - italic(y)[rep])) + - dont_expand_y_axis(c(0.005, 0)) + - force_axes_in_facets() + - yaxis_text(FALSE) + - yaxis_ticks(FALSE) + - yaxis_title(FALSE) + - facet_bg(FALSE) + + check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppc_error_hist", call), parent.frame()) + g + + error_hist_facets(facet_args, grouped = TRUE) + + facet_text() + theme(strip.text.y = element_blank()) } @@ -203,48 +181,23 @@ ppc_error_scatter <- function(y, yrep, ..., + facet_args = list(), size = 2.5, alpha = 0.8) { check_ignored_arguments(...) y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - - if (nrow(yrep) == 1) { - return( - .ppc_scatter( - data = data.frame(y = y, x = y - as.vector(yrep)), - mapping = aes_(x = ~ x, y = ~ y), - x_lab = expression(italic(y) - italic(y)[rep]), - y_lab = expression(italic(y)), - size = size, - alpha = alpha, - abline = FALSE - ) - ) - } - + yrep <- validate_predictions(yrep, length(y)) errors <- compute_errors(y, yrep) - .ppc_scatter( - data = dplyr::left_join( - melt_yrep(errors), - data.frame(y = y, y_id = seq_along(y)), - by = "y_id" - ), - mapping = aes_(x = ~ value, y = ~ y), - y_lab = expression(italic(y)), - x_lab = expression(italic(y) - italic(y)[rep]), + ppc_scatter( + y = y, + yrep = errors, + facet_args = facet_args, size = size, alpha = alpha, - abline = FALSE + ref_line = FALSE ) + - facet_wrap( - facets = ~ rep_id - # labeller = label_bquote(italic(y) - italic(y)[rep](.(rep_id))) - ) + - force_axes_in_facets() + - facet_text(FALSE) + - facet_bg(FALSE) + labs(x = error_label(), y = y_label()) } #' @rdname PPC-errors @@ -258,26 +211,47 @@ ppc_error_scatter_avg <- check_ignored_arguments(...) y <- validate_y(y) - yrep <- validate_yrep(yrep, y) + yrep <- validate_predictions(yrep, length(y)) + errors <- compute_errors(y, yrep) + ppc_scatter_avg( + y = y, + yrep = errors, + size = size, + alpha = alpha, + ref_line = FALSE + ) + + labs(x = error_avg_label(), y = y_label()) + } - if (nrow(yrep) == 1) - return( - ppc_error_scatter(y, yrep, - size = size, - alpha = alpha, ...) - ) - .ppc_scatter( - data = data.frame(y, avg_error = y - colMeans(yrep)), - mapping = aes_(x = ~ avg_error, y = ~ y), - y_lab = y_label(), - x_lab = "Average predictive error", - alpha = alpha, +#' @rdname PPC-errors +#' @export +ppc_error_scatter_avg_grouped <- + function(y, + yrep, + group, + ..., + facet_args = list(), + size = 2.5, + alpha = 0.8) { + check_ignored_arguments(...) + + y <- validate_y(y) + yrep <- validate_predictions(yrep, length(y)) + errors <- compute_errors(y, yrep) + ppc_scatter_avg_grouped( + y = y, + yrep = errors, + group = group, size = size, - abline = FALSE - ) + alpha = alpha, + facet_args = facet_args, + ref_line = FALSE + ) + + labs(x = error_avg_label(), y = y_label()) } + #' @rdname PPC-errors #' @export #' @param x A numeric vector the same length as `y` to use as the x-axis @@ -293,104 +267,159 @@ ppc_error_scatter_avg_vs_x <- check_ignored_arguments(...) y <- validate_y(y) - yrep <- validate_yrep(yrep, y) + yrep <- validate_predictions(yrep, length(y)) x <- validate_x(x, y) - .ppc_scatter( - data = data.frame(x, avg_error = y - colMeans(yrep)), - mapping = aes_(x = ~ x, y = ~ avg_error), - x_lab = expression(italic(x)), - y_lab = "Average predictive error", - alpha = alpha, + errors <- compute_errors(y, yrep) + ppc_scatter_avg( + y = x, + yrep = errors, size = size, - abline = FALSE - ) + alpha = alpha, + ref_line = FALSE + ) + + labs(x = error_avg_label(), y = expression(italic(x))) + + coord_flip() } #' @rdname PPC-errors #' @export #' @param bins For `ppc_error_binned()`, the number of bins to use (approximately). -ppc_error_binned <- function(y, yrep, ..., bins = NULL, size = 1, alpha = 0.25) { - check_ignored_arguments(...) +ppc_error_binned <- + function(y, + yrep, + ..., + facet_args = list(), + bins = NULL, + size = 1, + alpha = 0.25) { + check_ignored_arguments(...) - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - binned <- binned_error_data(y, yrep, bins = bins) - - mixed_scheme <- is_mixed_scheme(color_scheme_get()) - point_fill <- get_color(ifelse(mixed_scheme, "m", "d")) - point_color <- get_color(ifelse(mixed_scheme, "mh", "dh")) - graph <- - ggplot(binned, aes_(x = ~ ey_bar)) + - geom_hline( - yintercept = 0, - linetype = 2, - color = "black" - ) + - geom_ribbon( - aes_(ymax = ~ se2, ymin = ~ -se2), - fill = get_color("l"), - color = NA, - alpha = alpha - ) + - geom_path( - mapping = aes_(y = ~ se2), - color = get_color("l"), - size = size - ) + - geom_path( - mapping = aes_(y = ~ -se2), - color = get_color("l"), - size = size - ) + - geom_point( - mapping = aes_(y = ~ err_bar), - shape = 21, - fill = point_fill, - color = point_color - ) + - labs( - x = "Predicted proportion", - y = "Average Errors \n (with 2SE bounds)" - ) + - bayesplot_theme_get() + data <- ppc_error_binnned_data(y, yrep, bins = bins) + facet_layer <- if (nrow(yrep) == 1) { + geom_ignore() + } else { + facet_args[["facets"]] <- "rep_id" + do.call("facet_wrap", facet_args) + } - if (nrow(yrep) > 1) { - graph <- graph + - facet_wrap( - facets = ~rep_id - # labeller = label_bquote(italic(y)[rep](.(rep_id))) - ) + mixed_scheme <- is_mixed_scheme(color_scheme_get()) + point_fill <- get_color(ifelse(mixed_scheme, "m", "d")) + point_color <- get_color(ifelse(mixed_scheme, "mh", "dh")) + + ggplot(data, aes_(x = ~ ey_bar)) + + hline_0(linetype = 2, color = "black") + + geom_ribbon( + mapping = aes_(ymax = ~ se2, ymin = ~ -se2), + fill = get_color("l"), + color = NA, + alpha = alpha + ) + + geom_path( + mapping = aes_(y = ~ se2), + color = get_color("l"), + size = size + ) + + geom_path( + mapping = aes_(y = ~ -se2), + color = get_color("l"), + size = size + ) + + geom_point( + mapping = aes_(y = ~ err_bar), + shape = 21, + fill = point_fill, + color = point_color + ) + + labs( + x = "Predicted proportion", + y = "Average Errors \n (with 2SE bounds)" + ) + + bayesplot_theme_get() + + facet_layer + + force_axes_in_facets() + + facet_text(FALSE) } - graph + - force_axes_in_facets() + - facet_text(FALSE) + - facet_bg(FALSE) + +#' @rdname PPC-errors +#' @export +ppc_error_data <- function(y, yrep, group = NULL) { + y <- validate_y(y) + yrep <- validate_predictions(yrep, length(y)) + if (!is.null(group)) { + group <- validate_group(group, length(y)) + } + errors <- compute_errors(y, yrep) %>% melt_predictions() + errors <- tibble::add_column(errors, y_obs = y[errors$y_id], .before = "rep_id") + if (!is.null(group)) { + errors <- tibble::add_column(errors, group = group[errors$y_id], .before = "y_id") + } + errors } # internal ---------------------------------------------------------------- + +#' Compute predictive errors `y` - `yrep` +#' @noRd +#' @param y,yrep User's `y` and `yrep` arguments. +#' @return A matrix with the same dimensions as `yrep` compute_errors <- function(y, yrep) { - errs <- sweep(yrep, MARGIN = 2L, STATS = as.array(y), FUN = "-") - as.matrix(-1 * errs) + suggested_package("rstantools") + rstantools::predictive_error(object = yrep, y = y) } -grouped_error_data <- function(y, yrep, group) { - grps <- unique(group) - errs <- list() - for (j in seq_along(grps)) { - g_j <- grps[j] - err_j <- compute_errors(y[group == g_j], yrep[, group == g_j, drop=FALSE]) - errs[[j]] <- melt_yrep(err_j) - errs[[j]]$group <- g_j + +#' Create facet layer for PPC error plots +#' +#' The default is to use `scales="fixed"` (which I think makes sense for looking +#' at errors, right?) if not specified in `facet_args`. +#' +#' @param User's `facet_args` argument. +#' @param grouped If `FALSE` then does faceting by `rep_id`, if `TRUE` then both +#' `rep_id` and `group`. +#' @param ignore If `TRUE` then `geom_ignore()` is returned. This is intended to +#' allow turning off facets if there is only one plot to make. +#' @param scales_default What to use for the `scales` argument to `facet_*()` if +#' not specified in `facet_args`. +#' @return Object returned by `facet_wrap()` or `facet_grid()` (unless `ignore=TRUE`). +#' @noRd +error_hist_facets <- + function(facet_args, + grouped = FALSE, + ignore = FALSE, + scales_default = "fixed") { + if (ignore) { + return(geom_ignore()) + } + + if (grouped) { + facet_fun <- "facet_grid" + facet_args[["facets"]] <- rep_id ~ group + } else { + facet_fun <- "facet_wrap" + facet_args[["facets"]] <- ~ rep_id + } + facet_args[["scales"]] <- facet_args[["scales"]] %||% scales_default + + do.call(facet_fun, facet_args) } - dat <- dplyr::bind_rows(errs) - dat$y_id <- NULL - return(dat) + + +error_label <- function() { + expression(italic(y) - italic(y)[rep]) } +error_avg_label <- function() { + expression(paste("Average ", italic(y) - italic(y)[rep])) +} + + +# Data for binned errors plots +ppc_error_binnned_data <- function(y, yrep, bins = NULL) { + y <- validate_y(y) + yrep <- validate_predictions(yrep, length(y)) -binned_error_data <- function(y, yrep, bins = NULL) { if (is.null(bins)) { bins <- n_bins(length(y)) } @@ -398,11 +427,17 @@ binned_error_data <- function(y, yrep, bins = NULL) { errors <- compute_errors(y, yrep) binned_errs <- list() for (s in 1:nrow(errors)) { - binned_errs[[s]] <- bin_errors(ey = yrep[s,], r = errors[s,], bins = bins, - rep_id = s) + binned_errs[[s]] <- + bin_errors( + ey = yrep[s, ], + r = errors[s, ], + bins = bins, + rep_id = s + ) } - dat <- dplyr::bind_rows(binned_errs) - return(dat) + + binned_errs <- dplyr::bind_rows(binned_errs) + tibble::as_tibble(binned_errs) } # calculate number of bins binned_error_data() diff --git a/R/ppc-intervals.R b/R/ppc-intervals.R index 5571af06..a138f976 100644 --- a/R/ppc-intervals.R +++ b/R/ppc-intervals.R @@ -1,3 +1,5 @@ + + #' PPC intervals #' #' Medians and central interval estimates of `yrep` with `y` overlaid. @@ -7,18 +9,24 @@ #' @family PPCs #' #' @template args-y-yrep +#' @template args-group +#' @template args-facet_args #' @template args-prob-prob_outer -#' @param x A numeric vector the same length as `y` to use as the x-axis +#' @param x A numeric vector to use as the x-axis #' variable. For example, `x` could be a predictor variable from a #' regression model, a time variable for time-series models, etc. If `x` -#' is missing or `NULL`, then `1:length(y)` is used for the x-axis. -#' @param ... Currently unused. +#' is missing or `NULL` then the observation index is used for the x-axis. #' @param alpha,size,fatten Arguments passed to geoms. For ribbon plots `alpha` -#' and `size` are passed to [ggplot2::geom_ribbon()]. For interval plots -#' `size` and `fatten` are passed to [ggplot2::geom_pointrange()]. +#' is passed to [ggplot2::geom_ribbon()] to control the opacity of the outer +#' ribbon and `size` is passed to [ggplot2::geom_line()] to control the size +#' of the line representing the median prediction (`size=0` will remove the +#' line). For interval plots `alpha`, `size` and `fatten` are passed to +#' [ggplot2::geom_pointrange()] (`fatten=0` will remove the point estimates). +#' @param ... Currently unused. #' #' @template return-ggplot-or-data #' +#' @template reference-vis-paper #' @templateVar bdaRef (Ch. 6) #' @template reference-bda #' @@ -34,8 +42,8 @@ #' also be specified for the x-axis variable. #' #' Depending on the number of observations and the variability in the -#' predictions at different values of `x`, one or the other of these -#' plots may be easier to read than the other. +#' predictions at different values of `x`, one of these plots may be easier +#' to read than the other. #' } #' \item{`ppc_intervals_grouped(), ppc_ribbon_grouped()`}{ #' Same as `ppc_intervals()` and `ppc_ribbon()`, respectively, but a @@ -48,33 +56,33 @@ #' yrep <- matrix(rnorm(5000, 0, 2), ncol = 50) #' #' color_scheme_set("brightblue") -#' ppc_ribbon(y, yrep) #' ppc_intervals(y, yrep) +#' ppc_ribbon(y, yrep) +#' ppc_ribbon(y, yrep, y_draw = "points") +#' \dontrun{ +#' ppc_ribbon(y, yrep, y_draw = "both") +#' } #' -#' # change x axis to y values (instead of indices) and add x = y line -#' ppc_intervals(y, yrep, x = y) + abline_01() -#' +#' ppc_intervals(y, yrep, size = 1.5, fatten = 0) # remove the yrep point estimates #' #' color_scheme_set("teal") #' year <- 1950:1999 -#' ppc_ribbon(y, yrep, x = year, alpha = 0, size = 0.75) + ggplot2::xlab("Year") +#' ppc_intervals(y, yrep, x = year, fatten = 1) + ggplot2::xlab("Year") +#' ppc_ribbon(y, yrep, x = year) + ggplot2::xlab("Year") #' #' color_scheme_set("pink") #' year <- rep(2000:2009, each = 5) #' group <- gl(5, 1, length = 50, labels = LETTERS[1:5]) -#' ppc_ribbon_grouped(y, yrep, x = year, group) + +#' ppc_ribbon_grouped(y, yrep, x = year, group, y_draw = "both") + #' ggplot2::scale_x_continuous(breaks = pretty) #' -#' ppc_ribbon_grouped( -#' y, yrep, x = year, group, -#' facet_args = list(scales = "fixed"), -#' alpha = 1, -#' size = 2 -#' ) + +#' ppc_ribbon_grouped(y, yrep, x = year, group, +#' facet_args = list(scales = "fixed")) + #' xaxis_text(FALSE) + #' xaxis_ticks(FALSE) + #' panel_bg(fill = "gray20") #' +#' # get the data frames used to make the ggplots #' ppc_dat <- ppc_intervals_data(y, yrep, x = year, prob = 0.5) #' ppc_group_dat <- ppc_intervals_data(y, yrep, x = year, group = group, prob = 0.5) #' @@ -84,12 +92,15 @@ #' yrep <- posterior_predict(fit) #' #' color_scheme_set("purple") -#' with(mtcars, ppc_intervals(mpg, yrep, x = wt, prob = 0.5)) + +#' ppc_intervals(y = mtcars$mpg, yrep = yrep, x = mtcars$wt, prob = 0.8) + #' panel_bg(fill="gray90", color = NA) + #' grid_lines(color = "white") #' -#' ppc_intervals_grouped(y = mtcars$mpg, yrep, prob = 0.8, -#' x = mtcars$wt, group = mtcars$cyl) +#' ppc_ribbon(y = mtcars$mpg, yrep = yrep, x = mtcars$wt, +#' prob = 0.6, prob_outer = 0.8) +#' +#' ppc_ribbon_grouped(y = mtcars$mpg, yrep = yrep, x = mtcars$wt, +#' group = mtcars$cyl) #' #' #' color_scheme_set("gray") @@ -98,7 +109,8 @@ #' labels = rownames(mtcars), #' breaks = 1:nrow(mtcars) #' ) + -#' xaxis_text(angle = -70, vjust = 1, hjust = 0) +#' xaxis_text(angle = -70, vjust = 1, hjust = 0) + +#' xaxis_title(FALSE) #' #' } #' @@ -107,316 +119,219 @@ NULL #' @rdname PPC-intervals #' @export -ppc_intervals <- function(y, yrep, x = NULL, ..., prob = 0.5, prob_outer = 0.9, - size = 1, fatten = 3) { - check_ignored_arguments(...) - - data <- ppc_intervals_data( - y = y, - yrep = yrep, - x = x, - group = NULL, - prob = prob, - prob_outer = prob_outer - ) - - .ppc_intervals( - data = data, - size = size, - fatten = fatten, - grouped = FALSE, - style = "intervals", - x_lab = label_x(x) - ) -} - -#' @rdname PPC-intervals -#' @export -#' @template args-group -#' @param facet_args An optional list of arguments (other than `facets`) -#' passed to [ggplot2::facet_wrap()] to control faceting. -#' -ppc_intervals_grouped <- function(y, - yrep, - x = NULL, - group, - ..., - facet_args = list(), - prob = 0.5, - prob_outer = 0.9, - size = 1, - fatten = 3) { - check_ignored_arguments(...) - - data <- ppc_intervals_data( - y = y, - yrep = yrep, - x = x, - group = group, - prob = prob, - prob_outer = prob_outer - ) - - facet_args[["scales"]] <- facet_args[["scales"]] %||% "free" - - .ppc_intervals( - data = data, - facet_args = facet_args, - size = size, - fatten = fatten, - grouped = TRUE, - style = "intervals", - x_lab = label_x(x) - ) -} - - -#' @rdname PPC-intervals -#' @export -#' @param y_draw For ribbon plots only, a string specifying how to draw `y`. Can -#' be `"line"` (the default), `"points"`, or `"both"`. -ppc_ribbon <- function(y, - yrep, - x = NULL, - ..., - prob = 0.5, - prob_outer = 0.9, - alpha = 0.33, - size = 0.25, - y_draw = c("line", "points", "both")) { - check_ignored_arguments(...) - - data <- ppc_intervals_data( - y = y, - yrep = yrep, - x = x, - group = NULL, - prob = prob - ) - - .ppc_intervals( - data = data, - alpha = alpha, - size = size, - grouped = FALSE, - style = "ribbon", - x_lab = label_x(x), - y_draw = y_draw - ) -} - - -#' @export -#' @rdname PPC-intervals -ppc_ribbon_grouped <- function(y, - yrep, - x = NULL, - group, - ..., - facet_args = list(), - prob = 0.5, - prob_outer = 0.9, - alpha = 0.33, - size = 0.25, - y_draw = c("line", "points", "both")) { - check_ignored_arguments(...) +ppc_intervals <- + function(y, + yrep, + x = NULL, + ..., + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 1, + fatten = 2.5) { - data <- ppc_intervals_data( - y = y, - yrep = yrep, - x = x, - group = group, - prob = prob, - prob_outer = prob_outer - ) + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } - facet_args[["scales"]] <- facet_args[["scales"]] %||% "free" + data <- + ppc_intervals_data( + y = y, + yrep = yrep, + x = x, + group = dots$group, + prob = prob, + prob_outer = prob_outer + ) - .ppc_intervals( - data = data, - facet_args = facet_args, - alpha = alpha, - size = size, - grouped = TRUE, - style = "ribbon", - x_lab = label_x(x), - y_draw = y_draw - ) -} + ggplot(data) + + intervals_inner_aes( + needs_y = TRUE, + color = "yrep", + fill = "yrep" + ) + + geom_linerange( + mapping = intervals_outer_aes(color = "yrep"), + alpha = alpha, + size = size + ) + + geom_pointrange( + shape = 21, + stroke = 0.5, + size = size, + fatten = fatten + ) + + geom_point( + mapping = aes_( + y = ~ y_obs, + color = "y", + fill = "y" + ), + shape = 21, + stroke = 0.5, + size = 1 + ) + + scale_color_ppc() + + scale_fill_ppc() + + intervals_axis_labels(has_x = !is.null(x)) + + bayesplot_theme_get() + } #' @rdname PPC-intervals #' @export -ppc_intervals_data <- function(y, yrep, x = NULL, group = NULL, - ..., prob = 0.5, prob_outer = 0.9) { - check_ignored_arguments(...) - .ppc_intervals_data(y = y, yrep = yrep, x = x, group = group, - prob = prob, prob_outer = prob_outer) -} +ppc_intervals_grouped <- + function(y, + yrep, + x = NULL, + group, + ..., + facet_args = list(), + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 1, + fatten = 2.5) { + check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppc_intervals", call), parent.frame()) + g + + intervals_group_facets(facet_args) + + force_axes_in_facets() + } #' @rdname PPC-intervals #' @export -ppc_ribbon_data <- ppc_intervals_data - - - - -# internal ---------------------------------------------------------------- -label_x <- function(x) { - if (missing(x)) "Index" else NULL -} - -.ppc_intervals_data <- function(y, yrep, x = NULL, group = NULL, - prob = 0.5, prob_outer = 0.9) { - grouped <- !is.null(group) - stopifnot(prob > 0 && prob < 1) - stopifnot(prob_outer > 0 && prob_outer <= 1) - probs <- sort(c(prob, prob_outer)) - prob <- probs[1] - prob_outer <- probs[2] - - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - x <- validate_x(x, y) - - long_d <- melt_and_stack(y, yrep) - long_d$x <- x[long_d$y_id] - long_d$y_obs <- y[long_d$y_id] - - molten_reps <- long_d[!as.logical(long_d[["is_y"]]), , drop = FALSE] - molten_reps$is_y <- NULL - - if (grouped) { - group <- validate_group(group, y) - molten_reps$group <- group[molten_reps$y_id] - group_vars <- syms(c("y_id", "y_obs", "group", "x")) - } else { - group_vars <- syms(c("y_id", "y_obs", "x")) - } - - grouped_d <- dplyr::group_by(molten_reps, !!! group_vars) - alpha <- (1 - probs) / 2 - probs <- sort(c(alpha, 0.5, 1 - alpha)) - - val_col <- sym("value") - dplyr::ungroup(dplyr::summarise( - grouped_d, - outer_width = prob_outer, - inner_width = prob, - ll = unname(quantile(!! val_col, probs = probs[1])), - l = unname(quantile(!! val_col, probs = probs[2])), - m = unname(quantile(!! val_col, probs = probs[3])), - h = unname(quantile(!! val_col, probs = probs[4])), - hh = unname(quantile(!! val_col, probs = probs[5])) - )) -} - -# Make intervals or ribbon plot -# -# @param data The object returned by .ppc_intervals_data -# @return A ggplot object -# -.ppc_intervals <- - function(data, - facet_args = list(), +#' @param y_draw For ribbon plots only, a string specifying how to draw `y`. Can +#' be `"line"` (the default), `"points"`, or `"both"`. +ppc_ribbon <- + function(y, + yrep, + x = NULL, + ..., + prob = 0.5, + prob_outer = 0.9, alpha = 0.33, - fatten = 3, - size = 1, - grouped = FALSE, - style = c("intervals", "ribbon"), - x_lab = NULL, + size = 0.25, y_draw = c("line", "points", "both")) { - style <- match.arg(style) - y_draw <- match.arg(y_draw) + y_draw <- match.arg(y_draw) + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } - graph <- ggplot( - data = data, - mapping = aes_( - x = ~ x, - y = ~ m, - ymin = ~ l, - ymax = ~ h - ) - ) + data <- + ppc_intervals_data( + y = y, + yrep = yrep, + x = x, + group = dots$group, + prob = prob, + prob_outer = prob_outer + ) - if (style == "ribbon") { - graph <- graph + + g <- ggplot(data) + + intervals_inner_aes(fill = "yrep", color = "yrep") + geom_ribbon( - aes_(color = "yrep", fill = "yrep", ymin = ~ ll, ymax = ~ hh), - alpha = alpha, - size = size + mapping = intervals_outer_aes(fill = "yrep", color = "yrep"), + color = NA, + size = 0.2 * size, + alpha = alpha ) + geom_ribbon( - aes_(color = "yrep", fill = "yrep"), - alpha = alpha, - size = size + mapping = intervals_outer_aes(), + fill = NA, + color = get_color("m"), + size = 0.2 * size, + alpha = 1 ) + + geom_ribbon(size = 0.5 * size) + geom_line( - aes_(color = "yrep"), - size = size/2 + mapping = aes_(y = ~ m), + color = get_color("m"), + size = size ) + geom_blank(aes_(fill = "y")) if (y_draw == "line" || y_draw == "both") { - graph <- graph + geom_line( + g <- g + geom_line( aes_(y = ~ y_obs, color = "y"), size = 0.5 ) } if (y_draw == "points" || y_draw == "both") { - graph <- graph + geom_point( + g <- g + geom_point( mapping = aes_(y = ~ y_obs, color = "y", fill = "y"), shape = 21, size = 1.5 ) } - } else { - graph <- graph + - geom_pointrange( - mapping = aes_(color = "yrep", fill = "yrep", ymin = ~ ll, ymax = ~ hh), - shape = 21, - alpha = alpha, - size = size, - fatten = fatten - ) + - geom_pointrange( - mapping = aes_(color = "yrep", fill = "yrep"), - shape = 21, - size = size, - fatten = fatten - ) + - geom_point( - mapping = aes_(y = ~ y_obs, color = "y", fill = "y"), - shape = 21, - size = 1.5 - ) + g + + scale_color_ppc() + + scale_fill_ppc(values = c(NA, get_color("l")), na.value = NA) + + intervals_axis_labels(has_x = !is.null(x)) + + bayesplot_theme_get() } - graph <- graph + - scale_color_manual( - name = "", - values = set_names(get_color(c("lh", "dh")), c("yrep", "y")), - labels = c(yrep = yrep_label(), y = y_label()) - ) + - scale_fill_manual( - name = "", - values = c(yrep = get_color("l"), - y = if (style == "ribbon") NA else get_color("d")), - labels = c(yrep = yrep_label(), y = y_label()) - ) +#' @export +#' @rdname PPC-intervals +ppc_ribbon_grouped <- + function(y, + yrep, + x = NULL, + group, + ..., + facet_args = list(), + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 0.25, + y_draw = c("line", "points", "both")) { + check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppc_ribbon", call), parent.frame()) + g + + intervals_group_facets(facet_args) + + force_axes_in_facets() + } - if (grouped) { - facet_args[["facets"]] <- "group" - facet_args[["scales"]] <- facet_args[["scales"]] %||% "free" - graph <- graph + do.call("facet_wrap", facet_args) + +#' @rdname PPC-intervals +#' @export +ppc_intervals_data <- + function(y, + yrep, + x = NULL, + group = NULL, + ..., + prob = 0.5, + prob_outer = 0.9) { + check_ignored_arguments(...) + + y <- validate_y(y) + yrep <- validate_predictions(yrep, length(y)) + x <- validate_x(x, y) + if (!is.null(group)) { + group <- validate_group(group, length(y)) + } + .ppd_intervals_data( + predictions = yrep, + y = y, + x = x, + group = group, + prob = prob, + prob_outer = prob_outer + ) } - graph + - labs(y = NULL, x = x_lab %||% expression(italic(x))) + - bayesplot_theme_get() -} +#' @rdname PPC-intervals +#' @export +ppc_ribbon_data <- ppc_intervals_data diff --git a/R/ppc-loo.R b/R/ppc-loo.R index 005bc7b3..a4545c53 100644 --- a/R/ppc-loo.R +++ b/R/ppc-loo.R @@ -72,14 +72,15 @@ #' + (1 + floor | county), #' data = radon, #' iter = 1000, -#' chains = 2 # ,cores = 2 +#' chains = 2, +#' cores = 2 #' ) #' y <- radon$log_radon #' yrep <- posterior_predict(fit) #' -#' loo1 <- loo(fit, save_psis = TRUE, cores = 2) +#' loo1 <- loo(fit, save_psis = TRUE, cores = 4) #' psis1 <- loo1$psis_object -#' lw <- weights(psis1) +#' lw <- weights(psis1) # normalized log weights #' #' # marginal predictive check using LOO probability integral transform #' color_scheme_set("orange") @@ -234,17 +235,17 @@ ppc_loo_pit_overlay <- function(y, ) } - p + - scale_color_ppc_dist(labels = c("PIT", "Unif")) + - scale_y_continuous( - limits = c(0, NA), - expand = expansion(mult = c(0, .25)) - ) + - bayesplot_theme_get() + - yaxis_title(FALSE) + - xaxis_title(FALSE) + - yaxis_text(FALSE) + - yaxis_ticks(FALSE) + p + + scale_color_ppc(labels = c("PIT", "Unif")) + + scale_y_continuous( + limits = c(0, NA), + expand = expansion(mult = c(0, .25)) + ) + + bayesplot_theme_get() + + yaxis_title(FALSE) + + xaxis_title(FALSE) + + yaxis_text(FALSE) + + yaxis_ticks(FALSE) } #' @rdname PPC-loo @@ -265,7 +266,7 @@ ppc_loo_pit_data <- } else { suggested_package("rstantools") y <- validate_y(y) - yrep <- validate_yrep(yrep, y) + yrep <- validate_predictions(yrep, length(y)) stopifnot(identical(dim(yrep), dim(lw))) pit <- rstantools::loo_pit(object = yrep, y = y, lw = lw) } @@ -290,7 +291,6 @@ ppc_loo_pit_data <- data } - #' @rdname PPC-loo #' @export ppc_loo_pit_qq <- function(y, @@ -310,7 +310,7 @@ ppc_loo_pit_qq <- function(y, } else { suggested_package("rstantools") y <- validate_y(y) - yrep <- validate_yrep(yrep, y) + yrep <- validate_predictions(yrep, length(y)) stopifnot(identical(dim(yrep), dim(lw))) pit <- rstantools::loo_pit(object = yrep, y = y, lw = lw) } @@ -369,8 +369,6 @@ ppc_loo_pit <- } - - #' @rdname PPC-loo #' @export #' @template args-prob-prob_outer @@ -408,8 +406,9 @@ ppc_loo_intervals <- ..., prob = 0.5, prob_outer = 0.9, + alpha = 0.33, size = 1, - fatten = 3, + fatten = 2.5, order = c("index", "median")) { check_ignored_arguments(...) @@ -426,7 +425,7 @@ ppc_loo_intervals <- } } else { suggested_package("loo", min_version = "2.0.0") - yrep <- validate_yrep(yrep, y) + yrep <- validate_predictions(yrep, length(y)) if (!is.null(subset)) { stopifnot(length(y) >= length(subset)) y <- y[subset] @@ -448,24 +447,46 @@ ppc_loo_intervals <- if (order_by_median) { x <- reorder(x, intervals[, 2]) } - - graph <- .ppc_intervals( - data = .loo_intervals_data(y, x, intervals), - grouped = FALSE, - style = "intervals", - size = size, - fatten = fatten, - x_lab = "Data point (index)" - ) - - if (!order_by_median) { - return(graph) + xy_labs <- if (order_by_median) { + labs(x = "Ordered by median", y = NULL) + } else { + intervals_axis_labels(has_x = FALSE) } - graph + - xlab("Ordered by median") + - xaxis_text(FALSE) + - xaxis_ticks(FALSE) + data <- .loo_intervals_data(y, x, intervals) + ggplot(data) + + intervals_inner_aes( + needs_y = TRUE, + color = "yrep", + fill = "yrep" + ) + + geom_linerange( + mapping = intervals_outer_aes(color = "yrep"), + alpha = alpha, + size = size + ) + + geom_pointrange( + shape = 21, + stroke = 0.5, + size = size, + fatten = fatten + ) + + geom_point( + mapping = aes_( + y = ~ y_obs, + color = "y", + fill = "y" + ), + shape = 21, + stroke = 0.5, + size = 1 + ) + + scale_color_ppc() + + scale_fill_ppc() + + bayesplot_theme_get() + + xy_labs + + xaxis_text(!order_by_median) + + xaxis_ticks(!order_by_median) } #' @rdname PPC-loo @@ -495,7 +516,7 @@ ppc_loo_ribbon <- } } else { suggested_package("loo", min_version = "2.0.0") - yrep <- validate_yrep(yrep, y) + yrep <- validate_predictions(yrep, length(y)) if (!is.null(subset)) { stopifnot(length(y) >= length(subset)) y <- y[subset] @@ -512,14 +533,38 @@ ppc_loo_ribbon <- probs = sort(c(a, 0.5, 1 - a)) )$value)) } - .ppc_intervals( - data = .loo_intervals_data(y, x = seq_along(y), intervals), - grouped = FALSE, - style = "ribbon", - size = size, - alpha = alpha, - x_lab = "Data point (index)" - ) + + data <- .loo_intervals_data(y, x = seq_along(y), intervals) + ggplot(data) + + intervals_inner_aes(fill = "yrep", color = "yrep") + + geom_ribbon( + mapping = intervals_outer_aes(fill = "yrep", color = "yrep"), + alpha = alpha, + size = 0.05 + ) + + geom_ribbon( + mapping = intervals_outer_aes(), + alpha = 1, + size = 0.05, + fill = NA, + color = get_color("m") + ) + + geom_ribbon(size = 0.05) + + geom_line( + mapping = aes_(y = ~ m), + color = get_color("m"), + size = size + ) + + geom_blank(aes_(fill = "y")) + + geom_line( + aes_(y = ~ y_obs, color = "y"), + size = 0.5, + alpha = 2/3 + ) + + scale_color_ppc() + + scale_fill_ppc(values = c(NA, get_color("l"))) + + intervals_axis_labels(has_x = FALSE) + + bayesplot_theme_get() } @@ -528,7 +573,7 @@ ppc_loo_ribbon <- .loo_intervals_data <- function(y, x, intervals) { stopifnot(length(y) == nrow(intervals), length(x) == length(y)) - data.frame( + tibble::tibble( y_id = seq_along(y), y_obs = y, x = x, @@ -540,6 +585,7 @@ ppc_loo_ribbon <- } # subset a psis_object without breaking it +# (FIXME: use function from loo package when subset.psis() method becomes available) .psis_subset <- function(psis_object, subset) { stopifnot(all(subset == as.integer(subset))) if (length(subset) > dim(psis_object)[2]) { diff --git a/R/ppc-overview.R b/R/ppc-overview.R index 051ee691..41cd0208 100644 --- a/R/ppc-overview.R +++ b/R/ppc-overview.R @@ -4,18 +4,19 @@ #' @aliases PPC #' @family PPCs #' -#' @description -#' The **bayesplot** PPC module provides various plotting functions for creating -#' graphical displays comparing observed data to simulated data from the -#' posterior (or prior) predictive distribution. See below for a brief -#' discussion of the ideas behind posterior predictive checking, a description -#' of the structure of this package, and tips on providing an interface to -#' **bayesplot** from another package. -#' -#' @details -#' The idea behind posterior predictive checking is simple: if a model is a good -#' fit then we should be able to use it to generate data that looks a lot like -#' the data we observed. +#' @description The **bayesplot** PPC module provides various plotting functions +#' for creating graphical displays comparing observed data to simulated data +#' from the posterior (or prior) predictive distribution. See the sections +#' below for a brief discussion of the ideas behind posterior predictive +#' checking, an overview of the available PPC plots, and tips on providing an +#' interface to **bayesplot** from another package. +#' +#' For plots of posterior (or prior) predictive distributions that do _not_ +#' include observed data see [PPD-overview] instead. +#' +#' @details The idea behind posterior predictive checking is simple: if a model +#' is a good fit then we should be able to use it to generate data that looks +#' a lot like the data we observed. #' #' \subsection{Posterior predictive distribution}{ #' To generate the data used for posterior predictive checks we simulate from @@ -56,38 +57,45 @@ #' distribution. See Gabry et al. (2019) for more on prior predictive checking #' and when it is reasonable to compare the prior predictive distribution to the #' observed data. If you want to avoid using the observed data for prior -#' predictive checks, then the `y` argument to the PPC plotting functions can be -#' used to provide plausible or implausible `y` values that you want to compare -#' to the prior predictive realizations. +#' predictive checks then you can use the **bayesplot** [PPD] plots instead, +#' which do not take a `y` argument, or you can use the PPC plots but provide +#' plausible or implausible `y` values that you want to compare to the prior +#' predictive realizations. #' } #' #' @section PPC plotting functions: The plotting functions for prior and -#' posterior predictive checking are organized into several categories, each -#' with its own documentation: -#' * [Distributions][PPC-distributions]: Histograms, kernel density -#' estimates, boxplots, and other plots comparing the empirical distribution -#' of data `y` to the distributions of individual simulated datasets (rows) -#' in `yrep`. -#' * [Statistics][PPC-test-statistics]: The distribution of a statistic, -#' or a pair of statistics, over the simulated datasets (rows) in `yrep` -#' compared to value of the statistic(s) computed from `y`. -#' * [Intervals][PPC-intervals]: Interval estimates of `yrep` with `y` +#' posterior predictive checking all have the prefix `ppc_` and all require +#' the arguments `y`, a vector of observations, and `yrep`, a matrix of +#' replications (in-sample predictions). The plots are organized into several +#' categories, each with its own documentation: +#' * [PPC-distributions]: Histograms, kernel density estimates, boxplots, and +#' other plots comparing the empirical distribution of data `y` to the +#' distributions of individual simulated datasets (rows) in `yrep`. +#' +#' * [PPC-test-statistics]: The distribution of a statistic, or a pair of +#' statistics, over the simulated datasets (rows) in `yrep` compared to value of +#' the statistic(s) computed from `y`. +#' +#' * [PPC-intervals]: Interval estimates of `yrep` with `y` #' overlaid. The x-axis variable can be optionally specified by the user #' (e.g. to plot against a predictor variable or over time). -#' * [Predictive errors][PPC-errors]: Plots of predictive errors -#' (`y - yrep`) computed from `y` and each of the simulated datasets (rows) -#' in `yrep`. For binomial models binned error plots are also available. -#' * [Scatterplots][PPC-scatterplots]: Scatterplots (and similar -#' visualizations) of the data `y` vs. individual simulated datasets -#' (rows) in `yrep`, or vs. the average value of the distributions of each -#' data point (columns) in `yrep`. -#' * [Plots for discrete outcomes][PPC-discrete]: PPC functions that can -#' only be used if `y` and `yrep` are discrete. For example, rootograms for -#' count outcomes and bar plots for ordinal, categorical, and -#' multinomial outcomes. -#' * [LOO predictive checks][PPC-loo]: PPC functions for predictive checks -#' based on (approximate) leave-one-out (LOO) cross-validation. -#' * [Censored data][PPC-censoring]: PPC functions comparing the empirical +#' +#' * [PPC-errors]: Plots of predictive errors (`y - yrep`) computed from `y` and +#' each of the simulated datasets (rows) in `yrep`. For binomial models binned +#' error plots are also available. +#' +#' * [PPC-scatterplots]: Scatterplots (and similar visualizations) of the data +#' `y` vs. individual simulated datasets (rows) in `yrep`, or vs. the average +#' value of the distributions of each data point (columns) in `yrep`. +#' +#' * [PPC-discrete]: PPC functions that can only be used if `y` and `yrep` are +#' discrete. For example, rootograms for count outcomes and bar plots for +#' ordinal, categorical, and multinomial outcomes. +#' +#' * [PPC-loo]: PPC functions for predictive checks based on (approximate) +#' leave-one-out (LOO) cross-validation. +#'' +#' * [PPC-censoring]: PPC functions comparing the empirical #' distribution of censored data `y` to the distributions of individual #' simulated datasets (rows) in `yrep`. #' diff --git a/R/ppc-scatterplots.R b/R/ppc-scatterplots.R index 277dfaf8..ad19f7e0 100644 --- a/R/ppc-scatterplots.R +++ b/R/ppc-scatterplots.R @@ -8,12 +8,16 @@ #' @family PPCs #' #' @template args-y-yrep +#' @template args-group +#' @template args-facet_args #' @param ... Currently unused. #' @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 +#' slope 1 is drawn behind the scatter plot. #' #' @template details-binomial -#' @template return-ggplot +#' @template return-ggplot-or-data #' #' @templateVar bdaRef (Ch. 6) #' @template reference-bda @@ -26,9 +30,11 @@ #' small number of rows. #' } #' \item{`ppc_scatter_avg()`}{ -#' A scatterplot of `y` against the average values of `yrep`, i.e., -#' the points `(mean(yrep[, n]), y[n])`, where each `yrep[, n]` is -#' a vector of length equal to the number of posterior draws. +#' 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). #' } #' \item{`ppc_scatter_avg_grouped()`}{ #' The same as `ppc_scatter_avg()`, but a separate plot is generated for @@ -41,6 +47,10 @@ #' yrep <- example_yrep_draws() #' p1 <- ppc_scatter_avg(y, yrep) #' p1 +#' +#' # don't draw line x=y +#' ppc_scatter_avg(y, yrep, ref_line = FALSE) +#' #' p2 <- ppc_scatter(y, yrep[20:23, ], alpha = 0.5, size = 1.5) #' p2 #' @@ -49,139 +59,172 @@ #' p1 + lims #' p2 + lims #' +#' # for ppc_scatter_avg_grouped the default is to allow the facets +#' # to have different x and y axes #' group <- example_group_data() -#' ppc_scatter_avg_grouped(y, yrep, group, alpha = 0.7) + lims +#' ppc_scatter_avg_grouped(y, yrep, group) +#' +#' # let x-axis vary but force y-axis to be the same +#' ppc_scatter_avg_grouped(y, yrep, group, facet_args = list(scales = "free_x")) #' NULL -#' @export #' @rdname PPC-scatterplots -#' +#' @export ppc_scatter <- function(y, yrep, ..., + facet_args = list(), size = 2.5, - alpha = 0.8) { + alpha = 0.8, + ref_line = TRUE) { check_ignored_arguments(...) - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - graph <- .ppc_scatter( - data = data.frame( - melt_yrep(yrep), - y = rep(y, each = nrow(yrep)) - ), - mapping = aes_(x = ~ value, y = ~ y), - y_lab = y_label(), - x_lab = yrep_label(), - alpha = alpha, - size = size - ) - if (nrow(yrep) == 1) - return(graph) + data <- ppc_scatter_data(y, yrep) + if (nrow(yrep) == 1) { + facet_layer <- geom_ignore() + } else { + facet_args[["facets"]] <- "rep_label" + facet_layer <- do.call("facet_wrap_parsed", facet_args) + } - graph + - facet_wrap_parsed("rep_id") + + ggplot(data, scatter_aes(color = "yrep", fill = "yrep")) + + scatter_ref_line(ref_line) + + geom_point( + size = size, + alpha = alpha, + shape = 21, + show.legend = FALSE + ) + + # use ppd color scale since only need one color + # (and legend is off so no label modification needed) + scale_color_ppd() + + scale_fill_ppd() + + bayesplot_theme_get() + + facet_layer + + labs(x = yrep_label(), y = y_label()) + force_axes_in_facets() + facet_text(FALSE) + - facet_bg(FALSE) + legend_none() } -#' @export + #' @rdname PPC-scatterplots -#' +#' @export ppc_scatter_avg <- function(y, yrep, ..., size = 2.5, - alpha = 0.8) { - check_ignored_arguments(...) + alpha = 0.8, + ref_line = TRUE) { + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - if (nrow(yrep) == 1) - return(ppc_scatter(y, yrep, size = size, alpha = alpha, ...)) - - .ppc_scatter( - data = data.frame(y, avg_y_rep = colMeans(yrep)), - mapping = aes_(x = ~ avg_y_rep, y = ~ y), - y_lab = y_label(), - x_lab = yrep_avg_label(), - alpha = alpha, - size = size - ) + data <- ppc_scatter_avg_data(y, yrep, group = dots$group) + if (is.null(dots$group) && nrow(yrep) == 1) { + inform( + "With only 1 row in 'yrep' ppc_scatter_avg is the same as ppc_scatter." + ) + } + + ggplot(data, scatter_aes(color = "yrep", fill = "yrep")) + + scatter_ref_line(ref_line) + + geom_point( + alpha = alpha, + size = size, + shape = 21, + show.legend = FALSE + ) + + # ppd instead of ppc (see comment in ppc_scatter) + scale_color_ppd() + + scale_fill_ppd() + + labs(x = yrep_avg_label(), y = y_label()) + + bayesplot_theme_get() } -#' @export + #' @rdname PPC-scatterplots -#' @template args-group -#' +#' @export ppc_scatter_avg_grouped <- function(y, yrep, group, ..., + facet_args = list(), size = 2.5, - alpha = 0.8) { + alpha = 0.8, + ref_line = TRUE) { check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppc_scatter_avg", call), parent.frame()) + g + + scatter_avg_group_facets(facet_args) + + force_axes_in_facets() + } - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - ggplot( - data = data.frame( - y = y, - avg_yrep = colMeans(yrep), - group = validate_group(group, y) - ), - mapping = aes_(x = ~ avg_yrep, y = ~ y, group = ~ group) - ) + - geom_point( - shape = 21, - fill = get_color("m"), - color = get_color("mh"), - alpha = alpha, - size = size - ) + - labs( - y = y_label(), - x = yrep_avg_label() - ) + - facet_wrap("group", scales = "free") + - bayesplot_theme_get() + +#' @rdname PPC-scatterplots +#' @export +ppc_scatter_data <- function(y, yrep) { + y <- validate_y(y) + yrep <- validate_predictions(yrep, length(y)) + melt_predictions(yrep) %>% + dplyr::arrange(.data$y_id) %>% + tibble::add_column( + y_obs = rep(y, each = nrow(yrep)), + .before = "rep_id" + ) +} + + +#' @rdname PPC-scatterplots +#' @export +ppc_scatter_avg_data <- function(y, yrep, group = NULL) { + 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$rep_id <- NA_integer_ + levels(data$rep_label) <- "mean(italic(y)[rep]))" -# internal ----------------------------------------------------------------- -.ppc_scatter <- - function(data, - mapping, - x_lab = "", - y_lab = "", - color = c("mid", "light"), - size = 2.5, - alpha = 1, - abline = TRUE) { - mid <- isTRUE(match.arg(color) == "mid") - graph <- ggplot(data, mapping) - if (abline) { - graph <- graph + - geom_abline( - intercept = 0, - slope = 1, - linetype = 2, - color = get_color("dh") - ) + if (!is.null(group)) { + data <- tibble::add_column(data, + group = group[data$y_id], + .before = "y_id" + ) + } + + data +} + +# internal ---------------------------------------------------------------- +yrep_avg_label <- function() expression(paste("Average ", italic(y)[rep])) + +scatter_aes <- function(...) { + aes_(x = ~ value, y = ~ y_obs, ...) +} + +scatter_avg_group_facets <- function(facet_args) { + facet_args[["facets"]] <- "group" + facet_args[["scales"]] <- facet_args[["scales"]] %||% "free" + do.call("facet_wrap", facet_args) +} + +scatter_ref_line <- + function(ref_line, + linetype = 2, + color = get_color("dh"), + ...) { + if (!ref_line) { + return(geom_ignore()) } - graph + - geom_point( - shape = 21, - fill = get_color(ifelse(mid, "m", "l")), - color = get_color(ifelse(mid, "mh", "lh")), - size = size, - alpha = alpha - ) + - labs(x = x_lab, y = y_lab) + - bayesplot_theme_get() + abline_01(linetype = 2, color = get_color("dh"), ...) } diff --git a/R/ppc-test-statistics.R b/R/ppc-test-statistics.R index 1246c1ca..6ae84cb2 100644 --- a/R/ppc-test-statistics.R +++ b/R/ppc-test-statistics.R @@ -7,20 +7,24 @@ #' well as [Gabry et al. (2019)](https://github.com/jgabry/bayes-vis-paper#readme). #' #' @name PPC-test-statistics +#' @aliases PPC-statistics #' @family PPCs #' #' @template args-y-yrep +#' @template args-group #' @template args-facet_args -#' @param stat A single function or a string naming a function, except for -#' `ppc_stat_2d()` which requires a vector of exactly two functions or -#' function names. In all cases the function(s) should take a vector input and -#' return a scalar statistic. If specified as a string (or strings) then -#' the legend will display function names. If specified as a function (or -#' functions) then generic naming is used in the legend. +#' @template args-hist +#' @template args-hist-freq +#' @param stat A single function or a string naming a function, except for the +#' 2D plot which requires a vector of exactly two names or functions. In all +#' cases the function(s) should take a vector input and return a scalar +#' statistic. If specified as a string (or strings) then the legend will +#' display the function name(s). If specified as a function (or functions) +#' then generic naming is used in the legend. #' @param ... Currently unused. #' #' @template details-binomial -#' @template return-ggplot +#' @template return-ggplot-or-data #' #' @template reference-vis-paper #' @templateVar bdaRef (Ch. 6) @@ -28,21 +32,20 @@ #' #' @section Plot Descriptions: #' \describe{ -#' \item{`ppc_stat()`}{ -#' A histogram of the distribution of a test statistic computed by applying -#' `stat` to each dataset (row) in `yrep`. The value of the statistic in the -#' observed data, `stat(y)`, is overlaid as a vertical line. More details on -#' `ppc_stat()` can be found in Gabry et al. (2019). +#' \item{`ppc_stat()`, `ppc_stat_freqpoly()`}{ +#' A histogram or frequency polygon of the distribution of a statistic +#' computed by applying `stat` to each dataset (row) in `yrep`. The value of +#' the statistic in the observed data, `stat(y)`, is overlaid as a vertical +#' line. More details and example usage of `ppc_stat()` can be found in Gabry +#' et al. (2019). #' } #' \item{`ppc_stat_grouped()`,`ppc_stat_freqpoly_grouped()`}{ -#' The same as `ppc_stat()`, but a separate plot is generated for each -#' level of a grouping variable. In the case of -#' `ppc_stat_freqpoly_grouped()` the plots are frequency polygons rather -#' than histograms. More details on `ppc_stat_grouped()` can be found in -#' Gabry et al. (2019). +#' The same as `ppc_stat()` and `ppc_stat_freqpoly()`, but a separate plot is +#' generated for each level of a grouping variable. More details and example +#' usage of `ppc_stat_grouped()` can be found in Gabry et al. (2019). #' } #' \item{`ppc_stat_2d()`}{ -#' A scatterplot showing the joint distribution of two test statistics +#' A scatterplot showing the joint distribution of two statistics #' computed over the datasets (rows) in `yrep`. The value of the #' statistics in the observed data is overlaid as large point. #' } @@ -53,32 +56,46 @@ #' yrep <- example_yrep_draws() #' ppc_stat(y, yrep) #' ppc_stat(y, yrep, stat = "sd") + legend_none() -#' ppc_stat_2d(y, yrep) -#' ppc_stat_2d(y, yrep, stat = c("median", "mean")) + legend_move("bottom") #' +#' # use your own function for the 'stat' argument +#' color_scheme_set("brightblue") +#' q25 <- function(y) quantile(y, 0.25) +#' ppc_stat(y, yrep, stat = "q25") # legend includes function name +#' +#' # can define the function in the 'stat' argument instead of +#' # using its name but then the legend doesn't include the function name +#' ppc_stat(y, yrep, stat = function(y) quantile(y, 0.25)) +#' +#' # plots by group #' color_scheme_set("teal") #' group <- example_group_data() #' ppc_stat_grouped(y, yrep, group) +#' ppc_stat_grouped(y, yrep, group) + yaxis_text() #' -#' color_scheme_set("mix-red-blue") -#' ppc_stat_freqpoly_grouped(y, yrep, group, facet_args = list(nrow = 2)) +#' # force y-axes to have same scales, allow x axis to vary +#' ppc_stat_grouped(y, yrep, group, facet_args = list(scales = "free_x")) + yaxis_text() #' -#' # use your own function to compute test statistics -#' color_scheme_set("brightblue") -#' q25 <- function(y) quantile(y, 0.25) -#' ppc_stat(y, yrep, stat = "q25") # legend includes function name +#' # the freqpoly plots use frequency polygons instead of histograms +#' ppc_stat_freqpoly(y, yrep, stat = "median") +#' ppc_stat_freqpoly_grouped(y, yrep, group, stat = "median", facet_args = list(nrow = 2)) #' -#' # can define the function in the 'stat' argument but then -#' # the legend doesn't include a function name -#' ppc_stat(y, yrep, stat = function(y) quantile(y, 0.25)) +#' # ppc_stat_2d allows 2 statistics and makes a scatterplot +#' bayesplot_theme_set(ggplot2::theme_linedraw()) +#' color_scheme_set("viridisE") +#' ppc_stat_2d(y, yrep, stat = c("mean", "sd")) +#' +#' bayesplot_theme_set(ggplot2::theme_grey()) +#' color_scheme_set("brewer-Paired") +#' ppc_stat_2d(y, yrep, stat = c("median", "mad")) +#' +#' # reset aesthetics +#' color_scheme_set() +#' bayesplot_theme_set() #' NULL #' @rdname PPC-test-statistics #' @export -#' @template args-hist -#' @template args-hist-freq -#' ppc_stat <- function(y, yrep, @@ -87,16 +104,23 @@ ppc_stat <- binwidth = NULL, breaks = NULL, freq = TRUE) { - check_ignored_arguments(...) - - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - stat1 <- match.fun(stat) - T_y <- stat1(y) - T_yrep <- apply(yrep, 1, stat1) + stopifnot(length(stat) == 1) + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } - ggplot(data.frame(value = T_yrep), - set_hist_aes(freq)) + + data <- ppc_stat_data( + y = y, + yrep = yrep, + group = dots$group, + stat = match.fun(stat) + ) + ggplot( + data = dplyr::filter(data, .data$variable != "y"), + mapping = set_hist_aes(freq) + ) + geom_histogram( aes_(fill = "yrep"), color = get_color("lh"), @@ -106,12 +130,12 @@ ppc_stat <- breaks = breaks ) + geom_vline( - data = data.frame(Ty = T_y), - mapping = aes_(xintercept = ~ Ty, color = "y"), + data = dplyr::filter(data, .data$variable == "y"), + mapping = aes_(xintercept = ~ value, color = "y"), size = 1.5 ) + - scale_fill_manual(values = get_color("l"), labels = Tyrep_label()) + - scale_color_manual(values = get_color("dh"), labels = Ty_label()) + + scale_color_ppc(values = get_color("dh"), labels = Ty_label()) + + scale_fill_ppc(values = get_color("l"), labels = Tyrep_label()) + guides( color = guide_legend(title = NULL), fill = guide_legend( @@ -119,8 +143,8 @@ ppc_stat <- title = stat_legend_title(stat, deparse(substitute(stat))) ) ) + - bayesplot_theme_get() + dont_expand_y_axis() + + bayesplot_theme_get() + no_legend_spacing() + xaxis_title(FALSE) + yaxis_text(FALSE) + @@ -128,10 +152,9 @@ ppc_stat <- yaxis_title(FALSE) } -#' @export + #' @rdname PPC-test-statistics -#' @template args-group -#' +#' @export ppc_stat_grouped <- function(y, yrep, @@ -143,78 +166,42 @@ ppc_stat_grouped <- breaks = NULL, freq = TRUE) { check_ignored_arguments(...) - - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - group <- validate_group(group, y) - plot_data <- ppc_group_data(y, yrep, group, stat = match.fun(stat)) - is_y <- plot_data$variable == "y" - - facet_args[["facets"]] <- ~ group - if (is.null(facet_args[["scales"]])) - facet_args[["scales"]] <- "free" - - ggplot(plot_data[!is_y, , drop = FALSE], - set_hist_aes(freq)) + - geom_histogram( - aes_(fill = "yrep"), - color = get_color("lh"), - size = .25, - na.rm = TRUE, - binwidth = binwidth, - breaks = breaks - ) + - geom_vline( - data = plot_data[is_y, , drop = FALSE], - mapping = aes_(xintercept = ~ value, color = "y"), - size = 1.5 - ) + - do.call("facet_wrap", facet_args) + - scale_fill_manual(values = get_color("l"), labels = Tyrep_label()) + - scale_color_manual(values = get_color("dh"), labels = Ty_label()) + - guides( - color = guide_legend(title = NULL), - fill = guide_legend( - order = 1, - title = stat_legend_title(stat, deparse(substitute(stat))) - ) - ) + - bayesplot_theme_get() + - dont_expand_y_axis() + - no_legend_spacing() + - xaxis_title(FALSE) + - yaxis_text(FALSE) + - yaxis_ticks(FALSE) + - yaxis_title(FALSE) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppc_stat", call), parent.frame()) + g + + stat_group_facets(facet_args) + + force_axes_in_facets() } -#' @export #' @rdname PPC-test-statistics -#' -ppc_stat_freqpoly_grouped <- +#' @export +ppc_stat_freqpoly <- function(y, yrep, - group, stat = "mean", ..., facet_args = list(), binwidth = NULL, freq = TRUE) { - check_ignored_arguments(...) - - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) - group <- validate_group(group, y) - plot_data <- ppc_group_data(y, yrep, group, stat = match.fun(stat)) - is_y <- plot_data$variable == "y" + stopifnot(length(stat) == 1) + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } - facet_args[["facets"]] <- ~ group - if (is.null(facet_args[["scales"]])) - facet_args[["scales"]] <- "free" + data <- ppc_stat_data( + y = y, + yrep = yrep, + group = dots$group, + stat = match.fun(stat) + ) - ggplot(plot_data[!is_y, , drop = FALSE], - set_hist_aes(freq)) + + ggplot( + data = dplyr::filter(data, .data$variable != "y"), + mapping = set_hist_aes(freq) + ) + geom_freqpoly( aes_(color = "yrep"), size = .5, @@ -222,30 +209,49 @@ ppc_stat_freqpoly_grouped <- binwidth = binwidth ) + geom_vline( - data = plot_data[is_y, , drop = FALSE], + data = dplyr::filter(data, .data$variable == "y"), mapping = aes_(xintercept = ~ value, color = "y"), show.legend = FALSE, size = 1 ) + - do.call("facet_wrap", facet_args) + - scale_color_manual( + scale_color_ppc( name = stat_legend_title(stat, deparse(substitute(stat))), values = set_names(get_color(c("m", "dh")), c("yrep", "y")), labels = c(yrep = Tyrep_label(), y = Ty_label()) ) + dont_expand_y_axis(c(0.005, 0)) + + bayesplot_theme_get() + xaxis_title(FALSE) + yaxis_text(FALSE) + yaxis_ticks(FALSE) + - yaxis_title(FALSE) + - bayesplot_theme_get() + yaxis_title(FALSE) + } + + +#' @rdname PPC-test-statistics +#' @export +ppc_stat_freqpoly_grouped <- + function(y, + yrep, + group, + stat = "mean", + ..., + facet_args = list(), + binwidth = NULL, + freq = TRUE) { + check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppc_stat_freqpoly", call), parent.frame()) + g + + stat_group_facets(facet_args) + + force_axes_in_facets() } #' @rdname PPC-test-statistics #' @export -#' @param size,alpha Arguments passed to [ggplot2::geom_point()] to control the -#' appearance of scatterplot points. +#' @param size,alpha For the 2D plot only, arguments passed to +#' [ggplot2::geom_point()] to control the appearance of scatterplot points. ppc_stat_2d <- function(y, yrep, stat = c("mean", "sd"), @@ -255,8 +261,6 @@ ppc_stat_2d <- function(y, check_ignored_arguments(...) - y <- validate_y(y) - yrep <- validate_yrep(yrep, y) if (length(stat) != 2) { abort("For ppc_stat_2d the 'stat' argument must have length 2.") } @@ -269,53 +273,89 @@ ppc_stat_2d <- function(y, stat_labs <- expression(italic(T)[1], italic(T)[2]) } - stat1 <- match.fun(stat[[1]]) - stat2 <- match.fun(stat[[2]]) - T_y1 <- stat1(y) - T_y2 <- stat2(y) - T_yrep1 <- apply(yrep, 1, stat1) - T_yrep2 <- apply(yrep, 1, stat2) + data <- ppc_stat_data( + y = y, + yrep = yrep, + group = NULL, + stat = c(match.fun(stat[[1]]), match.fun(stat[[2]])) + ) + y_segment_data <- stat_2d_segment_data(data) + y_point_data <- data.frame( + x = y_segment_data[1, "x"], + y = y_segment_data[2, "y"] + ) - ggplot( - data = data.frame(x = T_yrep1, y = T_yrep2), - mapping = aes_(x = ~ x, y = ~ y) - ) + + ggplot(data) + geom_point( - aes_(fill = "yrep", color = "yrep"), + aes_( + x = ~ value, + y = ~ value2, + fill = "yrep", + color = "yrep" + ), shape = 21, size = size, alpha = alpha ) + - annotate( - geom = "segment", - x = c(T_y1, -Inf), xend = c(T_y1, T_y1), - y = c(-Inf, T_y2), yend = c(T_y2, T_y2), + geom_segment( + data = y_segment_data, + aes_( + x = ~ x, + y = ~ y, + xend = ~ xend, + yend = ~ yend, + color = "y" + ), linetype = 2, size = 0.4, - color = get_color("dh") + show.legend = FALSE ) + geom_point( - data = data.frame(x = T_y1, y = T_y2), - mapping = aes_(x = ~ x, y = ~ y, fill = "y", color = "y"), + data = y_point_data, + mapping = aes_( + x = ~ x, + y = ~ y, + fill = "y", + color = "y" + ), size = size * 1.5, shape = 21, stroke = 0.75 ) + - scale_fill_manual( - name = lgnd_title, - values = set_names(get_color(c("d", "l")), c("y", "yrep")), - labels = c(y = Ty_label(), yrep = Tyrep_label()) - ) + - scale_color_manual( - name = lgnd_title, - values = set_names(get_color(c("dh", "lh")), c("y", "yrep")), - labels = c(y = Ty_label(), yrep = Tyrep_label()) - ) + + scale_fill_ppc(lgnd_title, labels = c(Ty_label(), Tyrep_label())) + + scale_color_ppc(lgnd_title, labels = c(Ty_label(), Tyrep_label())) + labs(x = stat_labs[1], y = stat_labs[2]) + bayesplot_theme_get() } +#' @rdname PPC-test-statistics +#' @export +ppc_stat_data <- function(y, yrep, group = NULL, stat) { + if (!(length(stat) %in% 1:2)) { + abort("'stat' must have length 1 or 2.") + } + + y <- validate_y(y) + yrep <- validate_predictions(yrep, length(y)) + if (!is.null(group)) { + group <- validate_group(group, length(y)) + } + + if (length(stat) == 1) { + stat <- match.fun(stat) + } else { + stat <- list(match.fun(stat[[1]]), match.fun(stat[[2]])) + } + + .ppd_stat_data( + predictions = yrep, + y = y, + group = group, + stat = stat + ) +} + # internal ---------------------------------------------------------------- @@ -339,3 +379,23 @@ stat_legend_title <- function(stat, stat_txt) { bquote(italic(T) == .(lgnd_txt)) } + +#' Make data frame for geom_segment() for ppc_stat_2d() +#' @param data Data frame from `ppc_stat_data()`. +#' @return Data frame with two rows and four columns (`x`,`xend`,`y`,`yend`). +#' @noRd +stat_2d_segment_data <- function(data) { + y_data <- dplyr::filter(data, .data$variable == "y") + stats <- c(y_data$value[1], y_data$value2[1]) + data.frame( + x = c(stats[1], -Inf), + xend = c(stats[1], stats[1]), + y = c(-Inf, stats[2]), + yend = c(stats[2], stats[2]) + ) +} + + +Ty_label <- function() expression(italic(T(italic(y)))) +Tyrep_label <- function() expression(italic(T)(italic(y)[rep])) + diff --git a/R/ppd-distributions.R b/R/ppd-distributions.R new file mode 100644 index 00000000..95fb8c5b --- /dev/null +++ b/R/ppd-distributions.R @@ -0,0 +1,338 @@ +#' PPD distributions +#' +#' Plot posterior or prior predictive distributions. Each of these functions +#' makes the same plot as the corresponding [`ppc_`][PPC-distributions] function +#' but without plotting any observed data `y`. The **Plot Descriptions** section +#' at [PPC-distributions] has details on the individual plots. +#' +#' @name PPD-distributions +#' @family PPDs +#' +#' @template args-ypred +#' @inheritParams PPC-distributions +#' +#' @template details-binomial +#' @template return-ggplot-or-data +#' +#' @examples +#' # difference between ppd_dens_overlay() and ppc_dens_overlay() +#' color_scheme_set("brightblue") +#' preds <- example_yrep_draws() +#' ppd_dens_overlay(ypred = preds[1:50, ]) +#' ppc_dens_overlay(y = example_y_data(), yrep = preds[1:50, ]) +#' +NULL + +#' @rdname PPD-distributions +#' @export +ppd_data <- function(ypred, group = NULL) { + ypred <- validate_predictions(ypred) + if (!is.null(group)) { + group <- validate_group(group, n_obs = ncol(ypred)) + } + .ppd_data(predictions = ypred, y = NULL, group = group) +} + + +#' @rdname PPD-distributions +#' @export +ppd_dens_overlay <- + function(ypred, + ..., + size = 0.25, + alpha = 0.7, + trim = FALSE, + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + n_dens = 1024) { + check_ignored_arguments(...) + + data <- ppd_data(ypred) + ggplot(data, mapping = aes_(x = ~ value)) + + overlay_ppd_densities( + mapping = aes_(group = ~ rep_id, color = "ypred"), + size = size, + alpha = alpha, + trim = trim, + bw = bw, + adjust = adjust, + kernel = kernel, + n = n_dens + ) + + scale_color_ppd( + values = get_color("m"), + guide = guide_legend( # in case user turns legend back on + override.aes = list(size = 2 * size, alpha = 1)) + ) + + bayesplot_theme_get() + + dont_expand_axes() + + yaxis_title(FALSE) + + xaxis_title(FALSE) + + yaxis_text(FALSE) + + yaxis_ticks(FALSE) + + legend_none() + } + + +#' @rdname PPD-distributions +#' @export +ppd_ecdf_overlay <- + function(ypred, + ..., + discrete = FALSE, + pad = TRUE, + size = 0.25, + alpha = 0.7) { + check_ignored_arguments(...) + + data <- ppd_data(ypred) + ggplot(data, mapping = aes_(x = ~ value)) + + hline_at( + c(0, 0.5, 1), + size = c(0.2, 0.1, 0.2), + linetype = 2, + color = get_color("dh") + ) + + stat_ecdf( + mapping = aes_(group = ~ rep_id, color = "ypred"), + geom = if (discrete) "step" else "line", + size = size, + alpha = alpha, + pad = pad + ) + + scale_color_ppd( + values = get_color("m"), + guide = guide_legend( # in case user turns legend back on + override.aes = list(size = 2 * size, alpha = 1)) + ) + + scale_y_continuous(breaks = c(0, 0.5, 1)) + + bayesplot_theme_get() + + yaxis_title(FALSE) + + xaxis_title(FALSE) + + legend_none() + } + + +#' @rdname PPD-distributions +#' @export +ppd_dens <- + function(ypred, + ..., + trim = FALSE, + size = 0.5, + alpha = 1) { + check_ignored_arguments(...) + + data <- ppd_data(ypred) + ggplot(data, mapping = aes_( + x = ~ value, + color = "ypred", + fill = "ypred" + )) + + geom_density( + size = size, + alpha = alpha, + trim = trim + ) + + scale_color_ppd() + + scale_fill_ppd() + + bayesplot_theme_get() + + facet_wrap_parsed("rep_label") + + force_axes_in_facets() + + dont_expand_y_axis() + + legend_none() + + yaxis_text(FALSE) + + yaxis_title(FALSE) + + yaxis_ticks(FALSE) + + xaxis_title(FALSE) + + facet_text(FALSE) + } + + +#' @rdname PPD-distributions +#' @export +ppd_hist <- + function(ypred, + ..., + binwidth = NULL, + breaks = NULL, + freq = TRUE) { + check_ignored_arguments(...) + + data <- ppd_data(ypred) + ggplot(data, mapping = set_hist_aes( + freq, + color = "ypred", + fill = "ypred" + )) + + geom_histogram( + size = 0.25, + binwidth = binwidth, + breaks = breaks + ) + + scale_color_ppd() + + scale_fill_ppd() + + bayesplot_theme_get() + + facet_wrap_parsed("rep_label") + + force_axes_in_facets() + + dont_expand_y_axis() + + legend_none() + + yaxis_text(FALSE) + + yaxis_title(FALSE) + + yaxis_ticks(FALSE) + + xaxis_title(FALSE) + + facet_text(FALSE) + } + + +#' @rdname PPD-distributions +#' @export +ppd_freqpoly <- + function(ypred, + ..., + binwidth = NULL, + freq = TRUE, + size = 0.5, + alpha = 1) { + + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } + + data <- ppd_data(ypred, group = dots$group) + ggplot(data, mapping = set_hist_aes( + freq, + color = "ypred", + fill = "ypred" + )) + + geom_area( + stat = "bin", + binwidth = binwidth, + size = size, + alpha = alpha + ) + + facet_wrap_parsed("rep_label") + + scale_color_ppd() + + scale_fill_ppd() + + bayesplot_theme_get() + + force_axes_in_facets() + + dont_expand_y_axis() + + yaxis_text(FALSE) + + yaxis_title(FALSE) + + yaxis_ticks(FALSE) + + xaxis_title(FALSE) + + facet_text(FALSE) + + legend_none() + } + + +#' @rdname PPD-distributions +#' @export +ppd_freqpoly_grouped <- + function(ypred, + group, + ..., + binwidth = NULL, + freq = TRUE, + size = 0.5, + alpha = 1) { + + check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppd_freqpoly", call), parent.frame()) + g + + facet_grid( + rep_label ~ group, + scales = "free", + labeller = label_parsed + ) + + force_axes_in_facets() + + facet_text() + + theme(strip.text.y = element_blank()) + } + + +#' @rdname PPD-distributions +#' @export +ppd_boxplot <- + function(ypred, + ..., + notch = TRUE, + size = 0.5, + alpha = 1) { + check_ignored_arguments(...) + + data <- ppd_data(ypred) + ggplot(data, mapping = aes_( + x = ~ rep_label, + y = ~ value, + color = "ypred", + fill = "ypred" + )) + + geom_boxplot( + notch = notch, + size = size, + alpha = alpha, + outlier.color = get_color("lh"), + outlier.alpha = 2/3, + outlier.size = 1 + ) + + scale_color_ppd() + + scale_fill_ppd() + + scale_x_discrete(labels = function(x) parse(text=x)) + + bayesplot_theme_get() + + yaxis_title(FALSE) + + xaxis_ticks(FALSE) + + xaxis_text(FALSE) + + xaxis_title(FALSE) + + legend_none() + } + + +# internal ---------------------------------------------------------------- + +#' Back end for both `ppd_data()` and `ppc_data()` +#' +#' @noRd +#' @param predictions SxN matrix of predictions (`ypred` or `yrep`) already validated. +#' @param y User's `y` argument (if applicable), already validated. +#' @param group User's `group` argument, already validated. +#' @return A molten data frame of predictions, possible including `y`. +#' @importFrom dplyr left_join select +.ppd_data <- function(predictions, y = NULL, group = NULL) { + if (!is.null(y)) { + data <- melt_and_stack(y, predictions) + } else { + data <- melt_predictions(predictions) + levels(data$rep_label) <- gsub("rep", "pred", levels(data$rep_label)) + } + if (!is.null(group)) { + group_indices <- tibble::tibble(group, y_id = seq_along(group)) + data <- data %>% + left_join(group_indices, by = "y_id") %>% + select(.data$group, tidyselect::everything()) + } + data +} + +#' Wrapper for stat_density with some argument defaults changed +#' +#' This function is called internally by `ppd_dens_overlay()` and +#' `ppc_dens_overlay()`. +#' +#' @param geom,position Arguments passed to [ggplot2::stat_density()] but +#' with different defaults. +#' @param ... All arguments other than `geom` and `position` to pass to +#' `stat_density()`. The defaults will be the same as for `stat_density()`. +#' @return Object returned by `stat_density()`. +#' @noRd +overlay_ppd_densities <- + function(..., + geom = "line", + position = "identity") { + stat_density(..., geom = geom, position = position) + } + diff --git a/R/ppd-intervals.R b/R/ppd-intervals.R new file mode 100644 index 00000000..11e17379 --- /dev/null +++ b/R/ppd-intervals.R @@ -0,0 +1,348 @@ +#' PPD intervals +#' +#' Medians and central interval estimates of posterior or prior predictive +#' distributions. Each of these functions makes the same plot as the +#' corresponding [`ppc_`][PPC-intervals] function but without plotting any +#' observed data `y`. The **Plot Descriptions** section at [PPC-intervals] has +#' details on the individual plots. +#' +#' @name PPD-intervals +#' @family PPDs +#' +#' @template args-ypred +#' @inheritParams PPC-intervals +#' +#' @template return-ggplot-or-data +#' +#' @template reference-vis-paper +#' +#' @examples +#' color_scheme_set("brightblue") +#' ypred <- example_yrep_draws() +#' x <- example_x_data() +#' group <- example_group_data() +#' +#' ppd_intervals(ypred[, 1:50]) +#' ppd_intervals(ypred[, 1:50], fatten = .5) +#' ppd_intervals(ypred[, 1:50], prob_outer = 0.75, size = 2, fatten = 0) +#' +#' # put a predictor variable on the x-axis +#' ppd_intervals(ypred[, 1:100], x = x[1:100], size = 1, fatten = 0) + +#' ggplot2::labs(y = "Prediction", x = "Some variable of interest") +#' +#' # with a grouping variable too +#' ppd_intervals_grouped( +#' ypred = ypred[, 1:100], +#' x = x[1:100], +#' group = group[1:100], +#' size = 2, +#' fatten = 0, +#' facet_args = list(nrow = 2) +#' ) +#' +#' # even reducing size, ppd_intervals is too cluttered when there are many +#' # observations included (ppd_ribbon is better) +#' ppd_intervals(ypred, size = 0.5, fatten = 0.1) +#' ppd_ribbon(ypred) +#' ppd_ribbon(ypred, size = 0) # remove line showing median prediction +#' +#' +NULL + +#' @rdname PPD-intervals +#' @export +ppd_intervals <- + function(ypred, + x = NULL, + ..., + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 1, + fatten = 2.5) { + + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } + + + data <- ppd_intervals_data( + ypred = ypred, + x = x, + group = dots$group, + prob = prob, + prob_outer = prob_outer + ) + ggplot(data, mapping = intervals_inner_aes( + needs_y = TRUE, + color = "ypred", + fill = "ypred" + )) + + geom_linerange( + mapping = intervals_outer_aes(color = "ypred"), + alpha = alpha, + size = size + ) + + geom_pointrange( + shape = 21, + stroke = 0.5, + size = size, + fatten = fatten + ) + + scale_color_ppd() + + scale_fill_ppd() + + intervals_axis_labels(has_x = !is.null(x)) + + bayesplot_theme_get() + + legend_none() + } + + +#' @rdname PPD-intervals +#' @export +ppd_intervals_grouped <- + function(ypred, + x = NULL, + group, + ..., + facet_args = list(), + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 1, + fatten = 2.5) { + check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppd_intervals", call), parent.frame()) + g + + intervals_group_facets(facet_args) + + force_axes_in_facets() + } + + +#' @rdname PPD-intervals +#' @export +ppd_ribbon <- + function(ypred, + x = NULL, + ..., + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 0.25) { + + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } + + data <- ppd_intervals_data( + ypred = ypred, + x = x, + group = dots$group, + prob = prob, + prob_outer = prob_outer + ) + ggplot(data, mapping = intervals_inner_aes(color = "ypred", fill = "ypred")) + + geom_ribbon( + mapping = intervals_outer_aes(fill = "ypred", color = "ypred"), + color = NA, + size = 0.2 * size, + alpha = alpha + ) + + geom_ribbon( + mapping = intervals_outer_aes(), + fill = NA, + color = get_color("mh"), + size = 0.2 * size, + alpha = 1 + ) + + geom_ribbon(size = 0.5 * size) + + geom_line( + mapping = aes_(y = ~ m), + color = get_color("d"), + size = size + ) + + scale_color_ppd() + + scale_fill_ppd() + + intervals_axis_labels(has_x = !is.null(x)) + + bayesplot_theme_get() + + legend_none() + } + + +#' @export +#' @rdname PPD-intervals +ppd_ribbon_grouped <- + function(ypred, + x = NULL, + group, + ..., + facet_args = list(), + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 0.25) { + check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppd_ribbon", call), parent.frame()) + g + + intervals_group_facets(facet_args) + + force_axes_in_facets() + } + + +#' @rdname PPD-intervals +#' @export +ppd_intervals_data <- + function(ypred, + x = NULL, + group = NULL, + ..., + prob = 0.5, + prob_outer = 0.9) { + check_ignored_arguments(...) + + ypred <- validate_predictions(ypred) + x <- validate_x(x, ypred[1,]) + if (!is.null(group)) { + group <- validate_group(group, ncol(ypred)) + } + .ppd_intervals_data( + predictions = ypred, + y = NULL, + x = x, + group = group, + prob = prob, + prob_outer = prob_outer + ) + } + + +#' @rdname PPD-intervals +#' @export +ppd_ribbon_data <- ppd_intervals_data + + + +# internal ---------------------------------------------------------------- + +#' Back end for both `ppd_intervals_data()` and `ppc_intervals_data()` +#' +#' @noRd +#' @param predictions SxN matrix of predictions (`ypred` or `yrep`) already validated. +#' @param y `NULL` or user's `y` argument already validated. +#' @param group `NULL` or user's `group` argument, already validated. +#' @param x User's `x` argument, already validated. +#' @return A molten data frame of prediction intervals, possibly including `y`. +#' +#' @importFrom dplyr group_by ungroup summarise +.ppd_intervals_data <- + function(predictions, + y = NULL, + x = NULL, + group = NULL, + prob, + prob_outer) { + stopifnot(prob > 0 && prob < 1) + stopifnot(prob_outer > 0 && prob_outer <= 1) + probs <- sort(c(prob, prob_outer)) + prob <- probs[1] + prob_outer <- probs[2] + alpha <- (1 - probs) / 2 + probs <- sort(c(alpha, 0.5, 1 - alpha)) + + has_group <- !is.null(group) + has_y <- !is.null(y) + has_x <- !is.null(x) + + long_d <- melt_predictions(predictions) + if (has_y) { + long_d$y_obs <- y[long_d$y_id] + } + + if (!has_x) { + x <- seq_len(ncol(predictions)) + } + long_d$x <- x[long_d$y_id] + + if (has_group) { + long_d$group <- group[long_d$y_id] + } + group_by_vars <- syms(c("y_id", if (has_y) "y_obs", + if (has_group) "group", "x")) + + long_d %>% + group_by(!!!group_by_vars) %>% + summarise( + outer_width = prob_outer, + inner_width = prob, + ll = unname(quantile(.data$value, probs = probs[1])), + l = unname(quantile(.data$value, probs = probs[2])), + m = unname(quantile(.data$value, probs = probs[3])), + h = unname(quantile(.data$value, probs = probs[4])), + hh = unname(quantile(.data$value, probs = probs[5])) + ) %>% + ungroup() + } + + +#' Aesthetic mapping for interval and ribbon plots +#' +#' @param needs_y Whether to include `y = ~m` in the call to `aes_()`. Needed +#' for `geom_pointrange()`. +#' @param ... Aguments to pass to `aes_()` other than `x`,`y`,`ymin`,`ymax`. +#' @return Object returned by `aes_()`. Always sets at least `x`, `ymin`, `ymax`. +#' @noRd +intervals_inner_aes <- function(needs_y = FALSE, ...) { + mapping <- aes_( + x = ~ x, + ymin = ~ l, + ymax = ~ h, + ... + ) + if (!needs_y) { + return(mapping) + } + modify_aes_(mapping, y = ~ m) +} +intervals_outer_aes <- function(needs_y = FALSE, ...) { + mapping <- aes_( + x = ~ x, + ymin = ~ ll, + ymax = ~ hh, + ... + ) + if (!needs_y) { + return(mapping) + } + modify_aes_(mapping, y = ~ m) +} + +#' Create the facet layer for grouped interval and ribbon plots +#' +#' @param facet_args User's `facet_args` argument. +#' @param scales_default String to use for `scales` argument to `facet_wrap()` +#' if not specified by user. Defaults to `"free"`, unlike `facet_wrap()`. +#' @return Object returned by `facet_wrap()`. +#' @noRd +intervals_group_facets <- function(facet_args, scales_default = "free") { + facet_args[["facets"]] <- "group" + facet_args[["scales"]] <- facet_args[["scales"]] %||% scales_default + do.call("facet_wrap", facet_args) +} + +#' Set the axis labels for interval and ribbon plots +#' +#' @param has_x Did the user provide an `x` argument (T/F)? +#' @return Object returned by `labs()`. The y-axis label is `NULL` and x-axis +#' label is either 'x' or 'Index' depending on whether the user supplied `x`. +#' @noRd +intervals_axis_labels <- function(has_x) { + labs( + x = if (has_x) expression(italic(x)) else "Data point (index)", + y = NULL + ) +} diff --git a/R/ppd-overview.R b/R/ppd-overview.R new file mode 100644 index 00000000..183820bd --- /dev/null +++ b/R/ppd-overview.R @@ -0,0 +1,38 @@ +#' Plots of posterior or prior predictive distributions +#' +#' @name PPD-overview +#' @aliases PPD +#' @family PPDs +#' +#' @description The **bayesplot** PPD module provides various plotting functions +#' for creating graphical displays of simulated data from the posterior or +#' prior predictive distribution. These plots are essentially the same as the +#' corresponding [PPC] plots but without showing any observed data. Because +#' these are not "checks" compared to data we use PPD (for prior/posterior +#' predictive distribution) instead of PPC (for prior/posterior predictive +#' check). +#' +#' @section PPD plotting functions: The functions for plotting prior and +#' posterior predictive distributions without observed data each have the +#' prefix `ppd_` and all have a required argument `ypred` (a matrix of +#' predictions). The plots are organized into several categories, each with +#' its own documentation: +#' * [PPD-distributions]: Histograms, kernel density estimates, boxplots, and +#' other plots of multiple simulated datasets (rows) in `ypred`. These are the +#' same as the plots in [PPC-distributions] but without including any +#' comparison to `y`. +#' +#' * [PPD-intervals]: Interval estimates for each predicted observations +#' (columns) in `ypred`. The x-axis variable can be optionally specified by +#' the user (e.g. to plot against against a predictor variable or over +#' time).These are the same as the plots in [PPC-intervals] but without +#' including any comparison to `y`. +#' +#' * [PPD-test-statistics]: The distribution of a statistic, or a pair of +#' statistics, over the simulated datasets (rows) in `ypred`. These are the +#' same as the plots in [PPC-test-statistics] but without including any +#' comparison to `y`. +#' +#' @template reference-vis-paper +#' +NULL diff --git a/R/ppd-test-statistics.R b/R/ppd-test-statistics.R new file mode 100644 index 00000000..050ec127 --- /dev/null +++ b/R/ppd-test-statistics.R @@ -0,0 +1,313 @@ +#' PPD test statistics +#' +#' The distribution of a (test) statistic `T(ypred)`, or a pair of (test) +#' statistics, over the simulations from the posterior or prior predictive +#' distribution. Each of these functions makes the same plot as the +#' corresponding [`ppc_`][PPC-test-statistics] function but without comparing to +#' any observed data `y`. The **Plot Descriptions** section at +#' [PPC-test-statistics] has details on the individual plots. +#' +#' @name PPD-test-statistics +#' @aliases PPD-statistics +#' @family PPDs +#' +#' @template args-ypred +#' @inheritParams PPC-test-statistics +#' +#' @template details-binomial +#' @template return-ggplot-or-data +#' +#' @template reference-vis-paper +#' @examples +#' yrep <- example_yrep_draws() +#' ppd_stat(yrep) +#' ppd_stat(yrep, stat = "sd") + legend_none() +#' +#' # use your own function for the 'stat' argument +#' color_scheme_set("brightblue") +#' q25 <- function(y) quantile(y, 0.25) +#' ppd_stat(yrep, stat = "q25") # legend includes function name +NULL + +#' @rdname PPD-test-statistics +#' @export +ppd_stat <- + function(ypred, + stat = "mean", + ..., + binwidth = NULL, + breaks = NULL, + freq = TRUE) { + stopifnot(length(stat) == 1) + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } + + data <- ppd_stat_data( + ypred = ypred, + group = dots$group, + stat = match.fun(stat) + ) + ggplot(data, mapping = set_hist_aes( + freq, + color = "ypred", + fill = "ypred" + )) + + geom_histogram( + size = .25, + na.rm = TRUE, + binwidth = binwidth, + breaks = breaks + ) + + scale_color_ppd(guide = "none") + + scale_fill_ppd(labels = Typred_label(), guide = guide_legend( + title = stat_legend_title(stat, deparse(substitute(stat))) + )) + + bayesplot_theme_get() + + dont_expand_y_axis() + + xaxis_title(FALSE) + + yaxis_text(FALSE) + + yaxis_ticks(FALSE) + + yaxis_title(FALSE) + } + + +#' @rdname PPD-test-statistics +#' @export +ppd_stat_grouped <- + function(ypred, + group, + stat = "mean", + ..., + facet_args = list(), + binwidth = NULL, + breaks = NULL, + freq = TRUE) { + check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppd_stat", call), parent.frame()) + g + + stat_group_facets(facet_args) + + force_axes_in_facets() + } + + +#' @rdname PPD-test-statistics +#' @export +ppd_stat_freqpoly <- + function(ypred, + stat = "mean", + ..., + facet_args = list(), + binwidth = NULL, + freq = TRUE) { + stopifnot(length(stat) == 1) + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } + + data <- ppd_stat_data( + ypred = ypred, + group = dots$group, + stat = match.fun(stat) + ) + ggplot(data, mapping = set_hist_aes(freq)) + + geom_freqpoly( + aes_(color = "ypred"), + size = .5, + na.rm = TRUE, + binwidth = binwidth + ) + + scale_color_ppd( + name = stat_legend_title(stat, deparse(substitute(stat))), + labels = Typred_label() + ) + + dont_expand_y_axis(c(0.005, 0)) + + bayesplot_theme_get() + + xaxis_title(FALSE) + + yaxis_text(FALSE) + + yaxis_ticks(FALSE) + + yaxis_title(FALSE) + } + + +#' @rdname PPD-test-statistics +#' @export +ppd_stat_freqpoly_grouped <- + function(ypred, + group, + stat = "mean", + ..., + facet_args = list(), + binwidth = NULL, + freq = TRUE) { + check_ignored_arguments(...) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppd_stat_freqpoly", call), parent.frame()) + g + + stat_group_facets(facet_args) + + force_axes_in_facets() + } + + +#' @rdname PPD-test-statistics +#' @export +ppd_stat_2d <- + function(ypred, + stat = c("mean", "sd"), + ..., + size = 2.5, + alpha = 0.7) { + check_ignored_arguments(...) + if (length(stat) != 2) { + abort("For ppd_stat_2d the 'stat' argument must have length 2.") + } + + if (is.character(stat)) { + lgnd_title <- bquote(italic(T) == (list(.(stat[1]), .(stat[2])))) + stat_labs <- stat + } else { + lgnd_title <- expression(italic(T) == (list(italic(T)[1], italic(T)[2]))) + stat_labs <- expression(italic(T)[1], italic(T)[2]) + } + + data <- ppd_stat_data( + ypred = ypred, + group = NULL, + stat = c(match.fun(stat[[1]]), match.fun(stat[[2]])) + ) + ggplot(data) + + geom_point( + mapping = aes_( + x = ~ value, + y = ~ value2, + fill = "ypred", + color = "ypred" + ), + shape = 21, + size = size, + alpha = alpha + ) + + scale_fill_ppd(lgnd_title, labels = Typred_label()) + + scale_color_ppd(lgnd_title, labels = Typred_label()) + + labs(x = stat_labs[1], y = stat_labs[2]) + + bayesplot_theme_get() + } + + +#' @rdname PPD-test-statistics +#' @export +ppd_stat_data <- function(ypred, group = NULL, stat) { + if (!(length(stat) %in% 1:2)) { + abort("'stat' must have length 1 or 2.") + } + + ypred <- validate_predictions(ypred) + if (!is.null(group)) { + group <- validate_group(group, ncol(ypred)) + } + + if (length(stat) == 1) { + stat <- match.fun(stat) + } else { + stat <- list(match.fun(stat[[1]]), match.fun(stat[[2]])) + } + + .ppd_stat_data( + predictions = ypred, + y = NULL, + group = group, + stat = stat + ) +} + +# internal ---------------------------------------------------------------- + +#' Back end for both `ppd_stat_data()` and `ppc_stat_data()`. +#' +#' @noRd +#' @param predictions,y,group Already validated `y`, `yrep` or `ypred`, and +#' `group` objects. +#' @param stat A function already validated and returned by `match.fun()`, or a +#' list of two such functions. +#' @return A data frame with columns `group` (if not `NULL`), `variable`, +#' `value`, and `value2` (if `stat` contains two functions). +#' +#' @examples +#' y <- example_y_data() +#' yrep <- example_yrep_draws() +#' group <- example_group_data() +#' ppd_stat_data(yrep, group, stat = "median") +#' ppc_stat_data(y, yrep, group, stat = "median") +#' +#' @importFrom dplyr group_by ungroup summarise rename +.ppd_stat_data <- function(predictions, y = NULL, group = NULL, stat) { + stopifnot(length(stat) %in% c(1,2)) + if (length(stat) == 1) { + stopifnot(is.function(stat)) # sanity check, should already be validated + stat1 <- stat + stat2 <- NULL + } else { # two stats + stopifnot(is.function(stat[[1]]), is.function(stat[[2]])) + stat1 <- stat[[1]] + stat2 <- stat[[2]] + } + + has_group <- !is.null(group) + has_y <- !is.null(y) + + if (!has_group) { + group <- 1 + } + if (!has_y) { + y <- 1 + } + + d <- data.frame( + y = y, + group = factor(group), + ypred = t(predictions) + ) + colnames(d) <- gsub(".", "_", colnames(d), fixed = TRUE) + molten_d <- reshape2::melt(d, id.vars = "group") + molten_d <- group_by(molten_d, .data$group, .data$variable) + + data <- + molten_d %>% + summarise( + value1 = stat1(.data$value), + value2 = if (!is.null(stat2)) + stat2(.data$value) else NA + ) %>% + rename(value = .data$value1) %>% + ungroup() + + if (is.null(stat2)) { + data$value2 <- NULL + } + if (!has_group) { + data$group <- NULL + } + if (!has_y) { + data <- dplyr::filter(data, .data$variable != "y") + data$variable <- droplevels(data$variable) + } else { + levels(data$variable) <- gsub("ypred", "yrep", levels(data$variable)) + } + + data +} + + +# Create the facet layer for grouped stat plots +stat_group_facets <- function(facet_args, scales_default = "free") { + facet_args[["facets"]] <- "group" + facet_args[["scales"]] <- facet_args[["scales"]] %||% scales_default + do.call("facet_wrap", facet_args) +} + +Typred_label <- function() expression(italic(T)(italic(y)[pred])) diff --git a/README.md b/README.md index 74c82ee2..90ae3089 100644 --- a/README.md +++ b/README.md @@ -16,9 +16,8 @@ a plot is created it can be further customized using various functions from the **ggplot2** package. Currently **bayesplot** offers a variety of plots of posterior draws, -visual MCMC diagnostics, and graphical posterior (or prior) predictive checking. -Additional functionality (e.g. for forecasting/out-of-sample prediction and other -inference-related tasks) will be added in future releases. +visual MCMC diagnostics, graphical posterior (or prior) predictive checking, +and general plots of posterior (or prior) predictive distributions. The idea behind **bayesplot** is not only to provide convenient functionality for users, but also a common set of functions that can be easily used by diff --git a/man-roxygen/args-facet_args.R b/man-roxygen/args-facet_args.R index 566739cd..84ea6ba3 100644 --- a/man-roxygen/args-facet_args.R +++ b/man-roxygen/args-facet_args.R @@ -1,3 +1,5 @@ #' @param facet_args A named list of arguments (other than `facets`) passed #' to [ggplot2::facet_wrap()] or [ggplot2::facet_grid()] -#' to control faceting. +#' to control faceting. Note: if `scales` is not included in `facet_args` +#' then **bayesplot** may use `scales="free"` as the default (depending +#' on the plot) instead of the **ggplot2** default of `scales="fixed"`. diff --git a/man-roxygen/args-group.R b/man-roxygen/args-group.R index d4366c84..fda76dfc 100644 --- a/man-roxygen/args-group.R +++ b/man-roxygen/args-group.R @@ -1,3 +1,4 @@ -#' @param group A grouping variable (a vector or factor) of the same length as -#' `y`. Each value in `group` is interpreted as the group level -#' pertaining to the corresponding value of `y`. +#' @param group A grouping variable of the same length as `y`. +#' Will be coerced to [factor][base::factor] if not already a factor. +#' Each value in `group` is interpreted as the group level pertaining +#' to the corresponding observation. diff --git a/man-roxygen/args-prob-prob_outer.R b/man-roxygen/args-prob-prob_outer.R index 44186780..76442b5c 100644 --- a/man-roxygen/args-prob-prob_outer.R +++ b/man-roxygen/args-prob-prob_outer.R @@ -1,3 +1,3 @@ -#' @param prob,prob_outer Values between 0 and 1 indicating the desired +#' @param prob,prob_outer Values between `0` and `1` indicating the desired #' probability mass to include in the inner and outer intervals. The defaults #' are `prob=0.5` and `prob_outer=0.9`. diff --git a/man-roxygen/args-y-yrep.R b/man-roxygen/args-y-yrep.R index 5c3a7ba5..ccaf2e14 100644 --- a/man-roxygen/args-y-yrep.R +++ b/man-roxygen/args-y-yrep.R @@ -1,7 +1,8 @@ #' @param y A vector of observations. See **Details**. -#' @param yrep An \eqn{S} by \eqn{N} matrix of draws from the posterior -#' predictive distribution, where \eqn{S} is the size of the posterior sample -#' (or subset of the posterior sample used to generate `yrep`) and \eqn{N} is -#' the number of observations (the length of `y`). The columns of `yrep` -#' should be in the same order as the data points in `y` for the plots to make -#' sense. See **Details** for additional instructions. +#' @param yrep An `S` by `N` matrix of draws from the posterior (or prior) +#' predictive distribution. The number of rows, `S`, is the size of the +#' posterior (or prior) sample used to generate `yrep`. The number of columns, +#' `N` is the number of predicted observations (`length(y)`). The columns of +#' `yrep` should be in the same order as the data points in `y` for the plots +#' to make sense. See the **Details** and **Plot Descriptions** sections for +#' additional advice specific to particular plots. diff --git a/man-roxygen/args-ypred.R b/man-roxygen/args-ypred.R new file mode 100644 index 00000000..1c4d342b --- /dev/null +++ b/man-roxygen/args-ypred.R @@ -0,0 +1,4 @@ +#' @param ypred An `S` by `N` matrix of draws from the posterior (or prior) +#' predictive distribution. The number of rows, `S`, is the size of the +#' posterior (or prior) sample used to generate `ypred`. The number of +#' columns, `N`, is the number of predicted observations. diff --git a/man-roxygen/details-binomial.R b/man-roxygen/details-binomial.R index d49000e2..34c4f5c8 100644 --- a/man-roxygen/details-binomial.R +++ b/man-roxygen/details-binomial.R @@ -1,3 +1,3 @@ -#' @details For Binomial data, the plots will typically be most useful if -#' `y` and `yrep` contain the "success" proportions (not discrete +#' @details For Binomial data, the plots may be more useful if +#' the input contains the "success" *proportions* (not discrete #' "success" or "failure" counts). diff --git a/man/MCMC-diagnostics.Rd b/man/MCMC-diagnostics.Rd index 1ca79914..a85cf4c2 100644 --- a/man/MCMC-diagnostics.Rd +++ b/man/MCMC-diagnostics.Rd @@ -87,7 +87,9 @@ perform a similar function.} \item{facet_args}{A named list of arguments (other than \code{facets}) passed to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} or \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} -to control faceting.} +to control faceting. Note: if \code{scales} is not included in \code{facet_args} +then \strong{bayesplot} may use \code{scales="free"} as the default (depending +on the plot) instead of the \strong{ggplot2} default of \code{scales="fixed"}.} \item{lags}{The number of lags to show in the autocorrelation plot.} } diff --git a/man/MCMC-distributions.Rd b/man/MCMC-distributions.Rd index 32b4dec1..87fe30d7 100644 --- a/man/MCMC-distributions.Rd +++ b/man/MCMC-distributions.Rd @@ -152,7 +152,9 @@ abbreviated for convenience in interactive use (e.g., \code{transform}).} \item{facet_args}{A named list of arguments (other than \code{facets}) passed to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} or \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} -to control faceting.} +to control faceting. Note: if \code{scales} is not included in \code{facet_args} +then \strong{bayesplot} may use \code{scales="free"} as the default (depending +on the plot) instead of the \strong{ggplot2} default of \code{scales="fixed"}.} \item{binwidth}{Passed to \code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} to override the default binwidth.} diff --git a/man/MCMC-recover.Rd b/man/MCMC-recover.Rd index 4547db12..0e83a135 100644 --- a/man/MCMC-recover.Rd +++ b/man/MCMC-recover.Rd @@ -70,7 +70,9 @@ within which it makes sense to use the same y-axis.} \item{facet_args}{A named list of arguments (other than \code{facets}) passed to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} or \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} -to control faceting.} +to control faceting. Note: if \code{scales} is not included in \code{facet_args} +then \strong{bayesplot} may use \code{scales="free"} as the default (depending +on the plot) instead of the \strong{ggplot2} default of \code{scales="fixed"}.} \item{prob}{The probability mass to include in the inner interval. The default is \code{0.5} (50\% interval).} diff --git a/man/MCMC-traces.Rd b/man/MCMC-traces.Rd index cd82ec07..68d94198 100644 --- a/man/MCMC-traces.Rd +++ b/man/MCMC-traces.Rd @@ -8,7 +8,7 @@ \alias{mcmc_rank_overlay} \alias{mcmc_rank_hist} \alias{mcmc_trace_data} -\title{Trace plots of MCMC draws} +\title{Trace and rank plots of MCMC draws} \usage{ mcmc_trace( x, @@ -126,7 +126,9 @@ abbreviated for convenience in interactive use (e.g., \code{transform}).} \item{facet_args}{A named list of arguments (other than \code{facets}) passed to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} or \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} -to control faceting.} +to control faceting. Note: if \code{scales} is not included in \code{facet_args} +then \strong{bayesplot} may use \code{scales="free"} as the default (depending +on the plot) instead of the \strong{ggplot2} default of \code{scales="fixed"}.} \item{n_warmup}{An integer; the number of warmup iterations included in \code{x}. The default is \code{n_warmup = 0}, i.e. to assume no warmup @@ -187,7 +189,7 @@ function. in the same data frame. } \description{ -Trace plot (or traceplot) of MCMC draws. See the \strong{Plot Descriptions} +Trace and rank plots of MCMC draws. See the \strong{Plot Descriptions} section, below, for details. } \section{Plot Descriptions}{ diff --git a/man/PPC-censoring.Rd b/man/PPC-censoring.Rd index c14496fa..8e449ed9 100644 --- a/man/PPC-censoring.Rd +++ b/man/PPC-censoring.Rd @@ -13,12 +13,13 @@ ppc_km_overlay_grouped(y, yrep, group, ..., status_y, size = 0.25, alpha = 0.7) \arguments{ \item{y}{A vector of observations. See \strong{Details}.} -\item{yrep}{An \eqn{S} by \eqn{N} matrix of draws from the posterior -predictive distribution, where \eqn{S} is the size of the posterior sample -(or subset of the posterior sample used to generate \code{yrep}) and \eqn{N} is -the number of observations (the length of \code{y}). The columns of \code{yrep} -should be in the same order as the data points in \code{y} for the plots to make -sense. See \strong{Details} for additional instructions.} +\item{yrep}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{yrep}. The number of columns, +\code{N} is the number of predicted observations (\code{length(y)}). The columns of +\code{yrep} should be in the same order as the data points in \code{y} for the plots +to make sense. See the \strong{Details} and \strong{Plot Descriptions} sections for +additional advice specific to particular plots.} \item{...}{Currently only used internally.} @@ -29,9 +30,10 @@ right censored, 1 = event).} \item{size, alpha}{Passed to the appropriate geom to control the appearance of the \code{yrep} distributions.} -\item{group}{A grouping variable (a vector or factor) of the same length as -\code{y}. Each value in \code{group} is interpreted as the group level -pertaining to the corresponding value of \code{y}.} +\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 +to the corresponding observation.} } \value{ A ggplot object that can be further customized using the \strong{ggplot2} package. diff --git a/man/PPC-discrete.Rd b/man/PPC-discrete.Rd index 314d7c3a..b5622864 100644 --- a/man/PPC-discrete.Rd +++ b/man/PPC-discrete.Rd @@ -5,6 +5,7 @@ \alias{ppc_bars} \alias{ppc_bars_grouped} \alias{ppc_rootogram} +\alias{ppc_bars_data} \title{PPCs for discrete outcomes} \usage{ ppc_bars( @@ -14,7 +15,7 @@ ppc_bars( prob = 0.9, width = 0.9, size = 1, - fatten = 3, + fatten = 2.5, freq = TRUE ) @@ -27,7 +28,7 @@ ppc_bars_grouped( prob = 0.9, width = 0.9, size = 1, - fatten = 3, + fatten = 2.5, freq = TRUE ) @@ -39,39 +40,41 @@ ppc_rootogram( prob = 0.9, size = 1 ) + +ppc_bars_data(y, yrep, group = NULL, prob = 0.9, freq = TRUE) } \arguments{ \item{y}{A vector of observations. See \strong{Details}.} -\item{yrep}{An \eqn{S} by \eqn{N} matrix of draws from the posterior -predictive distribution, where \eqn{S} is the size of the posterior sample -(or subset of the posterior sample used to generate \code{yrep}) and \eqn{N} is -the number of observations (the length of \code{y}). The columns of \code{yrep} -should be in the same order as the data points in \code{y} for the plots to make -sense. See \strong{Details} for additional instructions.} +\item{yrep}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{yrep}. The number of columns, +\code{N} is the number of predicted observations (\code{length(y)}). The columns of +\code{yrep} should be in the same order as the data points in \code{y} for the plots +to make sense. See the \strong{Details} and \strong{Plot Descriptions} sections for +additional advice specific to particular plots.} \item{...}{Currently unused.} \item{prob}{A value between \code{0} and \code{1} indicating the desired probability mass to include in the \code{yrep} intervals. Set \code{prob=0} to remove the -intervals. For \code{ppc_rootogram()} these are intervals of the \emph{square roots} -of the expected counts.} +intervals. (Note: for rootograms these are intervals of the \emph{square roots} +of the expected counts.)} -\item{width}{For \code{ppc_bars()} and \code{ppc_bars_grouped()}, passed to -\code{\link[ggplot2:geom_bar]{ggplot2::geom_bar()}} to control the bar width.} +\item{width}{For bar plots only, passed to \code{\link[ggplot2:geom_bar]{ggplot2::geom_bar()}} to control +the bar width.} -\item{size, fatten}{For \code{ppc_bars()} and \code{ppc_bars_grouped()}, \code{size} and -\code{fatten} are passed to \code{\link[ggplot2:geom_linerange]{ggplot2::geom_pointrange()}} to control the -appearance of the \code{yrep} points and intervals. For \code{ppc_rootogram()} \code{size} -is passed to \code{\link[ggplot2:geom_path]{ggplot2::geom_line()}}.} +\item{size, fatten}{For bar plots, \code{size} and \code{fatten} are passed to +\code{\link[ggplot2:geom_linerange]{ggplot2::geom_pointrange()}} to control the appearance of the \code{yrep} points +and intervals. For rootograms \code{size} is passed to \code{\link[ggplot2:geom_path]{ggplot2::geom_line()}}.} -\item{freq}{For \code{ppc_bars()} and \code{ppc_bars_grouped()}, if \code{TRUE} (the -default) the y-axis will display counts. Setting \code{freq=FALSE} will put -proportions on the y-axis.} +\item{freq}{For bar plots only, if \code{TRUE} (the default) the y-axis will +display counts. Setting \code{freq=FALSE} will put proportions on the y-axis.} -\item{group}{A grouping variable (a vector or factor) of the same length as -\code{y}. Each value in \code{group} is interpreted as the group level -pertaining to the corresponding value of \code{y}.} +\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 +to the corresponding observation.} \item{facet_args}{An optional list of arguments (other than \code{facets}) passed to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} to control faceting.} @@ -82,7 +85,10 @@ style. The options are \code{"standing"}, \code{"hanging"}, and details on the different styles.} } \value{ -A ggplot object that can be further customized using the \strong{ggplot2} package. +The plotting functions return a ggplot object that can be further +customized using the \strong{ggplot2} package. The functions with suffix +\verb{_data()} return the data that would have been drawn by the plotting +function. } \description{ Many of the \link[=PPC-overview]{PPC} functions in \strong{bayesplot} can @@ -126,9 +132,9 @@ representing expected counts. observed counts. } -\strong{All of these are plotted on the square root scale}. See Kleiber and -Zeileis (2016) for advice on interpreting rootograms and selecting among -the different styles. +\strong{All of the rootograms are plotted on the square root scale}. See Kleiber +and Zeileis (2016) for advice on interpreting rootograms and selecting +among the different styles. } } } @@ -153,6 +159,40 @@ ppc_bars(y, yrep) color_scheme_set("mix-blue-pink") ppc_bars_grouped(y, yrep, group, prob = 0.5, freq = FALSE) +\dontrun{ +# example for ordinal regression using rstanarm +library(rstanarm) +fit <- stan_polr( + tobgp ~ agegp, + data = esoph, + method = "probit", + prior = R2(0.2, "mean"), + init_r = 0.1, + seed = 12345, + # cores = 4, + refresh = 0 + ) + +# coded as character, so convert to integer +yrep_char <- posterior_predict(fit) +print(yrep_char[1, 1:4]) + +yrep_int <- sapply(data.frame(yrep_char, stringsAsFactors = TRUE), as.integer) +y_int <- as.integer(esoph$tobgp) + +ppc_bars(y_int, yrep_int) + +ppc_bars_grouped( + y = y_int, + yrep = yrep_int, + group = esoph$agegp, + freq=FALSE, + prob = 0.5, + fatten = 1, + size = 1.5 +) +} + # rootograms for counts y <- rpois(100, 20) yrep <- matrix(rpois(10000, 20), ncol = 100) diff --git a/man/PPC-distributions.Rd b/man/PPC-distributions.Rd index 86de96b0..43660409 100644 --- a/man/PPC-distributions.Rd +++ b/man/PPC-distributions.Rd @@ -3,47 +3,20 @@ \name{PPC-distributions} \alias{PPC-distributions} \alias{ppc_data} -\alias{ppc_hist} -\alias{ppc_boxplot} -\alias{ppc_freqpoly} -\alias{ppc_freqpoly_grouped} -\alias{ppc_dens} \alias{ppc_dens_overlay} \alias{ppc_dens_overlay_grouped} \alias{ppc_ecdf_overlay} \alias{ppc_ecdf_overlay_grouped} +\alias{ppc_dens} +\alias{ppc_hist} +\alias{ppc_freqpoly} +\alias{ppc_freqpoly_grouped} +\alias{ppc_boxplot} \alias{ppc_violin_grouped} \title{PPC distributions} \usage{ ppc_data(y, yrep, group = NULL) -ppc_hist(y, yrep, ..., binwidth = NULL, breaks = NULL, freq = TRUE) - -ppc_boxplot(y, yrep, ..., notch = TRUE, size = 0.5, alpha = 1) - -ppc_freqpoly( - y, - yrep, - ..., - binwidth = NULL, - freq = TRUE, - size = 0.25, - alpha = 1 -) - -ppc_freqpoly_grouped( - y, - yrep, - group, - ..., - binwidth = NULL, - freq = TRUE, - size = 0.25, - alpha = 1 -) - -ppc_dens(y, yrep, ..., trim = FALSE, size = 0.5, alpha = 1) - ppc_dens_overlay( y, yrep, @@ -92,6 +65,25 @@ ppc_ecdf_overlay_grouped( alpha = 0.7 ) +ppc_dens(y, yrep, ..., trim = FALSE, size = 0.5, alpha = 1) + +ppc_hist(y, yrep, ..., binwidth = NULL, breaks = NULL, freq = TRUE) + +ppc_freqpoly(y, yrep, ..., binwidth = NULL, freq = TRUE, size = 0.5, alpha = 1) + +ppc_freqpoly_grouped( + y, + yrep, + group, + ..., + binwidth = NULL, + freq = TRUE, + size = 0.5, + alpha = 1 +) + +ppc_boxplot(y, yrep, ..., notch = TRUE, size = 0.5, alpha = 1) + ppc_violin_grouped( y, yrep, @@ -109,36 +101,23 @@ ppc_violin_grouped( \arguments{ \item{y}{A vector of observations. See \strong{Details}.} -\item{yrep}{An \eqn{S} by \eqn{N} matrix of draws from the posterior -predictive distribution, where \eqn{S} is the size of the posterior sample -(or subset of the posterior sample used to generate \code{yrep}) and \eqn{N} is -the number of observations (the length of \code{y}). The columns of \code{yrep} -should be in the same order as the data points in \code{y} for the plots to make -sense. See \strong{Details} for additional instructions.} +\item{yrep}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{yrep}. The number of columns, +\code{N} is the number of predicted observations (\code{length(y)}). The columns of +\code{yrep} should be in the same order as the data points in \code{y} for the plots +to make sense. See the \strong{Details} and \strong{Plot Descriptions} sections for +additional advice specific to particular plots.} -\item{group}{A grouping variable (a vector or factor) of the same length as -\code{y}. Each value in \code{group} is interpreted as the group level -pertaining to the corresponding value of \code{y}.} +\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 +to the corresponding observation.} \item{...}{Currently unused.} -\item{binwidth}{Passed to \code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} to override -the default binwidth.} - -\item{breaks}{Passed to \code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} as an -alternative to \code{binwidth}.} - -\item{freq}{For histograms, \code{freq=TRUE} (the default) puts count on the -y-axis. Setting \code{freq=FALSE} puts density on the y-axis. (For many -plots the y-axis text is off by default. To view the count or density -labels on the y-axis see the \code{\link[=yaxis_text]{yaxis_text()}} convenience -function.)} - -\item{notch}{A logical scalar passed to \code{\link[ggplot2:geom_boxplot]{ggplot2::geom_boxplot()}}. -Unlike for \code{geom_boxplot()}, the default is \code{notch=TRUE}.} - \item{size, alpha}{Passed to the appropriate geom to control the appearance of -the \code{yrep} distributions.} +the predictive distributions.} \item{trim}{A logical scalar passed to \code{\link[ggplot2:geom_density]{ggplot2::geom_density()}}.} @@ -153,6 +132,22 @@ passed to \code{\link[ggplot2:stat_ecdf]{ggplot2::stat_ecdf()}}. If \code{discre \item{pad}{A logical scalar passed to \code{\link[ggplot2:stat_ecdf]{ggplot2::stat_ecdf()}}.} +\item{binwidth}{Passed to \code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} to override +the default binwidth.} + +\item{breaks}{Passed to \code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} as an +alternative to \code{binwidth}.} + +\item{freq}{For histograms, \code{freq=TRUE} (the default) puts count on the +y-axis. Setting \code{freq=FALSE} puts density on the y-axis. (For many +plots the y-axis text is off by default. To view the count or density +labels on the y-axis see the \code{\link[=yaxis_text]{yaxis_text()}} convenience +function.)} + +\item{notch}{For the box plot, a logical scalar passed to +\code{\link[ggplot2:geom_boxplot]{ggplot2::geom_boxplot()}}. Note: unlike \code{geom_boxplot()}, the default is +\code{notch=TRUE}.} + \item{probs}{A numeric vector passed to \code{\link[ggplot2:geom_violin]{ggplot2::geom_violin()}}'s \code{draw_quantiles} argument to specify at which quantiles to draw horizontal lines. Set to \code{NULL} to remove the lines.} @@ -173,14 +168,13 @@ customized using the \strong{ggplot2} package. The functions with suffix function. } \description{ -Compare the empirical distribution of the data \code{y} to the distributions -of simulated/replicated data \code{yrep} from the posterior predictive -distribution. See the \strong{Plot Descriptions} section, below, -for details. +Compare the empirical distribution of the data \code{y} to the distributions of +simulated/replicated data \code{yrep} from the posterior predictive distribution. +See the \strong{Plot Descriptions} section, below, for details. } \details{ -For Binomial data, the plots will typically be most useful if -\code{y} and \code{yrep} contain the "success" proportions (not discrete +For Binomial data, the plots may be more useful if +the input contains the "success" \emph{proportions} (not discrete "success" or "failure" counts). } \section{Plot Descriptions}{ @@ -239,12 +233,13 @@ color_scheme_set("blue") ppc_dens(y, yrep[200:202, ]) } +# frequency polygons ppc_freqpoly(y, yrep[1:3,], alpha = 0.1, size = 1, binwidth = 5) -# if groups are different sizes then the 'freq' argument can be useful group <- example_group_data() ppc_freqpoly_grouped(y, yrep[1:3,], group) + yaxis_text() \donttest{ +# if groups are different sizes then the 'freq' argument can be useful ppc_freqpoly_grouped(y, yrep[1:3,], group, freq = FALSE) + yaxis_text() } diff --git a/man/PPC-errors.Rd b/man/PPC-errors.Rd index fa59543e..39152913 100644 --- a/man/PPC-errors.Rd +++ b/man/PPC-errors.Rd @@ -6,42 +6,80 @@ \alias{ppc_error_hist_grouped} \alias{ppc_error_scatter} \alias{ppc_error_scatter_avg} +\alias{ppc_error_scatter_avg_grouped} \alias{ppc_error_scatter_avg_vs_x} \alias{ppc_error_binned} +\alias{ppc_error_data} \title{PPC errors} \usage{ -ppc_error_hist(y, yrep, ..., binwidth = NULL, breaks = NULL, freq = TRUE) +ppc_error_hist( + y, + yrep, + ..., + facet_args = list(), + binwidth = NULL, + breaks = NULL, + freq = TRUE +) ppc_error_hist_grouped( y, yrep, group, ..., + facet_args = list(), binwidth = NULL, breaks = NULL, freq = TRUE ) -ppc_error_scatter(y, yrep, ..., size = 2.5, alpha = 0.8) +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_grouped( + y, + yrep, + group, + ..., + 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_binned(y, yrep, ..., bins = NULL, size = 1, alpha = 0.25) +ppc_error_binned( + y, + yrep, + ..., + facet_args = list(), + bins = NULL, + size = 1, + alpha = 0.25 +) + +ppc_error_data(y, yrep, group = NULL) } \arguments{ \item{y}{A vector of observations. See \strong{Details}.} -\item{yrep}{An \eqn{S} by \eqn{N} matrix of draws from the posterior -predictive distribution, where \eqn{S} is the size of the posterior sample -(or subset of the posterior sample used to generate \code{yrep}) and \eqn{N} is -the number of observations (the length of \code{y}). The columns of \code{yrep} -should be in the same order as the data points in \code{y} for the plots to make -sense. See \strong{Details} for additional instructions.} +\item{yrep}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{yrep}. The number of columns, +\code{N} is the number of predicted observations (\code{length(y)}). The columns of +\code{yrep} should be in the same order as the data points in \code{y} for the plots +to make sense. See the \strong{Details} and \strong{Plot Descriptions} sections for +additional advice specific to particular plots.} \item{...}{Currently unused.} +\item{facet_args}{A named list of arguments (other than \code{facets}) passed +to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} or \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} +to control faceting. Note: if \code{scales} is not included in \code{facet_args} +then \strong{bayesplot} may use \code{scales="free"} as the default (depending +on the plot) instead of the \strong{ggplot2} default of \code{scales="fixed"}.} + \item{binwidth}{Passed to \code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} to override the default binwidth.} @@ -54,9 +92,10 @@ plots the y-axis text is off by default. To view the count or density labels on the y-axis see the \code{\link[=yaxis_text]{yaxis_text()}} convenience function.)} -\item{group}{A grouping variable (a vector or factor) of the same length as -\code{y}. Each value in \code{group} is interpreted as the group level -pertaining to the corresponding value of \code{y}.} +\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 +to the corresponding observation.} \item{size, alpha}{For scatterplots, arguments passed to \code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} to control the appearance of the points. For the @@ -91,8 +130,8 @@ proportions (not counts). See the \strong{Examples} section, below. \describe{ \item{\code{ppc_error_hist()}}{ A separate histogram is plotted for the predictive errors computed from -\code{y} and each dataset (row) in \code{yrep}. For this plot \code{yrep} -should have only a small number of rows. +\code{y} and each dataset (row) in \code{yrep}. For this plot \code{yrep} should have +only a small number of rows. } \item{\code{ppc_error_hist_grouped()}}{ Like \code{ppc_error_hist()}, except errors are computed within levels of a @@ -102,20 +141,18 @@ product of the number of rows in \code{yrep} and the number of groups } \item{\code{ppc_error_scatter()}}{ A separate scatterplot is displayed for \code{y} vs. the predictive errors -computed from \code{y} and each dataset (row) in \code{yrep}. For this -plot \code{yrep} should have only a small number of rows. +computed from \code{y} and each dataset (row) in \code{yrep}. For this plot \code{yrep} +should have only a small number of rows. } \item{\code{ppc_error_scatter_avg()}}{ -A single scatterplot of \code{y} vs. the average of the errors computed -from \code{y} and each dataset (row) in \code{yrep}. For each individual -data point \code{y[n]} the average error is the average of the -errors for \code{y[n]} computed over the the draws from the posterior -predictive distribution. +A single scatterplot of \code{y} vs. the average of the errors computed from +\code{y} and each dataset (row) in \code{yrep}. For each individual data point +\code{y[n]} the average error is the average of the errors for \code{y[n]} computed +over the the draws from the posterior predictive distribution. } \item{\code{ppc_error_scatter_avg_vs_x()}}{ Same as \code{ppc_error_scatter_avg()}, except the average is plotted on the -\eqn{y}-axis and a a predictor variable \code{x} is plotted on the -\eqn{x}-axis. +y-axis and a predictor variable \code{x} is plotted on the x-axis. } \item{\code{ppc_error_binned()}}{ Intended for use with binomial data. A separate binned error plot (similar @@ -148,8 +185,8 @@ ppc_error_scatter_avg(y, yrep) x <- example_x_data() ppc_error_scatter_avg_vs_x(y, yrep, x) -# ppc_error_binned with binomial model from rstanarm \dontrun{ +# binned error plot with binomial model from rstanarm library(rstanarm) example("example_model", package = "rstanarm") formula(example_model) diff --git a/man/PPC-intervals.Rd b/man/PPC-intervals.Rd index 85b52c67..eed353b6 100644 --- a/man/PPC-intervals.Rd +++ b/man/PPC-intervals.Rd @@ -17,8 +17,9 @@ ppc_intervals( ..., prob = 0.5, prob_outer = 0.9, + alpha = 0.33, size = 1, - fatten = 3 + fatten = 2.5 ) ppc_intervals_grouped( @@ -30,8 +31,9 @@ ppc_intervals_grouped( facet_args = list(), prob = 0.5, prob_outer = 0.9, + alpha = 0.33, size = 1, - fatten = 3 + fatten = 2.5 ) ppc_ribbon( @@ -83,34 +85,42 @@ ppc_ribbon_data( \arguments{ \item{y}{A vector of observations. See \strong{Details}.} -\item{yrep}{An \eqn{S} by \eqn{N} matrix of draws from the posterior -predictive distribution, where \eqn{S} is the size of the posterior sample -(or subset of the posterior sample used to generate \code{yrep}) and \eqn{N} is -the number of observations (the length of \code{y}). The columns of \code{yrep} -should be in the same order as the data points in \code{y} for the plots to make -sense. See \strong{Details} for additional instructions.} +\item{yrep}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{yrep}. The number of columns, +\code{N} is the number of predicted observations (\code{length(y)}). The columns of +\code{yrep} should be in the same order as the data points in \code{y} for the plots +to make sense. See the \strong{Details} and \strong{Plot Descriptions} sections for +additional advice specific to particular plots.} -\item{x}{A numeric vector the same length as \code{y} to use as the x-axis +\item{x}{A numeric vector to use as the x-axis variable. For example, \code{x} could be a predictor variable from a regression model, a time variable for time-series models, etc. If \code{x} -is missing or \code{NULL}, then \code{1:length(y)} is used for the x-axis.} +is missing or \code{NULL} then the observation index is used for the x-axis.} \item{...}{Currently unused.} -\item{prob, prob_outer}{Values between 0 and 1 indicating the desired +\item{prob, prob_outer}{Values between \code{0} and \code{1} indicating the desired probability mass to include in the inner and outer intervals. The defaults are \code{prob=0.5} and \code{prob_outer=0.9}.} -\item{group}{A grouping variable (a vector or factor) of the same length as -\code{y}. Each value in \code{group} is interpreted as the group level -pertaining to the corresponding value of \code{y}.} - -\item{facet_args}{An optional list of arguments (other than \code{facets}) -passed to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} to control faceting.} - \item{alpha, size, fatten}{Arguments passed to geoms. For ribbon plots \code{alpha} -and \code{size} are passed to \code{\link[ggplot2:geom_ribbon]{ggplot2::geom_ribbon()}}. For interval plots -\code{size} and \code{fatten} are passed to \code{\link[ggplot2:geom_linerange]{ggplot2::geom_pointrange()}}.} +is passed to \code{\link[ggplot2:geom_ribbon]{ggplot2::geom_ribbon()}} to control the opacity of the outer +ribbon and \code{size} is passed to \code{\link[ggplot2:geom_path]{ggplot2::geom_line()}} to control the size +of the line representing the median prediction (\code{size=0} will remove the +line). For interval plots \code{alpha}, \code{size} and \code{fatten} are passed to +\code{\link[ggplot2:geom_linerange]{ggplot2::geom_pointrange()}} (\code{fatten=0} will remove the point estimates).} + +\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 +to the corresponding observation.} + +\item{facet_args}{A named list of arguments (other than \code{facets}) passed +to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} or \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} +to control faceting. Note: if \code{scales} is not included in \code{facet_args} +then \strong{bayesplot} may use \code{scales="free"} as the default (depending +on the plot) instead of the \strong{ggplot2} default of \code{scales="fixed"}.} \item{y_draw}{For ribbon plots only, a string specifying how to draw \code{y}. Can be \code{"line"} (the default), \code{"points"}, or \code{"both"}.} @@ -138,8 +148,8 @@ observed \code{y} values. In both cases an optional \code{x} variable can also be specified for the x-axis variable. Depending on the number of observations and the variability in the -predictions at different values of \code{x}, one or the other of these -plots may be easier to read than the other. +predictions at different values of \code{x}, one of these plots may be easier +to read than the other. } \item{\verb{ppc_intervals_grouped(), ppc_ribbon_grouped()}}{ Same as \code{ppc_intervals()} and \code{ppc_ribbon()}, respectively, but a @@ -153,33 +163,33 @@ y <- rnorm(50) yrep <- matrix(rnorm(5000, 0, 2), ncol = 50) color_scheme_set("brightblue") -ppc_ribbon(y, yrep) ppc_intervals(y, yrep) +ppc_ribbon(y, yrep) +ppc_ribbon(y, yrep, y_draw = "points") +\dontrun{ +ppc_ribbon(y, yrep, y_draw = "both") +} -# change x axis to y values (instead of indices) and add x = y line -ppc_intervals(y, yrep, x = y) + abline_01() - +ppc_intervals(y, yrep, size = 1.5, fatten = 0) # remove the yrep point estimates color_scheme_set("teal") year <- 1950:1999 -ppc_ribbon(y, yrep, x = year, alpha = 0, size = 0.75) + ggplot2::xlab("Year") +ppc_intervals(y, yrep, x = year, fatten = 1) + ggplot2::xlab("Year") +ppc_ribbon(y, yrep, x = year) + ggplot2::xlab("Year") color_scheme_set("pink") year <- rep(2000:2009, each = 5) group <- gl(5, 1, length = 50, labels = LETTERS[1:5]) -ppc_ribbon_grouped(y, yrep, x = year, group) + +ppc_ribbon_grouped(y, yrep, x = year, group, y_draw = "both") + ggplot2::scale_x_continuous(breaks = pretty) -ppc_ribbon_grouped( - y, yrep, x = year, group, - facet_args = list(scales = "fixed"), - alpha = 1, - size = 2 -) + +ppc_ribbon_grouped(y, yrep, x = year, group, + facet_args = list(scales = "fixed")) + xaxis_text(FALSE) + xaxis_ticks(FALSE) + panel_bg(fill = "gray20") +# get the data frames used to make the ggplots ppc_dat <- ppc_intervals_data(y, yrep, x = year, prob = 0.5) ppc_group_dat <- ppc_intervals_data(y, yrep, x = year, group = group, prob = 0.5) @@ -189,12 +199,15 @@ fit <- stan_glmer(mpg ~ wt + (1|cyl), data = mtcars, refresh = 0) yrep <- posterior_predict(fit) color_scheme_set("purple") -with(mtcars, ppc_intervals(mpg, yrep, x = wt, prob = 0.5)) + +ppc_intervals(y = mtcars$mpg, yrep = yrep, x = mtcars$wt, prob = 0.8) + panel_bg(fill="gray90", color = NA) + grid_lines(color = "white") -ppc_intervals_grouped(y = mtcars$mpg, yrep, prob = 0.8, - x = mtcars$wt, group = mtcars$cyl) +ppc_ribbon(y = mtcars$mpg, yrep = yrep, x = mtcars$wt, + prob = 0.6, prob_outer = 0.8) + +ppc_ribbon_grouped(y = mtcars$mpg, yrep = yrep, x = mtcars$wt, + group = mtcars$cyl) color_scheme_set("gray") @@ -203,13 +216,21 @@ ppc_intervals(mtcars$mpg, yrep, prob = 0.5) + labels = rownames(mtcars), breaks = 1:nrow(mtcars) ) + - xaxis_text(angle = -70, vjust = 1, hjust = 0) + xaxis_text(angle = -70, vjust = 1, hjust = 0) + + xaxis_title(FALSE) } } \references{ +Gabry, J. , Simpson, D. , Vehtari, A. , Betancourt, M. and +Gelman, A. (2019), Visualization in Bayesian workflow. +\emph{J. R. Stat. Soc. A}, 182: 389-402. doi:10.1111/rssa.12378. +(\href{https://rss.onlinelibrary.wiley.com/doi/full/10.1111/rssa.12378}{journal version}, +\href{https://arxiv.org/abs/1709.01449}{arXiv preprint}, +\href{https://github.com/jgabry/bayes-vis-paper}{code on GitHub}) + Gelman, A., Carlin, J. B., Stern, H. S., Dunson, D. B., Vehtari, A., and Rubin, D. B. (2013). \emph{Bayesian Data Analysis.} Chapman & Hall/CRC Press, London, third edition. (Ch. 6) diff --git a/man/PPC-loo.Rd b/man/PPC-loo.Rd index dbfd64eb..141fe385 100644 --- a/man/PPC-loo.Rd +++ b/man/PPC-loo.Rd @@ -71,8 +71,9 @@ ppc_loo_intervals( ..., prob = 0.5, prob_outer = 0.9, + alpha = 0.33, size = 1, - fatten = 3, + fatten = 2.5, order = c("index", "median") ) @@ -93,12 +94,13 @@ ppc_loo_ribbon( \arguments{ \item{y}{A vector of observations. See \strong{Details}.} -\item{yrep}{An \eqn{S} by \eqn{N} matrix of draws from the posterior -predictive distribution, where \eqn{S} is the size of the posterior sample -(or subset of the posterior sample used to generate \code{yrep}) and \eqn{N} is -the number of observations (the length of \code{y}). The columns of \code{yrep} -should be in the same order as the data points in \code{y} for the plots to make -sense. See \strong{Details} for additional instructions.} +\item{yrep}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{yrep}. The number of columns, +\code{N} is the number of predicted observations (\code{length(y)}). The columns of +\code{yrep} should be in the same order as the data points in \code{y} for the plots +to make sense. See the \strong{Details} and \strong{Plot Descriptions} sections for +additional advice specific to particular plots.} \item{lw}{A matrix of (smoothed) log weights with the same dimensions as \code{yrep}. See \code{\link[loo:psis]{loo::psis()}} and the associated \code{weights()} method as well as @@ -173,7 +175,7 @@ five columns in the following order: lower outer interval, lower inner interval, median (50\%), upper inner interval and upper outer interval (column names are ignored).} -\item{prob, prob_outer}{Values between 0 and 1 indicating the desired +\item{prob, prob_outer}{Values between \code{0} and \code{1} indicating the desired probability mass to include in the inner and outer intervals. The defaults are \code{prob=0.5} and \code{prob_outer=0.9}.} @@ -238,14 +240,15 @@ fit <- stan_lmer( + (1 + floor | county), data = radon, iter = 1000, - chains = 2 # ,cores = 2 + chains = 2, + cores = 2 ) y <- radon$log_radon yrep <- posterior_predict(fit) -loo1 <- loo(fit, save_psis = TRUE, cores = 2) +loo1 <- loo(fit, save_psis = TRUE, cores = 4) psis1 <- loo1$psis_object -lw <- weights(psis1) +lw <- weights(psis1) # normalized log weights # marginal predictive check using LOO probability integral transform color_scheme_set("orange") diff --git a/man/PPC-overview.Rd b/man/PPC-overview.Rd index b982f127..16d3f0ff 100644 --- a/man/PPC-overview.Rd +++ b/man/PPC-overview.Rd @@ -5,17 +5,20 @@ \alias{PPC} \title{Graphical posterior predictive checking} \description{ -The \strong{bayesplot} PPC module provides various plotting functions for creating -graphical displays comparing observed data to simulated data from the -posterior (or prior) predictive distribution. See below for a brief -discussion of the ideas behind posterior predictive checking, a description -of the structure of this package, and tips on providing an interface to -\strong{bayesplot} from another package. +The \strong{bayesplot} PPC module provides various plotting functions +for creating graphical displays comparing observed data to simulated data +from the posterior (or prior) predictive distribution. See the sections +below for a brief discussion of the ideas behind posterior predictive +checking, an overview of the available PPC plots, and tips on providing an +interface to \strong{bayesplot} from another package. + +For plots of posterior (or prior) predictive distributions that do \emph{not} +include observed data see \link{PPD-overview} instead. } \details{ -The idea behind posterior predictive checking is simple: if a model is a good -fit then we should be able to use it to generate data that looks a lot like -the data we observed. +The idea behind posterior predictive checking is simple: if a model +is a good fit then we should be able to use it to generate data that looks +a lot like the data we observed. \subsection{Posterior predictive distribution}{ To generate the data used for posterior predictive checks we simulate from @@ -56,40 +59,41 @@ from the prior predictive distribution instead of the posterior predictive distribution. See Gabry et al. (2019) for more on prior predictive checking and when it is reasonable to compare the prior predictive distribution to the observed data. If you want to avoid using the observed data for prior -predictive checks, then the \code{y} argument to the PPC plotting functions can be -used to provide plausible or implausible \code{y} values that you want to compare -to the prior predictive realizations. +predictive checks then you can use the \strong{bayesplot} \link{PPD} plots instead, +which do not take a \code{y} argument, or you can use the PPC plots but provide +plausible or implausible \code{y} values that you want to compare to the prior +predictive realizations. } } \section{PPC plotting functions}{ The plotting functions for prior and -posterior predictive checking are organized into several categories, each -with its own documentation: +posterior predictive checking all have the prefix \code{ppc_} and all require +the arguments \code{y}, a vector of observations, and \code{yrep}, a matrix of +replications (in-sample predictions). The plots are organized into several +categories, each with its own documentation: \itemize{ -\item \link[=PPC-distributions]{Distributions}: Histograms, kernel density -estimates, boxplots, and other plots comparing the empirical distribution -of data \code{y} to the distributions of individual simulated datasets (rows) -in \code{yrep}. -\item \link[=PPC-test-statistics]{Statistics}: The distribution of a statistic, -or a pair of statistics, over the simulated datasets (rows) in \code{yrep} -compared to value of the statistic(s) computed from \code{y}. -\item \link[=PPC-intervals]{Intervals}: Interval estimates of \code{yrep} with \code{y} +\item \link{PPC-distributions}: Histograms, kernel density estimates, boxplots, and +other plots comparing the empirical distribution of data \code{y} to the +distributions of individual simulated datasets (rows) in \code{yrep}. +\item \link{PPC-test-statistics}: The distribution of a statistic, or a pair of +statistics, over the simulated datasets (rows) in \code{yrep} compared to value of +the statistic(s) computed from \code{y}. +\item \link{PPC-intervals}: Interval estimates of \code{yrep} with \code{y} overlaid. The x-axis variable can be optionally specified by the user (e.g. to plot against a predictor variable or over time). -\item \link[=PPC-errors]{Predictive errors}: Plots of predictive errors -(\code{y - yrep}) computed from \code{y} and each of the simulated datasets (rows) -in \code{yrep}. For binomial models binned error plots are also available. -\item \link[=PPC-scatterplots]{Scatterplots}: Scatterplots (and similar -visualizations) of the data \code{y} vs. individual simulated datasets -(rows) in \code{yrep}, or vs. the average value of the distributions of each -data point (columns) in \code{yrep}. -\item \link[=PPC-discrete]{Plots for discrete outcomes}: PPC functions that can -only be used if \code{y} and \code{yrep} are discrete. For example, rootograms for -count outcomes and bar plots for ordinal, categorical, and -multinomial outcomes. -\item \link[=PPC-loo]{LOO predictive checks}: PPC functions for predictive checks -based on (approximate) leave-one-out (LOO) cross-validation. -\item \link[=PPC-censoring]{Censored data}: PPC functions comparing the empirical +\item \link{PPC-errors}: Plots of predictive errors (\code{y - yrep}) computed from \code{y} and +each of the simulated datasets (rows) in \code{yrep}. For binomial models binned +error plots are also available. +\item \link{PPC-scatterplots}: Scatterplots (and similar visualizations) of the data +\code{y} vs. individual simulated datasets (rows) in \code{yrep}, or vs. the average +value of the distributions of each data point (columns) in \code{yrep}. +\item \link{PPC-discrete}: PPC functions that can only be used if \code{y} and \code{yrep} are +discrete. For example, rootograms for count outcomes and bar plots for +ordinal, categorical, and multinomial outcomes. +\item \link{PPC-loo}: PPC functions for predictive checks based on (approximate) +leave-one-out (LOO) cross-validation. +' +\item \link{PPC-censoring}: PPC functions comparing the empirical distribution of censored data \code{y} to the distributions of individual simulated datasets (rows) in \code{yrep}. } diff --git a/man/PPC-scatterplots.Rd b/man/PPC-scatterplots.Rd index 2567b8f7..64963c40 100644 --- a/man/PPC-scatterplots.Rd +++ b/man/PPC-scatterplots.Rd @@ -5,35 +5,72 @@ \alias{ppc_scatter} \alias{ppc_scatter_avg} \alias{ppc_scatter_avg_grouped} +\alias{ppc_scatter_data} +\alias{ppc_scatter_avg_data} \title{PPC scatterplots} \usage{ -ppc_scatter(y, yrep, ..., size = 2.5, alpha = 0.8) +ppc_scatter( + y, + yrep, + ..., + facet_args = list(), + size = 2.5, + alpha = 0.8, + ref_line = TRUE +) -ppc_scatter_avg(y, yrep, ..., size = 2.5, alpha = 0.8) +ppc_scatter_avg(y, yrep, ..., size = 2.5, alpha = 0.8, ref_line = TRUE) -ppc_scatter_avg_grouped(y, yrep, group, ..., size = 2.5, alpha = 0.8) +ppc_scatter_avg_grouped( + y, + yrep, + group, + ..., + facet_args = list(), + size = 2.5, + alpha = 0.8, + ref_line = TRUE +) + +ppc_scatter_data(y, yrep) + +ppc_scatter_avg_data(y, yrep, group = NULL) } \arguments{ \item{y}{A vector of observations. See \strong{Details}.} -\item{yrep}{An \eqn{S} by \eqn{N} matrix of draws from the posterior -predictive distribution, where \eqn{S} is the size of the posterior sample -(or subset of the posterior sample used to generate \code{yrep}) and \eqn{N} is -the number of observations (the length of \code{y}). The columns of \code{yrep} -should be in the same order as the data points in \code{y} for the plots to make -sense. See \strong{Details} for additional instructions.} +\item{yrep}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{yrep}. The number of columns, +\code{N} is the number of predicted observations (\code{length(y)}). The columns of +\code{yrep} should be in the same order as the data points in \code{y} for the plots +to make sense. See the \strong{Details} and \strong{Plot Descriptions} sections for +additional advice specific to particular plots.} \item{...}{Currently unused.} +\item{facet_args}{A named list of arguments (other than \code{facets}) passed +to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} or \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} +to control faceting. Note: if \code{scales} is not included in \code{facet_args} +then \strong{bayesplot} may use \code{scales="free"} as the default (depending +on the plot) instead of the \strong{ggplot2} default of \code{scales="fixed"}.} + \item{size, alpha}{Arguments passed to \code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} to control the appearance of the points.} -\item{group}{A grouping variable (a vector or factor) of the same length as -\code{y}. Each value in \code{group} is interpreted as the group level -pertaining to the corresponding value of \code{y}.} +\item{ref_line}{If \code{TRUE} (the default) a dashed line with intercept 0 and +slope 1 is drawn behind the scatter plot.} + +\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 +to the corresponding observation.} } \value{ -A ggplot object that can be further customized using the \strong{ggplot2} package. +The plotting functions return a ggplot object that can be further +customized using the \strong{ggplot2} package. The functions with suffix +\verb{_data()} return the data that would have been drawn by the plotting +function. } \description{ Scatterplots of the observed data \code{y} vs. simulated/replicated data @@ -41,8 +78,8 @@ Scatterplots of the observed data \code{y} vs. simulated/replicated data \strong{Plot Descriptions} and \strong{Details} sections, below. } \details{ -For Binomial data, the plots will typically be most useful if -\code{y} and \code{yrep} contain the "success" proportions (not discrete +For Binomial data, the plots may be more useful if +the input contains the "success" \emph{proportions} (not discrete "success" or "failure" counts). } \section{Plot Descriptions}{ @@ -54,9 +91,11 @@ against that row of \code{yrep}. For this plot \code{yrep} should only contain a small number of rows. } \item{\code{ppc_scatter_avg()}}{ -A scatterplot of \code{y} against the average values of \code{yrep}, i.e., -the points \verb{(mean(yrep[, n]), y[n])}, where each \code{yrep[, n]} is -a vector of length equal to the number of posterior draws. +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). } \item{\code{ppc_scatter_avg_grouped()}}{ The same as \code{ppc_scatter_avg()}, but a separate plot is generated for @@ -70,6 +109,10 @@ y <- example_y_data() yrep <- example_yrep_draws() p1 <- ppc_scatter_avg(y, yrep) p1 + +# don't draw line x=y +ppc_scatter_avg(y, yrep, ref_line = FALSE) + p2 <- ppc_scatter(y, yrep[20:23, ], alpha = 0.5, size = 1.5) p2 @@ -78,8 +121,13 @@ lims <- ggplot2::lims(x = c(0, 160), y = c(0, 160)) p1 + lims p2 + lims +# for ppc_scatter_avg_grouped the default is to allow the facets +# to have different x and y axes group <- example_group_data() -ppc_scatter_avg_grouped(y, yrep, group, alpha = 0.7) + lims +ppc_scatter_avg_grouped(y, yrep, group) + +# let x-axis vary but force y-axis to be the same +ppc_scatter_avg_grouped(y, yrep, group, facet_args = list(scales = "free_x")) } \references{ diff --git a/man/PPC-test-statistics.Rd b/man/PPC-test-statistics.Rd index 2e724bc3..85b815b5 100644 --- a/man/PPC-test-statistics.Rd +++ b/man/PPC-test-statistics.Rd @@ -2,10 +2,13 @@ % Please edit documentation in R/ppc-test-statistics.R \name{PPC-test-statistics} \alias{PPC-test-statistics} +\alias{PPC-statistics} \alias{ppc_stat} \alias{ppc_stat_grouped} +\alias{ppc_stat_freqpoly} \alias{ppc_stat_freqpoly_grouped} \alias{ppc_stat_2d} +\alias{ppc_stat_data} \title{PPC test statistics} \usage{ ppc_stat( @@ -30,6 +33,16 @@ ppc_stat_grouped( freq = TRUE ) +ppc_stat_freqpoly( + y, + yrep, + stat = "mean", + ..., + facet_args = list(), + binwidth = NULL, + freq = TRUE +) + ppc_stat_freqpoly_grouped( y, yrep, @@ -42,23 +55,26 @@ ppc_stat_freqpoly_grouped( ) ppc_stat_2d(y, yrep, stat = c("mean", "sd"), ..., size = 2.5, alpha = 0.7) + +ppc_stat_data(y, yrep, group = NULL, stat) } \arguments{ \item{y}{A vector of observations. See \strong{Details}.} -\item{yrep}{An \eqn{S} by \eqn{N} matrix of draws from the posterior -predictive distribution, where \eqn{S} is the size of the posterior sample -(or subset of the posterior sample used to generate \code{yrep}) and \eqn{N} is -the number of observations (the length of \code{y}). The columns of \code{yrep} -should be in the same order as the data points in \code{y} for the plots to make -sense. See \strong{Details} for additional instructions.} - -\item{stat}{A single function or a string naming a function, except for -\code{ppc_stat_2d()} which requires a vector of exactly two functions or -function names. In all cases the function(s) should take a vector input and -return a scalar statistic. If specified as a string (or strings) then -the legend will display function names. If specified as a function (or -functions) then generic naming is used in the legend.} +\item{yrep}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{yrep}. The number of columns, +\code{N} is the number of predicted observations (\code{length(y)}). The columns of +\code{yrep} should be in the same order as the data points in \code{y} for the plots +to make sense. See the \strong{Details} and \strong{Plot Descriptions} sections for +additional advice specific to particular plots.} + +\item{stat}{A single function or a string naming a function, except for the +2D plot which requires a vector of exactly two names or functions. In all +cases the function(s) should take a vector input and return a scalar +statistic. If specified as a string (or strings) then the legend will +display the function name(s). If specified as a function (or functions) +then generic naming is used in the legend.} \item{...}{Currently unused.} @@ -74,19 +90,25 @@ plots the y-axis text is off by default. To view the count or density labels on the y-axis see the \code{\link[=yaxis_text]{yaxis_text()}} convenience function.)} -\item{group}{A grouping variable (a vector or factor) of the same length as -\code{y}. Each value in \code{group} is interpreted as the group level -pertaining to the corresponding value of \code{y}.} +\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 +to the corresponding observation.} \item{facet_args}{A named list of arguments (other than \code{facets}) passed to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} or \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} -to control faceting.} +to control faceting. Note: if \code{scales} is not included in \code{facet_args} +then \strong{bayesplot} may use \code{scales="free"} as the default (depending +on the plot) instead of the \strong{ggplot2} default of \code{scales="fixed"}.} -\item{size, alpha}{Arguments passed to \code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} to control the -appearance of scatterplot points.} +\item{size, alpha}{For the 2D plot only, arguments passed to +\code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} to control the appearance of scatterplot points.} } \value{ -A ggplot object that can be further customized using the \strong{ggplot2} package. +The plotting functions return a ggplot object that can be further +customized using the \strong{ggplot2} package. The functions with suffix +\verb{_data()} return the data that would have been drawn by the plotting +function. } \description{ The distribution of a (test) statistic \code{T(yrep)}, or a pair of (test) @@ -96,28 +118,27 @@ observed value \code{T(y)} computed from the data \code{y}. See the well as \href{https://github.com/jgabry/bayes-vis-paper#readme}{Gabry et al. (2019)}. } \details{ -For Binomial data, the plots will typically be most useful if -\code{y} and \code{yrep} contain the "success" proportions (not discrete +For Binomial data, the plots may be more useful if +the input contains the "success" \emph{proportions} (not discrete "success" or "failure" counts). } \section{Plot Descriptions}{ \describe{ -\item{\code{ppc_stat()}}{ -A histogram of the distribution of a test statistic computed by applying -\code{stat} to each dataset (row) in \code{yrep}. The value of the statistic in the -observed data, \code{stat(y)}, is overlaid as a vertical line. More details on -\code{ppc_stat()} can be found in Gabry et al. (2019). +\item{\code{ppc_stat()}, \code{ppc_stat_freqpoly()}}{ +A histogram or frequency polygon of the distribution of a statistic +computed by applying \code{stat} to each dataset (row) in \code{yrep}. The value of +the statistic in the observed data, \code{stat(y)}, is overlaid as a vertical +line. More details and example usage of \code{ppc_stat()} can be found in Gabry +et al. (2019). } \item{\code{ppc_stat_grouped()},\code{ppc_stat_freqpoly_grouped()}}{ -The same as \code{ppc_stat()}, but a separate plot is generated for each -level of a grouping variable. In the case of -\code{ppc_stat_freqpoly_grouped()} the plots are frequency polygons rather -than histograms. More details on \code{ppc_stat_grouped()} can be found in -Gabry et al. (2019). +The same as \code{ppc_stat()} and \code{ppc_stat_freqpoly()}, but a separate plot is +generated for each level of a grouping variable. More details and example +usage of \code{ppc_stat_grouped()} can be found in Gabry et al. (2019). } \item{\code{ppc_stat_2d()}}{ -A scatterplot showing the joint distribution of two test statistics +A scatterplot showing the joint distribution of two statistics computed over the datasets (rows) in \code{yrep}. The value of the statistics in the observed data is overlaid as large point. } @@ -129,24 +150,41 @@ y <- example_y_data() yrep <- example_yrep_draws() ppc_stat(y, yrep) ppc_stat(y, yrep, stat = "sd") + legend_none() -ppc_stat_2d(y, yrep) -ppc_stat_2d(y, yrep, stat = c("median", "mean")) + legend_move("bottom") +# use your own function for the 'stat' argument +color_scheme_set("brightblue") +q25 <- function(y) quantile(y, 0.25) +ppc_stat(y, yrep, stat = "q25") # legend includes function name + +# can define the function in the 'stat' argument instead of +# using its name but then the legend doesn't include the function name +ppc_stat(y, yrep, stat = function(y) quantile(y, 0.25)) + +# plots by group color_scheme_set("teal") group <- example_group_data() ppc_stat_grouped(y, yrep, group) +ppc_stat_grouped(y, yrep, group) + yaxis_text() -color_scheme_set("mix-red-blue") -ppc_stat_freqpoly_grouped(y, yrep, group, facet_args = list(nrow = 2)) +# force y-axes to have same scales, allow x axis to vary +ppc_stat_grouped(y, yrep, group, facet_args = list(scales = "free_x")) + yaxis_text() -# use your own function to compute test statistics -color_scheme_set("brightblue") -q25 <- function(y) quantile(y, 0.25) -ppc_stat(y, yrep, stat = "q25") # legend includes function name +# the freqpoly plots use frequency polygons instead of histograms +ppc_stat_freqpoly(y, yrep, stat = "median") +ppc_stat_freqpoly_grouped(y, yrep, group, stat = "median", facet_args = list(nrow = 2)) -# can define the function in the 'stat' argument but then -# the legend doesn't include a function name -ppc_stat(y, yrep, stat = function(y) quantile(y, 0.25)) +# ppc_stat_2d allows 2 statistics and makes a scatterplot +bayesplot_theme_set(ggplot2::theme_linedraw()) +color_scheme_set("viridisE") +ppc_stat_2d(y, yrep, stat = c("mean", "sd")) + +bayesplot_theme_set(ggplot2::theme_grey()) +color_scheme_set("brewer-Paired") +ppc_stat_2d(y, yrep, stat = c("median", "mad")) + +# reset aesthetics +color_scheme_set() +bayesplot_theme_set() } \references{ diff --git a/man/PPD-distributions.Rd b/man/PPD-distributions.Rd new file mode 100644 index 00000000..8aef15c7 --- /dev/null +++ b/man/PPD-distributions.Rd @@ -0,0 +1,147 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ppd-distributions.R +\name{PPD-distributions} +\alias{PPD-distributions} +\alias{ppd_data} +\alias{ppd_dens_overlay} +\alias{ppd_ecdf_overlay} +\alias{ppd_dens} +\alias{ppd_hist} +\alias{ppd_freqpoly} +\alias{ppd_freqpoly_grouped} +\alias{ppd_boxplot} +\title{PPD distributions} +\usage{ +ppd_data(ypred, group = NULL) + +ppd_dens_overlay( + ypred, + ..., + size = 0.25, + alpha = 0.7, + trim = FALSE, + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + n_dens = 1024 +) + +ppd_ecdf_overlay( + ypred, + ..., + discrete = FALSE, + pad = TRUE, + size = 0.25, + alpha = 0.7 +) + +ppd_dens(ypred, ..., trim = FALSE, size = 0.5, alpha = 1) + +ppd_hist(ypred, ..., binwidth = NULL, breaks = NULL, freq = TRUE) + +ppd_freqpoly(ypred, ..., binwidth = NULL, freq = TRUE, size = 0.5, alpha = 1) + +ppd_freqpoly_grouped( + ypred, + group, + ..., + binwidth = NULL, + freq = TRUE, + size = 0.5, + alpha = 1 +) + +ppd_boxplot(ypred, ..., notch = TRUE, size = 0.5, alpha = 1) +} +\arguments{ +\item{ypred}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{ypred}. The number of +columns, \code{N}, is the number of predicted observations.} + +\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 +to the corresponding observation.} + +\item{...}{Currently unused.} + +\item{size}{Passed to the appropriate geom to control the appearance of +the predictive distributions.} + +\item{alpha}{Passed to the appropriate geom to control the appearance of +the predictive distributions.} + +\item{trim}{A logical scalar passed to \code{\link[ggplot2:geom_density]{ggplot2::geom_density()}}.} + +\item{bw}{Optional arguments passed to +\code{\link[stats:density]{stats::density()}} to override default kernel density estimation +parameters. \code{n_dens} defaults to \code{1024}.} + +\item{adjust}{Optional arguments passed to +\code{\link[stats:density]{stats::density()}} to override default kernel density estimation +parameters. \code{n_dens} defaults to \code{1024}.} + +\item{kernel}{Optional arguments passed to +\code{\link[stats:density]{stats::density()}} to override default kernel density estimation +parameters. \code{n_dens} defaults to \code{1024}.} + +\item{n_dens}{Optional arguments passed to +\code{\link[stats:density]{stats::density()}} to override default kernel density estimation +parameters. \code{n_dens} defaults to \code{1024}.} + +\item{discrete}{For \code{ppc_ecdf_overlay()}, should the data be treated as +discrete? The default is \code{FALSE}, in which case \code{geom="line"} is +passed to \code{\link[ggplot2:stat_ecdf]{ggplot2::stat_ecdf()}}. If \code{discrete} is set to +\code{TRUE} then \code{geom="step"} is used.} + +\item{pad}{A logical scalar passed to \code{\link[ggplot2:stat_ecdf]{ggplot2::stat_ecdf()}}.} + +\item{binwidth}{Passed to \code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} to override +the default binwidth.} + +\item{breaks}{Passed to \code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} as an +alternative to \code{binwidth}.} + +\item{freq}{For histograms, \code{freq=TRUE} (the default) puts count on the +y-axis. Setting \code{freq=FALSE} puts density on the y-axis. (For many +plots the y-axis text is off by default. To view the count or density +labels on the y-axis see the \code{\link[=yaxis_text]{yaxis_text()}} convenience +function.)} + +\item{notch}{For the box plot, a logical scalar passed to +\code{\link[ggplot2:geom_boxplot]{ggplot2::geom_boxplot()}}. Note: unlike \code{geom_boxplot()}, the default is +\code{notch=TRUE}.} +} +\value{ +The plotting functions return a ggplot object that can be further +customized using the \strong{ggplot2} package. The functions with suffix +\verb{_data()} return the data that would have been drawn by the plotting +function. +} +\description{ +Plot posterior or prior predictive distributions. Each of these functions +makes the same plot as the corresponding \code{\link[=PPC-distributions]{ppc_}} function +but without plotting any observed data \code{y}. The \strong{Plot Descriptions} section +at \link{PPC-distributions} has details on the individual plots. +} +\details{ +For Binomial data, the plots may be more useful if +the input contains the "success" \emph{proportions} (not discrete +"success" or "failure" counts). +} +\examples{ +# difference between ppd_dens_overlay() and ppc_dens_overlay() +color_scheme_set("brightblue") +preds <- example_yrep_draws() +ppd_dens_overlay(ypred = preds[1:50, ]) +ppc_dens_overlay(y = example_y_data(), yrep = preds[1:50, ]) + +} +\seealso{ +Other PPDs: +\code{\link{PPD-intervals}}, +\code{\link{PPD-overview}}, +\code{\link{PPD-test-statistics}} +} +\concept{PPDs} diff --git a/man/PPD-intervals.Rd b/man/PPD-intervals.Rd new file mode 100644 index 00000000..0a33bfdb --- /dev/null +++ b/man/PPD-intervals.Rd @@ -0,0 +1,189 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ppd-intervals.R +\name{PPD-intervals} +\alias{PPD-intervals} +\alias{ppd_intervals} +\alias{ppd_intervals_grouped} +\alias{ppd_ribbon} +\alias{ppd_ribbon_grouped} +\alias{ppd_intervals_data} +\alias{ppd_ribbon_data} +\title{PPD intervals} +\usage{ +ppd_intervals( + ypred, + x = NULL, + ..., + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 1, + fatten = 2.5 +) + +ppd_intervals_grouped( + ypred, + x = NULL, + group, + ..., + facet_args = list(), + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 1, + fatten = 2.5 +) + +ppd_ribbon( + ypred, + x = NULL, + ..., + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 0.25 +) + +ppd_ribbon_grouped( + ypred, + x = NULL, + group, + ..., + facet_args = list(), + prob = 0.5, + prob_outer = 0.9, + alpha = 0.33, + size = 0.25 +) + +ppd_intervals_data( + ypred, + x = NULL, + group = NULL, + ..., + prob = 0.5, + prob_outer = 0.9 +) + +ppd_ribbon_data( + ypred, + x = NULL, + group = NULL, + ..., + prob = 0.5, + prob_outer = 0.9 +) +} +\arguments{ +\item{ypred}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{ypred}. The number of +columns, \code{N}, is the number of predicted observations.} + +\item{x}{A numeric vector to use as the x-axis +variable. For example, \code{x} could be a predictor variable from a +regression model, a time variable for time-series models, etc. If \code{x} +is missing or \code{NULL} then the observation index is used for the x-axis.} + +\item{...}{Currently unused.} + +\item{prob}{Values between \code{0} and \code{1} indicating the desired +probability mass to include in the inner and outer intervals. The defaults +are \code{prob=0.5} and \code{prob_outer=0.9}.} + +\item{prob_outer}{Values between \code{0} and \code{1} indicating the desired +probability mass to include in the inner and outer intervals. The defaults +are \code{prob=0.5} and \code{prob_outer=0.9}.} + +\item{alpha}{Arguments passed to geoms. For ribbon plots \code{alpha} +is passed to \code{\link[ggplot2:geom_ribbon]{ggplot2::geom_ribbon()}} to control the opacity of the outer +ribbon and \code{size} is passed to \code{\link[ggplot2:geom_path]{ggplot2::geom_line()}} to control the size +of the line representing the median prediction (\code{size=0} will remove the +line). For interval plots \code{alpha}, \code{size} and \code{fatten} are passed to +\code{\link[ggplot2:geom_linerange]{ggplot2::geom_pointrange()}} (\code{fatten=0} will remove the point estimates).} + +\item{size}{Arguments passed to geoms. For ribbon plots \code{alpha} +is passed to \code{\link[ggplot2:geom_ribbon]{ggplot2::geom_ribbon()}} to control the opacity of the outer +ribbon and \code{size} is passed to \code{\link[ggplot2:geom_path]{ggplot2::geom_line()}} to control the size +of the line representing the median prediction (\code{size=0} will remove the +line). For interval plots \code{alpha}, \code{size} and \code{fatten} are passed to +\code{\link[ggplot2:geom_linerange]{ggplot2::geom_pointrange()}} (\code{fatten=0} will remove the point estimates).} + +\item{fatten}{Arguments passed to geoms. For ribbon plots \code{alpha} +is passed to \code{\link[ggplot2:geom_ribbon]{ggplot2::geom_ribbon()}} to control the opacity of the outer +ribbon and \code{size} is passed to \code{\link[ggplot2:geom_path]{ggplot2::geom_line()}} to control the size +of the line representing the median prediction (\code{size=0} will remove the +line). For interval plots \code{alpha}, \code{size} and \code{fatten} are passed to +\code{\link[ggplot2:geom_linerange]{ggplot2::geom_pointrange()}} (\code{fatten=0} will remove the point estimates).} + +\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 +to the corresponding observation.} + +\item{facet_args}{A named list of arguments (other than \code{facets}) passed +to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} or \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} +to control faceting. Note: if \code{scales} is not included in \code{facet_args} +then \strong{bayesplot} may use \code{scales="free"} as the default (depending +on the plot) instead of the \strong{ggplot2} default of \code{scales="fixed"}.} +} +\value{ +The plotting functions return a ggplot object that can be further +customized using the \strong{ggplot2} package. The functions with suffix +\verb{_data()} return the data that would have been drawn by the plotting +function. +} +\description{ +Medians and central interval estimates of posterior or prior predictive +distributions. Each of these functions makes the same plot as the +corresponding \code{\link[=PPC-intervals]{ppc_}} function but without plotting any +observed data \code{y}. The \strong{Plot Descriptions} section at \link{PPC-intervals} has +details on the individual plots. +} +\examples{ +color_scheme_set("brightblue") +ypred <- example_yrep_draws() +x <- example_x_data() +group <- example_group_data() + +ppd_intervals(ypred[, 1:50]) +ppd_intervals(ypred[, 1:50], fatten = .5) +ppd_intervals(ypred[, 1:50], prob_outer = 0.75, size = 2, fatten = 0) + +# put a predictor variable on the x-axis +ppd_intervals(ypred[, 1:100], x = x[1:100], size = 1, fatten = 0) + + ggplot2::labs(y = "Prediction", x = "Some variable of interest") + +# with a grouping variable too +ppd_intervals_grouped( + ypred = ypred[, 1:100], + x = x[1:100], + group = group[1:100], + size = 2, + fatten = 0, + facet_args = list(nrow = 2) +) + +# even reducing size, ppd_intervals is too cluttered when there are many +# observations included (ppd_ribbon is better) +ppd_intervals(ypred, size = 0.5, fatten = 0.1) +ppd_ribbon(ypred) +ppd_ribbon(ypred, size = 0) # remove line showing median prediction + + +} +\references{ +Gabry, J. , Simpson, D. , Vehtari, A. , Betancourt, M. and +Gelman, A. (2019), Visualization in Bayesian workflow. +\emph{J. R. Stat. Soc. A}, 182: 389-402. doi:10.1111/rssa.12378. +(\href{https://rss.onlinelibrary.wiley.com/doi/full/10.1111/rssa.12378}{journal version}, +\href{https://arxiv.org/abs/1709.01449}{arXiv preprint}, +\href{https://github.com/jgabry/bayes-vis-paper}{code on GitHub}) +} +\seealso{ +Other PPDs: +\code{\link{PPD-distributions}}, +\code{\link{PPD-overview}}, +\code{\link{PPD-test-statistics}} +} +\concept{PPDs} diff --git a/man/PPD-overview.Rd b/man/PPD-overview.Rd new file mode 100644 index 00000000..5c8ec5ef --- /dev/null +++ b/man/PPD-overview.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ppd-overview.R +\name{PPD-overview} +\alias{PPD-overview} +\alias{PPD} +\title{Plots of posterior or prior predictive distributions} +\description{ +The \strong{bayesplot} PPD module provides various plotting functions +for creating graphical displays of simulated data from the posterior or +prior predictive distribution. These plots are essentially the same as the +corresponding \link{PPC} plots but without showing any observed data. Because +these are not "checks" compared to data we use PPD (for prior/posterior +predictive distribution) instead of PPC (for prior/posterior predictive +check). +} +\section{PPD plotting functions}{ + The functions for plotting prior and +posterior predictive distributions without observed data each have the +prefix \code{ppd_} and all have a required argument \code{ypred} (a matrix of +predictions). The plots are organized into several categories, each with +its own documentation: +\itemize{ +\item \link{PPD-distributions}: Histograms, kernel density estimates, boxplots, and +other plots of multiple simulated datasets (rows) in \code{ypred}. These are the +same as the plots in \link{PPC-distributions} but without including any +comparison to \code{y}. +\item \link{PPD-intervals}: Interval estimates for each predicted observations +(columns) in \code{ypred}. The x-axis variable can be optionally specified by +the user (e.g. to plot against against a predictor variable or over +time).These are the same as the plots in \link{PPC-intervals} but without +including any comparison to \code{y}. +\item \link{PPD-test-statistics}: The distribution of a statistic, or a pair of +statistics, over the simulated datasets (rows) in \code{ypred}. These are the +same as the plots in \link{PPC-test-statistics} but without including any +comparison to \code{y}. +} +} + +\references{ +Gabry, J. , Simpson, D. , Vehtari, A. , Betancourt, M. and +Gelman, A. (2019), Visualization in Bayesian workflow. +\emph{J. R. Stat. Soc. A}, 182: 389-402. doi:10.1111/rssa.12378. +(\href{https://rss.onlinelibrary.wiley.com/doi/full/10.1111/rssa.12378}{journal version}, +\href{https://arxiv.org/abs/1709.01449}{arXiv preprint}, +\href{https://github.com/jgabry/bayes-vis-paper}{code on GitHub}) +} +\seealso{ +Other PPDs: +\code{\link{PPD-distributions}}, +\code{\link{PPD-intervals}}, +\code{\link{PPD-test-statistics}} +} +\concept{PPDs} diff --git a/man/PPD-test-statistics.Rd b/man/PPD-test-statistics.Rd new file mode 100644 index 00000000..015d627d --- /dev/null +++ b/man/PPD-test-statistics.Rd @@ -0,0 +1,144 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ppd-test-statistics.R +\name{PPD-test-statistics} +\alias{PPD-test-statistics} +\alias{PPD-statistics} +\alias{ppd_stat} +\alias{ppd_stat_grouped} +\alias{ppd_stat_freqpoly} +\alias{ppd_stat_freqpoly_grouped} +\alias{ppd_stat_2d} +\alias{ppd_stat_data} +\title{PPD test statistics} +\usage{ +ppd_stat( + ypred, + stat = "mean", + ..., + binwidth = NULL, + breaks = NULL, + freq = TRUE +) + +ppd_stat_grouped( + ypred, + group, + stat = "mean", + ..., + facet_args = list(), + binwidth = NULL, + breaks = NULL, + freq = TRUE +) + +ppd_stat_freqpoly( + ypred, + stat = "mean", + ..., + facet_args = list(), + binwidth = NULL, + freq = TRUE +) + +ppd_stat_freqpoly_grouped( + ypred, + group, + stat = "mean", + ..., + facet_args = list(), + binwidth = NULL, + freq = TRUE +) + +ppd_stat_2d(ypred, stat = c("mean", "sd"), ..., size = 2.5, alpha = 0.7) + +ppd_stat_data(ypred, group = NULL, stat) +} +\arguments{ +\item{ypred}{An \code{S} by \code{N} matrix of draws from the posterior (or prior) +predictive distribution. The number of rows, \code{S}, is the size of the +posterior (or prior) sample used to generate \code{ypred}. The number of +columns, \code{N}, is the number of predicted observations.} + +\item{stat}{A single function or a string naming a function, except for the +2D plot which requires a vector of exactly two names or functions. In all +cases the function(s) should take a vector input and return a scalar +statistic. If specified as a string (or strings) then the legend will +display the function name(s). If specified as a function (or functions) +then generic naming is used in the legend.} + +\item{...}{Currently unused.} + +\item{binwidth}{Passed to \code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} to override +the default binwidth.} + +\item{breaks}{Passed to \code{\link[ggplot2:geom_histogram]{ggplot2::geom_histogram()}} as an +alternative to \code{binwidth}.} + +\item{freq}{For histograms, \code{freq=TRUE} (the default) puts count on the +y-axis. Setting \code{freq=FALSE} puts density on the y-axis. (For many +plots the y-axis text is off by default. To view the count or density +labels on the y-axis see the \code{\link[=yaxis_text]{yaxis_text()}} convenience +function.)} + +\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 +to the corresponding observation.} + +\item{facet_args}{A named list of arguments (other than \code{facets}) passed +to \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}} or \code{\link[ggplot2:facet_grid]{ggplot2::facet_grid()}} +to control faceting. Note: if \code{scales} is not included in \code{facet_args} +then \strong{bayesplot} may use \code{scales="free"} as the default (depending +on the plot) instead of the \strong{ggplot2} default of \code{scales="fixed"}.} + +\item{size}{For the 2D plot only, arguments passed to +\code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} to control the appearance of scatterplot points.} + +\item{alpha}{For the 2D plot only, arguments passed to +\code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} to control the appearance of scatterplot points.} +} +\value{ +The plotting functions return a ggplot object that can be further +customized using the \strong{ggplot2} package. The functions with suffix +\verb{_data()} return the data that would have been drawn by the plotting +function. +} +\description{ +The distribution of a (test) statistic \code{T(ypred)}, or a pair of (test) +statistics, over the simulations from the posterior or prior predictive +distribution. Each of these functions makes the same plot as the +corresponding \code{\link[=PPC-test-statistics]{ppc_}} function but without comparing to +any observed data \code{y}. The \strong{Plot Descriptions} section at +\link{PPC-test-statistics} has details on the individual plots. +} +\details{ +For Binomial data, the plots may be more useful if +the input contains the "success" \emph{proportions} (not discrete +"success" or "failure" counts). +} +\examples{ +yrep <- example_yrep_draws() +ppd_stat(yrep) +ppd_stat(yrep, stat = "sd") + legend_none() + +# use your own function for the 'stat' argument +color_scheme_set("brightblue") +q25 <- function(y) quantile(y, 0.25) +ppd_stat(yrep, stat = "q25") # legend includes function name +} +\references{ +Gabry, J. , Simpson, D. , Vehtari, A. , Betancourt, M. and +Gelman, A. (2019), Visualization in Bayesian workflow. +\emph{J. R. Stat. Soc. A}, 182: 389-402. doi:10.1111/rssa.12378. +(\href{https://rss.onlinelibrary.wiley.com/doi/full/10.1111/rssa.12378}{journal version}, +\href{https://arxiv.org/abs/1709.01449}{arXiv preprint}, +\href{https://github.com/jgabry/bayes-vis-paper}{code on GitHub}) +} +\seealso{ +Other PPDs: +\code{\link{PPD-distributions}}, +\code{\link{PPD-intervals}}, +\code{\link{PPD-overview}} +} +\concept{PPDs} diff --git a/man/available_ppc.Rd b/man/available_ppc.Rd index 18c5cc18..c41aaa66 100644 --- a/man/available_ppc.Rd +++ b/man/available_ppc.Rd @@ -2,32 +2,57 @@ % Please edit documentation in R/available-module-functions.R \name{available_ppc} \alias{available_ppc} +\alias{available_ppd} \alias{available_mcmc} -\title{Get or view the names of available plotting functions} +\title{Get or view the names of available plotting or data functions} \usage{ -available_ppc(pattern = NULL, fixed = FALSE, invert = FALSE) +available_ppc(pattern = NULL, fixed = FALSE, invert = FALSE, plots_only = TRUE) -available_mcmc(pattern = NULL, fixed = FALSE, invert = FALSE) +available_ppd(pattern = NULL, fixed = FALSE, invert = FALSE, plots_only = TRUE) + +available_mcmc( + pattern = NULL, + fixed = FALSE, + invert = FALSE, + plots_only = TRUE +) } \arguments{ \item{pattern, fixed, invert}{Passed to \code{\link[base:grep]{base::grep()}}.} + +\item{plots_only}{If \code{TRUE} (the default) only plotting functions are +searched for. If \code{FALSE} then functions that return data for plotting +(functions ending in \verb{_data()}) are also included.} } \value{ A possibly empty character vector of function names with several additional attributes (for use by a custom print method). If \code{pattern} is missing then the returned object contains the names of all available -plotting functions in the \link{MCMC} or \link{PPC} module, depending on +plotting functions in the \link{MCMC}, \link{PPC}, or \link{PPD} module, depending on which function is called. If \code{pattern} is specified then a subset of function names is returned. } \description{ -Get or view the names of available plotting functions +Get or view the names of available plotting or data functions } \examples{ available_mcmc() available_mcmc("nuts") available_mcmc("rhat|neff") + +available_ppc() available_ppc("grouped") available_ppc("grouped", invert = TRUE) +available_ppd() +available_ppd("grouped") + +# can also see which functions that return data are available +available_ppc(plots_only = FALSE) + +# only show the _data functions +available_ppc("_data", plots_only = FALSE) +available_ppd("_data", plots_only = FALSE) +available_mcmc("_data", plots_only = FALSE) + } diff --git a/man/bayesplot-package.Rd b/man/bayesplot-package.Rd index 97d03ffd..e43e457a 100644 --- a/man/bayesplot-package.Rd +++ b/man/bayesplot-package.Rd @@ -7,7 +7,7 @@ \title{\strong{bayesplot}: Plotting for Bayesian Models} \description{ \if{html}{ - \figure{stanlogo.png}{options: width="50px" alt="mc-stan.org"} + \figure{stanlogo.png}{options: width="50" alt="mc-stan.org"} } \emph{Stan Development Team} @@ -36,12 +36,11 @@ The plotting functions in \strong{bayesplot} are organized into several modules: Monte Carlo (MCMC) simulations generated by \emph{any} MCMC algorithm as well as diagnostics. There are also additional functions specifically for use with models fit using the \link[=NUTS]{No-U-Turn Sampler (NUTS)}. -\item \link[=PPC-overview]{PPC}: Graphical prior and posterior predictive +\item \link[=PPC-overview]{PPC}: Graphical (posterior or prior) predictive checks (PPCs). +\item \link[=PPD-overview]{PPD}: Plots of (posterior or prior) predictive +distributions without comparisons to observed data. } - -In future releases modules will be added specifically for -forecasting/out-of-sample prediction and other inference-related tasks. } \section{Resources}{ @@ -88,6 +87,13 @@ ppc_dens_overlay(y, yrep[1:50, ]) color_scheme_set("pink") ppc_stat(y, yrep, stat = "median") + grid_lines() ppc_hist(y, yrep[1:8, ]) + +# Same plots but without y (using ppd_ instead of ppc_) +bayesplot_theme_set(ggplot2::theme_gray()) +ypred <- yrep +ppd_dens_overlay(ypred[1:50, ]) +ppd_stat(ypred, stat = "median") + grid_lines() +ppd_hist(ypred[1:8, ]) } } diff --git a/man/bayesplot_theme_get.Rd b/man/bayesplot_theme_get.Rd index fb346937..661e75bc 100644 --- a/man/bayesplot_theme_get.Rd +++ b/man/bayesplot_theme_get.Rd @@ -81,6 +81,9 @@ mcmc_hist(x) bayesplot_theme_set(theme_dark()) mcmc_hist(x) + panel_bg(fill = "black") +# reset +bayesplot_theme_set() + } \seealso{ \code{\link[=theme_default]{theme_default()}} for the default \strong{bayesplot} theme. diff --git a/tests/testthat/_snaps/ppc-discrete/ppc-bars-default.svg b/tests/testthat/_snaps/ppc-discrete/ppc-bars-default.svg index 69fc4510..403437d7 100644 --- a/tests/testthat/_snaps/ppc-discrete/ppc-bars-default.svg +++ b/tests/testthat/_snaps/ppc-discrete/ppc-bars-default.svg @@ -30,16 +30,16 @@ - - - - - - - - - - + + + + + + + + + + @@ -67,8 +67,8 @@ 4 5 Count - - + + y r e diff --git a/tests/testthat/_snaps/ppc-discrete/ppc-bars-grouped-default.svg b/tests/testthat/_snaps/ppc-discrete/ppc-bars-grouped-default.svg index 7cfa2bbe..94dd1559 100644 --- a/tests/testthat/_snaps/ppc-discrete/ppc-bars-grouped-default.svg +++ b/tests/testthat/_snaps/ppc-discrete/ppc-bars-grouped-default.svg @@ -30,16 +30,18 @@ - - - - - - - - - - + + + + + + + + + + + + @@ -52,16 +54,18 @@ - - - - - - - - - - + + + + + + + + + + + + @@ -122,8 +126,8 @@ Count - - + + y r e diff --git a/tests/testthat/_snaps/ppc-discrete/ppc-bars-grouped-facet-args-prob-size.svg b/tests/testthat/_snaps/ppc-discrete/ppc-bars-grouped-facet-args-prob-size.svg index 88fbe567..4c2fb250 100644 --- a/tests/testthat/_snaps/ppc-discrete/ppc-bars-grouped-facet-args-prob-size.svg +++ b/tests/testthat/_snaps/ppc-discrete/ppc-bars-grouped-facet-args-prob-size.svg @@ -30,16 +30,18 @@ - - - - - - - - - - + + + + + + + + + + + + @@ -52,16 +54,18 @@ - - - - - - - - - - + + + + + + + + + + + + @@ -120,8 +124,8 @@ Count - - + + y r e diff --git a/tests/testthat/_snaps/ppc-discrete/ppc-bars-prob-0-33-width-size-fatten.svg b/tests/testthat/_snaps/ppc-discrete/ppc-bars-prob-0-33-width-size-fatten.svg index 1c4d091a..75d54a32 100644 --- a/tests/testthat/_snaps/ppc-discrete/ppc-bars-prob-0-33-width-size-fatten.svg +++ b/tests/testthat/_snaps/ppc-discrete/ppc-bars-prob-0-33-width-size-fatten.svg @@ -30,16 +30,16 @@ - - - - - - - - - - + + + + + + + + + + @@ -69,8 +69,8 @@ 4 5 Count - - + + y r e diff --git a/tests/testthat/_snaps/ppc-discrete/ppc-bars-width-size-fatten.svg b/tests/testthat/_snaps/ppc-discrete/ppc-bars-width-size-fatten.svg index 1dcb3949..d3e610de 100644 --- a/tests/testthat/_snaps/ppc-discrete/ppc-bars-width-size-fatten.svg +++ b/tests/testthat/_snaps/ppc-discrete/ppc-bars-width-size-fatten.svg @@ -30,16 +30,16 @@ - - - - - - - - - - + + + + + + + + + + @@ -67,8 +67,8 @@ 4 5 Count - - + + y r e diff --git a/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-alpha-size.svg b/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-alpha-size.svg index c6ea8a4b..dae85220 100644 --- a/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-alpha-size.svg +++ b/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-alpha-size.svg @@ -29,7 +29,7 @@ - + @@ -38,23 +38,23 @@ - - - - - + + + + + - + - - - + + + @@ -63,12 +63,12 @@ - + - + diff --git a/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-default.svg b/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-default.svg index 6061203a..656ba60c 100644 --- a/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-default.svg +++ b/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-default.svg @@ -29,7 +29,7 @@ - + @@ -38,23 +38,23 @@ - - - - - + + + + + - + - - - + + + @@ -63,12 +63,12 @@ - + - + diff --git a/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-no-notch.svg b/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-no-notch.svg index e444891f..bd9a4721 100644 --- a/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-no-notch.svg +++ b/tests/testthat/_snaps/ppc-distributions/ppc-boxplot-no-notch.svg @@ -29,7 +29,7 @@ - + @@ -38,23 +38,23 @@ - - - - - + + + + + - + - - - + + + @@ -63,12 +63,12 @@ - + - + diff --git a/tests/testthat/_snaps/ppc-distributions/ppc-freqpoly-default.svg b/tests/testthat/_snaps/ppc-distributions/ppc-freqpoly-default.svg index ac2b0f17..cdb7e4b3 100644 --- a/tests/testthat/_snaps/ppc-distributions/ppc-freqpoly-default.svg +++ b/tests/testthat/_snaps/ppc-distributions/ppc-freqpoly-default.svg @@ -26,7 +26,7 @@ - + @@ -39,7 +39,7 @@ - + @@ -52,7 +52,7 @@ - + @@ -65,7 +65,7 @@ - + @@ -78,7 +78,7 @@ - + @@ -91,7 +91,7 @@ - + @@ -104,7 +104,7 @@ - + @@ -117,7 +117,7 @@ - + @@ -130,7 +130,7 @@ - + @@ -241,9 +241,9 @@ - + - + y y r diff --git a/tests/testthat/_snaps/ppc-distributions/ppc-freqpoly-grouped-default.svg b/tests/testthat/_snaps/ppc-distributions/ppc-freqpoly-grouped-default.svg index 641bd06b..c54ba29d 100644 --- a/tests/testthat/_snaps/ppc-distributions/ppc-freqpoly-grouped-default.svg +++ b/tests/testthat/_snaps/ppc-distributions/ppc-freqpoly-grouped-default.svg @@ -20,286 +20,318 @@ - - + + - - - - - + + + + + + + - - + + - - - - - + + + + + + + - - + + - - - - - + + + + + + + - - + + - - - + + + - + + + - - + + - - - - - + + + + + + + - - + + - - - - - + + + + + + + - - + + - - - - - + + + + + + + - - + + - - - + + + + + - + - - + + - - - - - + + + + + + + - - + + - - - - - + + + + + + + - - + + - - - - - + + + + + + + - - + + - - - + + + - + + + - - + + - - - - - + + + + + + + - - + + - - - - - + + + + + + + - - + + - - - - - + + + + + + + - - + + - - - + + + + + - + - - + + - -A + +A - - + + - -B + +B - - + + - -C + +C - - + + - -D + +D - - + + - + - - + + - + - - + + - + - - + + - + @@ -354,19 +386,19 @@ 1 2 3 - - - - - - - - -y -y -r -e -p + + + + + + + + +y +y +r +e +p ppc_freqpoly_grouped (default) diff --git a/tests/testthat/_snaps/ppc-distributions/ppc-km-overlay-default.svg b/tests/testthat/_snaps/ppc-distributions/ppc-km-overlay-default.svg new file mode 100644 index 00000000..4e99f457 --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppc-km-overlay-default.svg @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.5 +1.0 + + + + + + + + + + +0 +1 +2 +3 +4 +5 + + +y +y +r +e +p +ppc_km_overlay (default) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppc-km-overlay-size-alpha.svg b/tests/testthat/_snaps/ppc-distributions/ppc-km-overlay-size-alpha.svg new file mode 100644 index 00000000..14ee1a2f --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppc-km-overlay-size-alpha.svg @@ -0,0 +1,73 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.5 +1.0 + + + + + + + + + + +0 +1 +2 +3 +4 +5 + + +y +y +r +e +p +ppc_km_overlay (size, alpha) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-boxplot-alpha-size.svg b/tests/testthat/_snaps/ppc-distributions/ppd-boxplot-alpha-size.svg new file mode 100644 index 00000000..a6c0fb86 --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-boxplot-alpha-size.svg @@ -0,0 +1,84 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +0 +2 + + + + +ppd_boxplot (alpha, size) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-boxplot-default.svg b/tests/testthat/_snaps/ppc-distributions/ppd-boxplot-default.svg new file mode 100644 index 00000000..94778a02 --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-boxplot-default.svg @@ -0,0 +1,84 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +0 +2 + + + + +ppd_boxplot (default) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-boxplot-no-notch.svg b/tests/testthat/_snaps/ppc-distributions/ppd-boxplot-no-notch.svg new file mode 100644 index 00000000..0180d328 --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-boxplot-no-notch.svg @@ -0,0 +1,84 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +0 +2 + + + + +ppd_boxplot (no notch) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-dens-default.svg b/tests/testthat/_snaps/ppc-distributions/ppd-dens-default.svg new file mode 100644 index 00000000..e4878158 --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-dens-default.svg @@ -0,0 +1,241 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +0 +2 + + + + +-2 +0 +2 + + + + +-2 +0 +2 + + + +ppd_dens (default) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-dens-overlay-alpha-size.svg b/tests/testthat/_snaps/ppc-distributions/ppd-dens-overlay-alpha-size.svg new file mode 100644 index 00000000..a4615afc --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-dens-overlay-alpha-size.svg @@ -0,0 +1,65 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +0 +2 +ppd_dens_overlay (alpha, size) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-dens-overlay-default.svg b/tests/testthat/_snaps/ppc-distributions/ppd-dens-overlay-default.svg new file mode 100644 index 00000000..8b3984c1 --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-dens-overlay-default.svg @@ -0,0 +1,65 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +0 +2 +ppd_dens_overlay (default) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-freqpoly-alpha-binwidth-size.svg b/tests/testthat/_snaps/ppc-distributions/ppd-freqpoly-alpha-binwidth-size.svg new file mode 100644 index 00000000..4d94e266 --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-freqpoly-alpha-binwidth-size.svg @@ -0,0 +1,253 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-5.0 +-2.5 +0.0 +2.5 +5.0 + + + + + + +-5.0 +-2.5 +0.0 +2.5 +5.0 + + + + + + +-5.0 +-2.5 +0.0 +2.5 +5.0 + + + +ppd_freqpoly (alpha, binwidth, size) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-freqpoly-default.svg b/tests/testthat/_snaps/ppc-distributions/ppd-freqpoly-default.svg new file mode 100644 index 00000000..79230124 --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-freqpoly-default.svg @@ -0,0 +1,241 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +0 +2 + + + + +-2 +0 +2 + + + + +-2 +0 +2 + + + +ppd_freqpoly (default) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-freqpoly-grouped-default.svg b/tests/testthat/_snaps/ppc-distributions/ppd-freqpoly-grouped-default.svg new file mode 100644 index 00000000..6f4e439f --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-freqpoly-grouped-default.svg @@ -0,0 +1,323 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +A + + + + + + + + + +B + + + + + + + + + +C + + + + + + + + + +D + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 +3 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + + +-3 +-2 +-1 +0 +1 +2 +3 + + + +ppd_freqpoly_grouped (default) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-hist-binwidth.svg b/tests/testthat/_snaps/ppc-distributions/ppd-hist-binwidth.svg new file mode 100644 index 00000000..725f1237 --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-hist-binwidth.svg @@ -0,0 +1,249 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2.5 +0.0 +2.5 + + + + +-2.5 +0.0 +2.5 + + + + +-2.5 +0.0 +2.5 + + + +ppd_hist (binwidth) + + diff --git a/tests/testthat/_snaps/ppc-distributions/ppd-hist-default.svg b/tests/testthat/_snaps/ppc-distributions/ppd-hist-default.svg new file mode 100644 index 00000000..06480602 --- /dev/null +++ b/tests/testthat/_snaps/ppc-distributions/ppd-hist-default.svg @@ -0,0 +1,465 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +0 +2 + + + + +-2 +0 +2 + + + + +-2 +0 +2 + + + +ppd_hist (default) + + diff --git a/tests/testthat/_snaps/ppc-errors/ppc-error-hist-default.svg b/tests/testthat/_snaps/ppc-errors/ppc-error-hist-default.svg new file mode 100644 index 00000000..afb1fdc4 --- /dev/null +++ b/tests/testthat/_snaps/ppc-errors/ppc-error-hist-default.svg @@ -0,0 +1,201 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2.5 +0.0 +2.5 + + + + +-2.5 +0.0 +2.5 + + + + +-2.5 +0.0 +2.5 + +y +− +y +r +e +p +ppc_error_hist (default) + + diff --git a/tests/testthat/_snaps/ppc-errors/ppc-error-hist-grouped-default.svg b/tests/testthat/_snaps/ppc-errors/ppc-error-hist-grouped-default.svg new file mode 100644 index 00000000..d6adb85d --- /dev/null +++ b/tests/testthat/_snaps/ppc-errors/ppc-error-hist-grouped-default.svg @@ -0,0 +1,619 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +A + + + + + + + + + +B + + + + + + + + + +C + + + + + + + + + +D + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2.5 +0.0 +2.5 + + + + +-2.5 +0.0 +2.5 + + + + +-2.5 +0.0 +2.5 + + + + +-2.5 +0.0 +2.5 + + + +y +− +y +r +e +p +ppc_error_hist_grouped (default) + + 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 new file mode 100644 index 00000000..445e86d6 --- /dev/null +++ b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-default.svg @@ -0,0 +1,166 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 +3 +Average +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 new file mode 100644 index 00000000..6eb818c0 --- /dev/null +++ b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-grouped-default.svg @@ -0,0 +1,303 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +C + + + + + + + + + +D + + + + + + + + + +A + + + + + + + + + +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 +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 new file mode 100644 index 00000000..8adb4a27 --- /dev/null +++ b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-avg-vs-x-default.svg @@ -0,0 +1,164 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-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) + + diff --git a/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-default.svg b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-default.svg new file mode 100644 index 00000000..46303bb9 --- /dev/null +++ b/tests/testthat/_snaps/ppc-errors/ppc-error-scatter-default.svg @@ -0,0 +1,430 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +0 +2 +4 + + + + + +-2 +0 +2 +4 + + + + + +-2 +0 +2 +4 + +-2 +-1 +0 +1 +2 +3 + + + + + + +y +− +y +r +e +p +y +ppc_error_scatter (default) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-default.svg b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-default.svg index bdcf22ae..b8497936 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-default.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-default.svg @@ -20,553 +20,451 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - --2 --1 -0 -1 -2 -3 - - - - - - - - - - - - -0 -25 -50 -75 -100 -x - - - - - - - - - - -y -r -e -p -y + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) + + + + + + + + +y +y +r +e +p ppc_intervals (default) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-grouped-default.svg b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-grouped-default.svg index 99ccee7d..0f4823a7 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-grouped-default.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-grouped-default.svg @@ -20,558 +20,466 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - -C + +C - - + + - -D + +D @@ -594,120 +502,118 @@ B - - - - - - - -50 -55 -60 -65 -70 -75 - - - - - - - -75 -80 -85 -90 -95 -100 - - - - - - - -0 -5 -10 -15 -20 -25 - - - - - - - -25 -30 -35 -40 -45 -50 - --2 --1 -0 -1 -2 -3 - - - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - -x - - - - - - - - - - -y -r -e -p -y + + + + + + + +50 +55 +60 +65 +70 +75 + + + + + + + +75 +80 +85 +90 +95 +100 + + + + + + + +0 +5 +10 +15 +20 +25 + + + + + + + +25 +30 +35 +40 +45 +50 + +-2 +-1 +0 +1 +2 +3 + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +Data point (index) + + + + + + + + +y +y +r +e +p ppc_intervals_grouped (default) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-grouped-x-values.svg b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-grouped-x-values.svg index be9f36ff..6264f6c6 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-grouped-x-values.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-grouped-x-values.svg @@ -50,31 +50,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - @@ -100,56 +75,58 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -184,31 +161,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - @@ -234,56 +186,58 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -318,31 +272,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - @@ -368,56 +297,58 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -452,31 +383,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - @@ -502,56 +408,58 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -685,21 +593,19 @@ x - - - - - - - - - - -y -r -e -p -y + + + + + + + + +y +y +r +e +p ppc_intervals_grouped (x values) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-interval-width.svg b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-interval-width.svg index 17612779..e74e8867 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-interval-width.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-interval-width.svg @@ -20,553 +20,451 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - --2 --1 -0 -1 -2 -3 - - - - - - - - - - - - -0 -25 -50 -75 -100 -x - - - - - - - - - - -y -r -e -p -y + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) + + + + + + + + +y +y +r +e +p ppc_intervals (interval width) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-x-values.svg b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-x-values.svg index aa2a6a37..36696ce1 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-x-values.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-x-values.svg @@ -125,106 +125,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -325,206 +225,206 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -554,21 +454,19 @@ 2 3 x - - - - - - - - - - -y -r -e -p -y + + + + + + + + +y +y +r +e +p ppc_intervals (x values) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-y-draw-both.svg b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-y-draw-both.svg deleted file mode 100644 index 32aa5cb7..00000000 --- a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-y-draw-both.svg +++ /dev/null @@ -1,180 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --2 --1 -0 -1 -2 -3 - - - - - - - - - - - - -0 -25 -50 -75 -100 -x - - - - - - - - - - -y -r -e -p -y -ppc_intervals (y_draw = both) - - diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-y-draw-line.svg b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-y-draw-line.svg deleted file mode 100644 index c809491c..00000000 --- a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-y-draw-line.svg +++ /dev/null @@ -1,78 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --2 --1 -0 -1 -2 -3 - - - - - - - - - - - - -0 -25 -50 -75 -100 -x - - - - - - - - -y -r -e -p -y -ppc_intervals (y_draw = line) - - diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-y-draw-point.svg b/tests/testthat/_snaps/ppc-intervals/ppc-intervals-y-draw-point.svg deleted file mode 100644 index 3717e7af..00000000 --- a/tests/testthat/_snaps/ppc-intervals/ppc-intervals-y-draw-point.svg +++ /dev/null @@ -1,177 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --2 --1 -0 -1 -2 -3 - - - - - - - - - - - - -0 -25 -50 -75 -100 -x - - - - - - - - -y -r -e -p -y -ppc_intervals (y_draw = point) - - diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-default.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-default.svg index 4702b205..895015c5 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-default.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-default.svg @@ -20,59 +20,60 @@ - - + + - - - - - - - - - + + + + + + + + + + + + - --2 --1 -0 -1 -2 -3 - - - - - - - - - - - - -0 -25 -50 -75 -100 -x - - - - - - - - -y -r -e -p -y + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) + + + + + + +y +y +r +e +p ppc_ribbon (default) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-default.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-default.svg index 8d5f34b0..36cfdf36 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-default.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-default.svg @@ -20,90 +20,110 @@ - - + + - - - - - - - - - + + + + + + + + + + + + + + - - + + - - - - - - - - - + + + + + + + + + + + + + + - - + + - - - - - - - - - + + + + + + + + + + + + + + - - + + - - - - - - - - - + + + + + + + + + + + + + + - - + + - -C + +C - - + + - -D + +D @@ -126,118 +146,116 @@ B - - - - - - - -50 -55 -60 -65 -70 -75 - - - - - - - -75 -80 -85 -90 -95 -100 - - - - - - - -0 -5 -10 -15 -20 -25 - - - - - - - -25 -30 -35 -40 -45 -50 - --2 --1 -0 -1 -2 -3 - - - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - -x - - - - - - - - -y -r -e -p -y + + + + + + + +50 +55 +60 +65 +70 +75 + + + + + + + +75 +80 +85 +90 +95 +100 + + + + + + + +0 +5 +10 +15 +20 +25 + + + + + + + +25 +30 +35 +40 +45 +50 + +-2 +-1 +0 +1 +2 +3 + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +Data point (index) + + + + + + +y +y +r +e +p ppc_ribbon_grouped (default) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-x-values.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-x-values.svg index ed79d06e..e7baa859 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-x-values.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-x-values.svg @@ -26,13 +26,18 @@ - - - - - - + + + + + + + + + + + @@ -43,13 +48,18 @@ - - - - - - + + + + + + + + + + + @@ -60,13 +70,18 @@ - - - - - - + + + + + + + + + + + @@ -77,13 +92,18 @@ - - - - - - + + + + + + + + + + + @@ -217,19 +237,17 @@ x - - - - - - - - -y -r -e -p -y + + + + + + +y +y +r +e +p ppc_ribbon_grouped (x values) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-both.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-both.svg index 760b6561..ffffb95c 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-both.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-both.svg @@ -20,190 +20,210 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - -C + +C - - + + - -D + +D @@ -226,120 +246,118 @@ B - - - - - - - -50 -55 -60 -65 -70 -75 - - - - - - - -75 -80 -85 -90 -95 -100 - - - - - - - -0 -5 -10 -15 -20 -25 - - - - - - - -25 -30 -35 -40 -45 -50 - --2 --1 -0 -1 -2 -3 - - - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - -x - - - - - - - - - - -y -r -e -p -y + + + + + + + +50 +55 +60 +65 +70 +75 + + + + + + + +75 +80 +85 +90 +95 +100 + + + + + + + +0 +5 +10 +15 +20 +25 + + + + + + + +25 +30 +35 +40 +45 +50 + +-2 +-1 +0 +1 +2 +3 + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +Data point (index) + + + + + + + + +y +y +r +e +p ppc_ribbon_grouped (y_draw = both) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-line.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-line.svg index 4167eed3..def1d312 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-line.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-line.svg @@ -20,90 +20,110 @@ - - + + - - - - - - - - - + + + + + + + + + + + + + + - - + + - - - - - - - - - + + + + + + + + + + + + + + - - + + - - - - - - - - - + + + + + + + + + + + + + + - - + + - - - - - - - - - + + + + + + + + + + + + + + - - + + - -C + +C - - + + - -D + +D @@ -126,118 +146,116 @@ B - - - - - - - -50 -55 -60 -65 -70 -75 - - - - - - - -75 -80 -85 -90 -95 -100 - - - - - - - -0 -5 -10 -15 -20 -25 - - - - - - - -25 -30 -35 -40 -45 -50 - --2 --1 -0 -1 -2 -3 - - - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - -x - - - - - - - - -y -r -e -p -y + + + + + + + +50 +55 +60 +65 +70 +75 + + + + + + + +75 +80 +85 +90 +95 +100 + + + + + + + +0 +5 +10 +15 +20 +25 + + + + + + + +25 +30 +35 +40 +45 +50 + +-2 +-1 +0 +1 +2 +3 + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +Data point (index) + + + + + + +y +y +r +e +p ppc_ribbon_grouped (y_draw = line) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-point.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-point.svg index 5ad1d41f..b9cd6190 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-point.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-grouped-y-draw-point.svg @@ -20,186 +20,206 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - -C + +C - - + + - -D + +D @@ -222,118 +242,116 @@ B - - - - - - - -50 -55 -60 -65 -70 -75 - - - - - - - -75 -80 -85 -90 -95 -100 - - - - - - - -0 -5 -10 -15 -20 -25 - - - - - - - -25 -30 -35 -40 -45 -50 - --2 --1 -0 -1 -2 -3 - - - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - - --2 --1 -0 -1 -2 - - - - - -x - - - - - - - - -y -r -e -p -y + + + + + + + +50 +55 +60 +65 +70 +75 + + + + + + + +75 +80 +85 +90 +95 +100 + + + + + + + +0 +5 +10 +15 +20 +25 + + + + + + + +25 +30 +35 +40 +45 +50 + +-2 +-1 +0 +1 +2 +3 + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +Data point (index) + + + + + + +y +y +r +e +p ppc_ribbon_grouped (y_draw = point) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-interval-width.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-interval-width.svg index d28c3448..4e173751 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-interval-width.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-interval-width.svg @@ -20,59 +20,60 @@ - - + + - - - - - - - - - + + + + + + + + + + + + - --2 --1 -0 -1 -2 -3 - - - - - - - - - - - - -0 -25 -50 -75 -100 -x - - - - - - - - -y -r -e -p -y + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) + + + + + + +y +y +r +e +p ppc_ribbon (interval width) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-x-values.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-x-values.svg index 01551864..36e7947b 100644 --- a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-x-values.svg +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-x-values.svg @@ -26,12 +26,15 @@ - - - - - - + + + + + + + + + @@ -62,19 +65,17 @@ 2 3 x - - - - - - - - -y -r -e -p -y + + + + + + +y +y +r +e +p ppc_ribbon (x values) diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-y-draw-both.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-y-draw-both.svg new file mode 100644 index 00000000..7df15b24 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-y-draw-both.svg @@ -0,0 +1,181 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) + + + + + + + + +y +y +r +e +p +ppc_ribbon (y_draw = both) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-y-draw-line.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-y-draw-line.svg new file mode 100644 index 00000000..b61945e4 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-y-draw-line.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) + + + + + + +y +y +r +e +p +ppc_ribbon (y_draw = line) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-y-draw-point.svg b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-y-draw-point.svg new file mode 100644 index 00000000..326c7d46 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppc-ribbon-y-draw-point.svg @@ -0,0 +1,178 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) + + + + + + +y +y +r +e +p +ppc_ribbon (y_draw = point) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppd-intervals-default.svg b/tests/testthat/_snaps/ppc-intervals/ppd-intervals-default.svg new file mode 100644 index 00000000..f401a74b --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppd-intervals-default.svg @@ -0,0 +1,355 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) +ppd_intervals (default) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppd-intervals-grouped-default.svg b/tests/testthat/_snaps/ppc-intervals/ppd-intervals-grouped-default.svg new file mode 100644 index 00000000..4a443550 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppd-intervals-grouped-default.svg @@ -0,0 +1,504 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +C + + + + + + + + + +D + + + + + + + + + +A + + + + + + + + + +B + + + + + + + + + +50 +55 +60 +65 +70 +75 + + + + + + + +75 +80 +85 +90 +95 +100 + + + + + + + +0 +5 +10 +15 +20 +25 + + + + + + + +25 +30 +35 +40 +45 +50 + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +Data point (index) +ppd_intervals_grouped (default) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppd-intervals-grouped-x-values.svg b/tests/testthat/_snaps/ppc-intervals/ppd-intervals-grouped-x-values.svg new file mode 100644 index 00000000..bcbbdfb8 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppd-intervals-grouped-x-values.svg @@ -0,0 +1,496 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +C + + + + + + + + + +D + + + + + + + + + +A + + + + + + + + + +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 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +x +ppd_intervals_grouped (x values) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppd-intervals-interval-width.svg b/tests/testthat/_snaps/ppc-intervals/ppd-intervals-interval-width.svg new file mode 100644 index 00000000..16b407d8 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppd-intervals-interval-width.svg @@ -0,0 +1,355 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) +ppd_intervals (interval width) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppd-intervals-x-values.svg b/tests/testthat/_snaps/ppc-intervals/ppd-intervals-x-values.svg new file mode 100644 index 00000000..6b97f063 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppd-intervals-x-values.svg @@ -0,0 +1,357 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + + + + + + +-2 +-1 +0 +1 +2 +3 +x +ppd_intervals (x values) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-default.svg b/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-default.svg new file mode 100644 index 00000000..efb98a28 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-default.svg @@ -0,0 +1,65 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) +ppd_ribbon (default) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-grouped-default.svg b/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-grouped-default.svg new file mode 100644 index 00000000..85e5eac2 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-grouped-default.svg @@ -0,0 +1,244 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +C + + + + + + + + + +D + + + + + + + + + +A + + + + + + + + + +B + + + + + + + + + +50 +55 +60 +65 +70 +75 + + + + + + + +75 +80 +85 +90 +95 +100 + + + + + + + +0 +5 +10 +15 +20 +25 + + + + + + + +25 +30 +35 +40 +45 +50 + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +Data point (index) +ppd_ribbon_grouped (default) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-grouped-x-values.svg b/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-grouped-x-values.svg new file mode 100644 index 00000000..dca57386 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-grouped-x-values.svg @@ -0,0 +1,236 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +C + + + + + + + + + +D + + + + + + + + + +A + + + + + + + + + +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 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + + +-2 +-1 +0 +1 +2 + + + + + +x +ppd_ribbon_grouped (x values) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-interval-width.svg b/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-interval-width.svg new file mode 100644 index 00000000..be45cf7d --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-interval-width.svg @@ -0,0 +1,65 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + + + + + +0 +25 +50 +75 +100 +Data point (index) +ppd_ribbon (interval width) + + diff --git a/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-x-values.svg b/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-x-values.svg new file mode 100644 index 00000000..4a6c4d71 --- /dev/null +++ b/tests/testthat/_snaps/ppc-intervals/ppd-ribbon-x-values.svg @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-2 +-1 +0 +1 +2 + + + + + + + + + + + + +-2 +-1 +0 +1 +2 +3 +x +ppd_ribbon (x values) + + 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 75c0b7d9..ef927ddb 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 @@ -25,6 +25,7 @@ + @@ -50,6 +51,8 @@ + + @@ -59,6 +62,7 @@ + @@ -84,6 +88,8 @@ + + @@ -93,6 +99,7 @@ + @@ -118,6 +125,8 @@ + + @@ -127,6 +136,7 @@ + @@ -152,6 +162,8 @@ + + diff --git a/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-size-alpha.svg b/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-size-alpha-ref-line.svg similarity index 96% rename from tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-size-alpha.svg rename to tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-size-alpha-ref-line.svg index 2305294f..9e142966 100644 --- a/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-size-alpha.svg +++ b/tests/testthat/_snaps/ppc-scatterplots/ppc-scatter-avg-grouped-size-alpha-ref-line.svg @@ -50,6 +50,8 @@ + + @@ -84,6 +86,8 @@ + + @@ -118,6 +122,8 @@ + + @@ -152,6 +158,8 @@ + + @@ -280,6 +288,6 @@ e p y -ppc_scatter_avg_grouped (size, alpha) +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 b2170e0d..3bc59a66 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 @@ -26,106 +26,106 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-2d-default.svg b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-2d-default.svg index 8265fd87..79af0d4a 100644 --- a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-2d-default.svg +++ b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-2d-default.svg @@ -25,6 +25,7 @@ + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-2d-stat-size-alpha.svg b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-2d-stat-size-alpha.svg index 643a47cd..21360f41 100644 --- a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-2d-stat-size-alpha.svg +++ b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-2d-stat-size-alpha.svg @@ -25,6 +25,7 @@ + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-freqpoly-grouped-default.svg b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-freqpoly-grouped-default.svg index c95e5526..626821fd 100644 --- a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-freqpoly-grouped-default.svg +++ b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-freqpoly-grouped-default.svg @@ -20,158 +20,132 @@ - - + + - - - + + + + + - - + + - - - + + + + + - - + + - - - + + + + + - - + + - - - + + + + + - - + + - -C + +C - - + + - -D + +D - - + + - -A + +A - - + + - -B + +B - - - - - --0.6 --0.3 -0.0 -0.3 - - - - --0.25 -0.00 -0.25 - - - - - --0.2 -0.0 -0.2 -0.4 - - - - --0.2 -0.0 -0.2 - -0 -1 -2 -3 - - - - - -0 -1 -2 -3 - - - - - -0 -1 -2 -3 - - - - - -0 -1 -2 -3 -4 - - - - - + + + + + +-0.6 +-0.3 +0.0 +0.3 + + + + +-0.25 +0.00 +0.25 + + + + + +-0.2 +0.0 +0.2 +0.4 + + + + +-0.2 +0.0 +0.2 + + + + T = mean @@ -188,6 +162,6 @@ ( y ) -ppc_stat_freqpoly_grouped (default) +ppc_stat_freqpoly_grouped (default) diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-freqpoly-grouped-stat-facet-args-binwidth.svg b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-freqpoly-grouped-stat-facet-args-binwidth.svg index 8dbd880c..91c5b388 100644 --- a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-freqpoly-grouped-stat-facet-args-binwidth.svg +++ b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-freqpoly-grouped-stat-facet-args-binwidth.svg @@ -20,137 +20,113 @@ - - + + - - - + + + + + - - + + - - - + + + + + - - + + - - - + + + + + - - + + - - - + + + + + - - + + - -D + +D - - + + - -C + +C - - + + - -B + +B - - + + - -A + +A - - - - - - - --15 --10 --5 -0 -5 -10 - -0 -1 -2 -3 - - - - - -0 -1 -2 -3 - - - - - -0 -1 -2 -3 - - - - - -0 -1 -2 -3 - - - - + + + + + + + +-15 +-10 +-5 +0 +5 +10 + + + + T = sum @@ -167,6 +143,6 @@ ( y ) -ppc_stat_freqpoly_grouped (stat, facet_args, binwidth) +ppc_stat_freqpoly_grouped (stat, facet_args, binwidth) diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-grouped-default.svg b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-grouped-default.svg index 529cc44c..ddc6ce84 100644 --- a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-grouped-default.svg +++ b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-grouped-default.svg @@ -56,6 +56,8 @@ + + @@ -96,6 +98,8 @@ + + @@ -136,6 +140,8 @@ + + @@ -176,6 +182,8 @@ + + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-grouped-stat-facet-args-binwidth.svg b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-grouped-stat-facet-args-binwidth.svg index edb1b7b4..60119353 100644 --- a/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-grouped-stat-facet-args-binwidth.svg +++ b/tests/testthat/_snaps/ppc-test-statistics/ppc-stat-grouped-stat-facet-args-binwidth.svg @@ -32,6 +32,8 @@ + + @@ -48,6 +50,8 @@ + + @@ -64,6 +68,8 @@ + + @@ -80,6 +86,8 @@ + + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-2d-default.svg b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-2d-default.svg new file mode 100644 index 00000000..3c8737bb --- /dev/null +++ b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-2d-default.svg @@ -0,0 +1,94 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.90 +0.95 +1.00 +1.05 + + + + + + + + + +-0.1 +0.0 +0.1 +0.2 +mean +sd +T += +( +mean +, + +sd +) + +T +( +y +p +r +e +d +) +ppd_stat_2d (default) + + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-2d-stat-size-alpha.svg b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-2d-stat-size-alpha.svg new file mode 100644 index 00000000..01e48ce9 --- /dev/null +++ b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-2d-stat-size-alpha.svg @@ -0,0 +1,98 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.8 +0.9 +1.0 +1.1 +1.2 + + + + + + + + + + + +-0.2 +-0.1 +0.0 +0.1 +0.2 +median +mad +T += +( +median +, + +mad +) + +T +( +y +p +r +e +d +) +ppd_stat_2d (stat, size, alpha) + + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-default.svg b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-default.svg new file mode 100644 index 00000000..18cea240 --- /dev/null +++ b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-default.svg @@ -0,0 +1,90 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 + + + + + + +-0.1 +0.0 +0.1 +0.2 +0.3 +T += +mean + +T +( +y +p +r +e +d +) +ppd_stat (default) + + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-freqpoly-grouped-default.svg b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-freqpoly-grouped-default.svg new file mode 100644 index 00000000..753c74eb --- /dev/null +++ b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-freqpoly-grouped-default.svg @@ -0,0 +1,159 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +C + + + + + + + + + +D + + + + + + + + + +A + + + + + + + + + +B + + + + + + + +-0.6 +-0.3 +0.0 +0.3 + + + + +-0.25 +0.00 +0.25 + + + + + +-0.2 +0.0 +0.2 +0.4 + + + + +-0.2 +0.0 +0.2 + + + + +T += +mean + +T +( +y +p +r +e +d +) +ppd_stat_freqpoly_grouped (default) + + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-freqpoly-grouped-stat-facet-args-binwidth.svg b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-freqpoly-grouped-stat-facet-args-binwidth.svg new file mode 100644 index 00000000..2fc14dfe --- /dev/null +++ b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-freqpoly-grouped-stat-facet-args-binwidth.svg @@ -0,0 +1,140 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +D + + + + + + + + + +C + + + + + + + + + +B + + + + + + + + + +A + + + + + + + + + +-15 +-10 +-5 +0 +5 +10 + + + + +T += +sum + +T +( +y +p +r +e +d +) +ppd_stat_freqpoly_grouped (stat, facet_args, binwidth) + + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-grouped-default.svg b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-grouped-default.svg new file mode 100644 index 00000000..6b4d3d18 --- /dev/null +++ b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-grouped-default.svg @@ -0,0 +1,279 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +C + + + + + + + + + +D + + + + + + + + + +A + + + + + + + + + +B + + + + + + + +-0.6 +-0.3 +0.0 +0.3 + + + + + + +-0.4 +-0.2 +0.0 +0.2 +0.4 + + + + + +-0.2 +0.0 +0.2 +0.4 + + + + +-0.2 +0.0 +0.2 + + + + +T += +mean + +T +( +y +p +r +e +d +) +ppd_stat_grouped (default) + + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-grouped-stat-facet-args-binwidth.svg b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-grouped-stat-facet-args-binwidth.svg new file mode 100644 index 00000000..c294aeda --- /dev/null +++ b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-grouped-stat-facet-args-binwidth.svg @@ -0,0 +1,154 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +D + + + + + + + + + +C + + + + + + + + + +B + + + + + + + + + +A + + + + + + +0.5 +1.0 +1.5 + + + + +T += +stats::var + +T +( +y +p +r +e +d +) +ppd_stat_grouped (stat, facet_args, binwidth) + + diff --git a/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-stat-binwidth-freq.svg b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-stat-binwidth-freq.svg new file mode 100644 index 00000000..9e41bbc2 --- /dev/null +++ b/tests/testthat/_snaps/ppc-test-statistics/ppd-stat-stat-binwidth-freq.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1 +2 +3 + + + + + + + + +0.7 +0.8 +0.9 +1.0 +1.1 +1.2 +1.3 +T += +mad + +T +( +y +p +r +e +d +) +ppd_stat (stat, binwidth, freq) + + diff --git a/tests/testthat/data-for-ordinal.rda b/tests/testthat/data-for-ordinal.rda new file mode 100644 index 00000000..1966c4bd Binary files /dev/null and b/tests/testthat/data-for-ordinal.rda differ diff --git a/tests/testthat/test-aesthetics.R b/tests/testthat/test-aesthetics.R index 5b69b7ff..fec2c8e9 100644 --- a/tests/testthat/test-aesthetics.R +++ b/tests/testthat/test-aesthetics.R @@ -225,3 +225,6 @@ test_that("color_scheme_view renders correctly", { color_scheme_set() }) + +bayesplot_theme_set(bayesplot::theme_default()) +color_scheme_set() diff --git a/tests/testthat/test-available_ppc.R b/tests/testthat/test-available_ppc.R index 7ba822d3..f953b3b4 100644 --- a/tests/testthat/test-available_ppc.R +++ b/tests/testthat/test-available_ppc.R @@ -6,12 +6,12 @@ test_that("available_mcmc works", { a <- available_mcmc() expect_s3_class(a, "bayesplot_function_list") expect_s3_class(a, "character") - expect_identical( - as.character(a), - sort(grep("^mcmc_", getNamespaceExports("bayesplot"), value = TRUE)) - ) - b <- available_mcmc("trace|dens") + all_mcmc_plots <- sort(grep("^mcmc_", getNamespaceExports("bayesplot"), value = TRUE)) + all_mcmc_plots <- grep("_data", all_mcmc_plots, invert = TRUE, value = TRUE) + expect_identical(as.character(a), all_mcmc_plots) + + b <- available_mcmc("trace|dens", plots = FALSE) expect_s3_class(b, "bayesplot_function_list") expect_identical( as.character(b), @@ -25,16 +25,16 @@ test_that("available_ppc works", { a <- available_ppc() expect_s3_class(a, "bayesplot_function_list") expect_s3_class(a, "character") - expect_identical( - as.character(a), - sort(grep("^ppc_", getNamespaceExports("bayesplot"), value = TRUE)) - ) + + all_ppc_plots <- sort(grep("^ppc_", getNamespaceExports("bayesplot"), value = TRUE)) + all_ppc_plots <- grep("_data", all_ppc_plots, invert = TRUE, value = TRUE) + expect_identical(as.character(a), all_ppc_plots) b <- available_ppc("grouped") expect_s3_class(b, "bayesplot_function_list") expect_identical( as.character(b), - sort(grep("_grouped$", getNamespaceExports("bayesplot"), value = TRUE)) + sort(grep("^ppc_.*_grouped$", getNamespaceExports("bayesplot"), value = TRUE)) ) c <- available_ppc("grouped", invert = TRUE) @@ -43,7 +43,21 @@ test_that("available_ppc works", { expect_length(available_ppc(pattern = "99999"), 0) }) +test_that("available_ppd works", { + a <- available_ppd() + expect_s3_class(a, "bayesplot_function_list") + expect_s3_class(a, "character") + + all_ppd_plots <- sort(grep("^ppd_", getNamespaceExports("bayesplot"), value = TRUE)) + all_ppd_plots <- grep("_data", all_ppd_plots, invert = TRUE, value = TRUE) + expect_identical(as.character(a), all_ppd_plots) + + a <- available_ppd(plots_only = FALSE) + expect_identical(as.character(a), sort(grep("^ppd_", getNamespaceExports("bayesplot"), value = TRUE))) +}) + test_that("print.bayesplot_function_list works", { + expect_output(print(available_ppd()), "bayesplot PPD module:") expect_output(print(available_ppc()), "bayesplot PPC module:") expect_output(print(available_mcmc()), "bayesplot MCMC module:") diff --git a/tests/testthat/test-helpers-ppc.R b/tests/testthat/test-helpers-ppc.R index 0af6e683..032b65c2 100644 --- a/tests/testthat/test-helpers-ppc.R +++ b/tests/testthat/test-helpers-ppc.R @@ -3,19 +3,19 @@ context("PPC: misc. functions") source(test_path("data-for-ppc-tests.R")) -# melt_yrep --------------------------------------------------------------- +# melt_predictions --------------------------------------------------------------- expect_molten_yrep <- function(yrep) { y <- rnorm(ncol(yrep)) - yrep <- validate_yrep(yrep, y) + yrep <- validate_predictions(yrep, length(y)) - x <- melt_yrep(yrep) - expect_equal(ncol(x), 4) + x <- melt_predictions(yrep) + expect_equal(ncol(x), 5) expect_equal(nrow(x), prod(dim(yrep))) rep_nums <- rep(seq_len(nrow(yrep)), length(y)) obs_nums <- sort(rep(seq_len(length(y)), nrow(yrep))) - expect_identical(colnames(x), c("y_id", "rep_id", "rep_label", "value")) + expect_identical(colnames(x), c("y_id", "y_name", "rep_id", "rep_label", "value")) expect_equal(x$y_id, obs_nums) expect_equal(x$rep_id, rep_nums) @@ -26,19 +26,19 @@ expect_molten_yrep <- function(yrep) { expect_type(x$value, "double") } -test_that("melt_yrep returns correct structure", { +test_that("melt_predictions returns correct structure", { expect_molten_yrep(yrep) expect_molten_yrep(yrep2) load(test_path("data-for-binomial.rda")) expect_molten_yrep(Ey) - expect_molten_yrep(validate_yrep(yrep, y)) + expect_molten_yrep(validate_predictions(yrep, length(y))) }) # melt_and_stack ---------------------------------------------------------- test_that("melt_and_stack returns correct structure", { - molten_yrep <- melt_yrep(yrep) + molten_yrep <- melt_predictions(yrep) d <- melt_and_stack(y, yrep) expect_s3_class(d, "data.frame") expect_equal(nrow(d), nrow(molten_yrep) + length(y)) @@ -48,42 +48,6 @@ test_that("melt_and_stack returns correct structure", { }) -# ppc_group_data ---------------------------------------------------------- - -d <- ppc_group_data(y, yrep, group) -d_stat <- ppc_group_data(y, yrep, group, stat = "mean") - -test_that("ppc_group_data returns correct structure", { - expect_identical(colnames(d), c("group", "variable", "value")) - expect_s3_class(d, c("grouped_df", "tbl_df", "tbl", "data.frame")) - - expect_identical(colnames(d_stat), colnames(d)) - expect_s3_class(d, c("grouped_df", "tbl_df", "tbl", "data.frame")) - - nr <- length(unique(d$variable)) * length(unique(group)) - expect_equal(nrow(d_stat), nr) -}) - -test_that("ppc_group_data with stat returns correct values for y", { - for (lev in levels(group)) { - mean_y_group <- with(d_stat, value[group == lev & variable == "y"]) - expect_equal(mean_y_group, mean(y[group == lev]), - info = paste("group =", lev)) - } -}) - -test_that("ppc_group_data with stat returns correct values for yrep", { - for (lev in levels(group)) { - for (j in 1:nrow(yrep)) { - var <- paste0("yrep_", j) - mean_yrep_group <- with(d_stat, value[group == lev & variable == var]) - expect_equal(mean_yrep_group, mean(yrep[j, group == lev]), - info = paste("group =", lev, "|", "rep =", j)) - } - } -}) - - # is_whole_number, all_counts -------------------------------------------- test_that("is_whole_number works correctly", { expect_equal(is_whole_number(c(1L, 2, 3/3, 4/5)), diff --git a/tests/testthat/test-mcmc-scatter-and-parcoord.R b/tests/testthat/test-mcmc-scatter-and-parcoord.R index cb41874c..2ae02d71 100644 --- a/tests/testthat/test-mcmc-scatter-and-parcoord.R +++ b/tests/testthat/test-mcmc-scatter-and-parcoord.R @@ -69,11 +69,6 @@ test_that("mcmc_pairs returns a bayesplot_grid object", { expect_bayesplot_grid(g) expect_equal(print(g), plot(g)) expect_bayesplot_grid(mcmc_pairs(arr, pars = "sigma", regex_pars = "beta")) - expect_bayesplot_grid(mcmc_pairs(arr, regex_pars = "x:[1-3]", - transformations = "exp", - diag_fun = "dens", off_diag_fun = "hex", - diag_args = list(trim = FALSE), - off_diag_args = list(binwidth = c(0.5, 0.5)))) expect_bayesplot_grid(mcmc_pairs(drawsarr, pars = "mu", regex_pars = "theta")) expect_bayesplot_grid(suppressWarnings(mcmc_pairs(arr1chain, regex_pars = "beta"))) @@ -83,6 +78,15 @@ test_that("mcmc_pairs returns a bayesplot_grid object", { expect_bayesplot_grid(mcmc_pairs(dframe_multiple_chains, regex_pars = "beta")) }) +test_that("mcmc_pairs using hexbin works", { + skip_if_not_installed("hexbin") + expect_bayesplot_grid(mcmc_pairs(arr, regex_pars = "x:[1-3]", + transformations = "exp", + diag_fun = "dens", off_diag_fun = "hex", + diag_args = list(trim = FALSE), + off_diag_args = list(binwidth = c(0.5, 0.5)))) +}) + test_that("no mcmc_pairs non-NUTS 'condition's fail", { expect_bayesplot_grid( mcmc_pairs(arr, pars = "sigma", regex_pars = "beta", @@ -116,7 +120,7 @@ test_that("mcmc_pairs works with NUTS info", { p <- mcmc_pairs( post, pars = c("wt", "am"), - off_diag_fun = "hex", + off_diag_fun = "scatter", condition = pairs_condition(nuts = "lp__"), lp = lp, np = np, diff --git a/tests/testthat/test-ppc-censoring.R b/tests/testthat/test-ppc-censoring.R index e36ee484..30b7f0c9 100644 --- a/tests/testthat/test-ppc-censoring.R +++ b/tests/testthat/test-ppc-censoring.R @@ -4,11 +4,13 @@ context("PPC: censoring") source(test_path("data-for-ppc-tests.R")) test_that("ppc_km_overlay returns a ggplot object", { + skip_if_not_installed("ggfortify") expect_gg(ppc_km_overlay(y, yrep, status_y = status_y, size = 0.5, alpha = 0.2)) expect_gg(ppc_km_overlay(y2, yrep2, status_y = status_y2)) }) test_that("ppc_km_overlay_grouped returns a ggplot object", { + skip_if_not_installed("ggfortify") expect_gg(ppc_km_overlay_grouped(y, yrep, group, status_y = status_y)) expect_gg(ppc_km_overlay_grouped(y, yrep, as.numeric(group), @@ -29,6 +31,7 @@ test_that("ppc_km_overlay_grouped returns a ggplot object", { test_that("ppc_km_overlay renders correctly", { testthat::skip_on_cran() testthat::skip_if_not_installed("vdiffr") + skip_if_not_installed("ggfortify") p_base <- ppc_km_overlay(vdiff_y2, vdiff_yrep2, status_y = vdiff_status_y2) vdiffr::expect_doppelganger("ppc_km_overlay (default)", p_base) @@ -44,6 +47,8 @@ test_that("ppc_km_overlay renders correctly", { test_that("ppc_km_overlay_grouped renders correctly", { testthat::skip_on_cran() + testthat::skip_if_not_installed("vdiffr") + skip_if_not_installed("ggfortify") p_base <- ppc_km_overlay_grouped(vdiff_y2, vdiff_yrep2, vdiff_group2, status_y = vdiff_status_y2) diff --git a/tests/testthat/test-ppc-discrete.R b/tests/testthat/test-ppc-discrete.R index 63ee9402..de539099 100644 --- a/tests/testthat/test-ppc-discrete.R +++ b/tests/testthat/test-ppc-discrete.R @@ -1,30 +1,29 @@ library(bayesplot) +# suppressPackageStartupMessages(library(rstanarm)) context("PPC: discrete") +source(test_path("data-for-ppc-tests.R")) +load(test_path("data-for-ordinal.rda")) +# data("esoph", package = "datasets") +# fit <- stan_polr(tobgp ~ agegp, data = esoph, method = "probit", prior = R2(0.2, "mean"), +# init_r = 0.1, seed = 12345, chains = 1, iter = 500, refresh = 0) +# y_ord <- as.integer(fit$y) +# yrep_char <- posterior_predict(fit, draws = 50) +# yrep_ord <- sapply(data.frame(yrep_char, stringsAsFactors = TRUE), as.integer) +# group_ord <- datasets::esoph$agegp +# save(y_ord, yrep_ord, group_ord, file = testthat::test_path("data-for-ordinal.rda")) -# bar plots --------------------------------------------------------------- - -if (requireNamespace("rstanarm", quietly = TRUE)) { - suppressPackageStartupMessages(library(rstanarm)) - data("esoph", package = "datasets") - fit <- stan_polr(tobgp ~ agegp, data = esoph, method = "probit", prior = R2(0.2, "mean"), - init_r = 0.1, seed = 12345, chains = 1, iter = 500, refresh = 0) - y <- as.integer(fit$y) - yrep_char <- posterior_predict(fit, draws = 10) - yrep <- sapply(data.frame(yrep_char, stringsAsFactors = TRUE), as.integer) -} +# bar plots --------------------------------------------------------------- test_that("ppc_bars & ppc_bars_grouped return a ggplot object", { - skip_if_not_installed("rstanarm") - expect_gg(ppc_bars(y, yrep)) - expect_gg(ppc_bars(y, yrep, prob = 0)) - expect_gg(ppc_bars_grouped(y, yrep, group = esoph$agegp)) + expect_gg(ppc_bars(y_ord, yrep_ord)) + expect_gg(ppc_bars(y_ord, yrep_ord, prob = 0)) + expect_gg(ppc_bars_grouped(y_ord, yrep_ord, group = group_ord)) }) test_that("freq argument to ppc_bars works", { - skip_if_not_installed("rstanarm") - p_freq <- ggplot2::ggplot_build(ppc_bars(y, yrep, freq = TRUE)) - p_prop <- ggplot2::ggplot_build(ppc_bars(y, yrep, freq = FALSE)) + p_freq <- ggplot2::ggplot_build(ppc_bars(y_ord, yrep_ord, freq = TRUE)) + p_prop <- ggplot2::ggplot_build(ppc_bars(y_ord, yrep_ord, freq = FALSE)) y_freq <- p_freq$data[[1]]$y y_prop <- p_prop$data[[1]]$y @@ -39,22 +38,49 @@ test_that("ppc_bars works with negative integers", { }) test_that("ppc_bars(_grouped) errors if y/yrep not discrete", { - skip_if_not_installed("rstanarm") - expect_error(ppc_bars(y + 0.5, yrep), + # make continuous + y_cont <- y_ord + 0.33 + yrep_cont <- yrep_ord + 0.33 + + expect_error(ppc_bars(y_cont, yrep_ord), "ppc_bars expects 'y' to be discrete") - expect_error(ppc_bars(y, yrep + 0.5), + expect_error(ppc_bars(y_ord, yrep_cont), + "ppc_bars expects 'yrep' to be discrete") + expect_error(ppc_bars_grouped(y_cont, yrep_ord, group = group_ord), + "ppc_bars expects 'y' to be discrete") + expect_error(ppc_bars_grouped(y_ord, yrep_cont, group = group_ord), "ppc_bars expects 'yrep' to be discrete") - expect_error(ppc_bars_grouped(y + 0.5, yrep, group = esoph$agegp), - "ppc_bars_grouped expects 'y' to be discrete") - expect_error(ppc_bars_grouped(y, yrep + 0.5, group = esoph$agegp), - "ppc_bars_grouped expects 'yrep' to be discrete") }) +test_that("ppc_bars_data includes all levels", { + y_ord2 <- y_ord + y_ord2[y_ord2 == 1] <- 2 + yrep_ord2 <- yrep_ord + yrep_ord2[yrep_ord2 == 2] <- 1 + + tab <- as.integer(table(y_ord)) + + # y and yrep have save levels + d <- ppc_bars_data(y_ord, yrep_ord) + expect_equal(d$x, 1:4) + expect_equal(d$y_obs, tab) + + # yrep has more unique values than y + d2 <- ppc_bars_data(y_ord2, yrep_ord) + expect_equal(d2$x, 1:4) + expect_equal(d2$y_obs, c(NA, sum(tab[1:2]), tab[3:4])) + + # y has more unique values than yrep + d3 <- ppc_bars_data(y_ord, yrep_ord2) + expect_equal(d3$x, 1:4) + expect_equal(d3$y_obs, tab) + expect_equivalent(d3$l[2], NA_real_) + expect_equivalent(d3$m[2], NA_real_) + expect_equivalent(d3$h[2], NA_real_) +}) -# rootograms ----------------------------------------------------------- -rm(list = ls()) -source(test_path("data-for-ppc-tests.R")) +# rootograms ----------------------------------------------------------- yrep3 <- matrix(yrep2, nrow = 5, ncol = ncol(yrep2), byrow = TRUE) test_that("ppc_rootogram returns a ggplot object", { @@ -149,4 +175,3 @@ test_that("ppc_rootogram renders correctly", { fig = p_custom_hanging) }) - diff --git a/tests/testthat/test-ppc-distributions.R b/tests/testthat/test-ppc-distributions.R index 8d0accb6..047e59cf 100644 --- a/tests/testthat/test-ppc-distributions.R +++ b/tests/testthat/test-ppc-distributions.R @@ -6,11 +6,19 @@ source(test_path("data-for-ppc-tests.R")) test_that("ppc_dens_overlay returns a ggplot object", { expect_gg(ppc_dens_overlay(y, yrep)) expect_gg(ppc_dens_overlay(y2, yrep2, size = 0.5, alpha = 0.2)) + + # ppd versions + expect_gg(ppd_dens_overlay(yrep)) + expect_gg(ppd_dens_overlay(yrep2, size = 0.5, alpha = 0.2)) }) test_that("ppc_ecdf_overlay returns a ggplot object", { expect_gg(ppc_ecdf_overlay(y, yrep, size = 0.5, alpha = 0.2)) expect_gg(ppc_ecdf_overlay(y2, yrep2)) + + # ppd versions + expect_gg(ppd_ecdf_overlay(yrep, size = 0.5, alpha = 0.2)) + expect_gg(ppd_ecdf_overlay(yrep2)) }) test_that("ppc_dens,pp_hist,ppc_freqpoly,ppc_boxplot return ggplot objects", { @@ -18,27 +26,45 @@ test_that("ppc_dens,pp_hist,ppc_freqpoly,ppc_boxplot return ggplot objects", { expect_gg(ppc_hist(y, yrep[1:8, ])) expect_gg(ppc_hist(y2, yrep2)) - expect_gg(ppc_boxplot(y, yrep[1,, drop = FALSE])) - expect_gg(ppc_boxplot(y, yrep[1:8, ])) - expect_gg(ppc_boxplot(y2, yrep2, notch = FALSE)) - expect_gg(ppc_dens(y, yrep[1:8, ])) expect_gg(ppc_dens(y2, yrep2)) expect_gg(ppc_freqpoly(y, yrep[1:8, ], binwidth = 2, size = 2, alpha = 0.1)) expect_gg(ppc_freqpoly(y2, yrep2)) + expect_gg(ppc_boxplot(y, yrep[1,, drop = FALSE])) + expect_gg(ppc_boxplot(y, yrep[1:8, ])) + expect_gg(ppc_boxplot(y2, yrep2, notch = FALSE)) + expect_gg(p <- ppc_hist(y, yrep[1:8, ], binwidth = 3)) if (utils::packageVersion("ggplot2") >= "3.0.0") { facet_var <- "~rep_label" expect_equal(as.character(p$facet$params$facets[1]), facet_var) } + + # ppd versions + expect_gg(ppd_hist(yrep[1,, drop = FALSE])) + expect_gg(ppd_hist(yrep[1:8, ])) + expect_gg(ppd_hist(yrep2)) + + expect_gg(ppc_dens(y, yrep[1:8, ])) + expect_gg(ppc_dens(y2, yrep2)) + + expect_gg(ppd_freqpoly(yrep[1:8, ], binwidth = 2, size = 2, alpha = 0.1)) + expect_gg(ppd_freqpoly(yrep2)) + + expect_gg(ppd_boxplot(yrep[1,, drop = FALSE])) + expect_gg(ppd_boxplot(yrep[1:8, ])) + expect_gg(ppd_boxplot(yrep2, notch = FALSE)) }) test_that("ppc_freqpoly_grouped returns a ggplot object", { expect_gg(ppc_freqpoly_grouped(y, yrep[1:4, ], group)) expect_gg(ppc_freqpoly_grouped(y, yrep[1:4, ], group, freq = TRUE, alpha = 0.5)) + + # ppd versions + expect_gg(ppd_freqpoly_grouped(yrep[1:4, ], group)) }) test_that("ppc_violin_grouped returns a ggplot object", { @@ -50,7 +76,6 @@ test_that("ppc_violin_grouped returns a ggplot object", { - # Visual tests ----------------------------------------------------------------- test_that("ppc_hist renders correctly", { @@ -62,6 +87,13 @@ test_that("ppc_hist renders correctly", { p_binwidth <- ppc_hist(vdiff_y, vdiff_yrep[1:8, ], binwidth = 3) vdiffr::expect_doppelganger("ppc_hist (binwidth)", p_binwidth) + + # ppd versions + p_base <- ppd_hist(vdiff_yrep[1:8, ]) + vdiffr::expect_doppelganger("ppd_hist (default)", p_base) + + p_binwidth <- ppd_hist(vdiff_yrep[1:8, ], binwidth = 3) + vdiffr::expect_doppelganger("ppd_hist (binwidth)", p_binwidth) }) test_that("ppc_freqpoly renders correctly", { @@ -77,10 +109,22 @@ test_that("ppc_freqpoly renders correctly", { binwidth = 2, size = 2, alpha = 0.1) - vdiffr::expect_doppelganger( title = "ppc_freqpoly (alpha, binwidth, size)", fig = p_custom) + + # ppd versions + p_base <- ppd_freqpoly(vdiff_yrep[1:8, ]) + vdiffr::expect_doppelganger("ppd_freqpoly (default)", p_base) + + p_custom <- ppd_freqpoly( + ypred = vdiff_yrep[1:8, ], + binwidth = 2, + size = 2, + alpha = 0.1) + vdiffr::expect_doppelganger( + title = "ppd_freqpoly (alpha, binwidth, size)", + fig = p_custom) }) test_that("ppc_freqpoly_grouped renders correctly", { @@ -89,6 +133,10 @@ test_that("ppc_freqpoly_grouped renders correctly", { p_base <- ppc_freqpoly_grouped(vdiff_y, vdiff_yrep[1:3, ], vdiff_group) vdiffr::expect_doppelganger("ppc_freqpoly_grouped (default)", p_base) + + # ppd versions + p_base <- ppd_freqpoly_grouped(vdiff_yrep[1:3, ], vdiff_group) + vdiffr::expect_doppelganger("ppd_freqpoly_grouped (default)", p_base) }) test_that("ppc_boxplot renders correctly", { @@ -103,6 +151,16 @@ test_that("ppc_boxplot renders correctly", { p_custom <- ppc_boxplot(vdiff_y, vdiff_yrep[1:8, ], size = 1.5, alpha = .5) vdiffr::expect_doppelganger("ppc_boxplot (alpha, size)", p_custom) + + # ppd versions + p_base <- ppd_boxplot(vdiff_yrep[1:8, ]) + vdiffr::expect_doppelganger("ppd_boxplot (default)", p_base) + + p_no_notch <- ppd_boxplot(vdiff_yrep[1:8, ], notch = FALSE) + vdiffr::expect_doppelganger("ppd_boxplot (no notch)", p_no_notch) + + p_custom <- ppd_boxplot(vdiff_yrep[1:8, ], size = 1.5, alpha = .5) + vdiffr::expect_doppelganger("ppd_boxplot (alpha, size)", p_custom) }) test_that("ppc_ecdf_overlay renders correctly", { @@ -153,6 +211,10 @@ test_that("ppc_dens renders correctly", { p_base <- ppc_dens(vdiff_y, vdiff_yrep[1:8, ]) vdiffr::expect_doppelganger("ppc_dens (default)", p_base) + + # ppd versions + p_base <- ppd_dens(vdiff_yrep[1:8, ]) + vdiffr::expect_doppelganger("ppd_dens (default)", p_base) }) test_that("ppc_dens_overlay renders correctly", { @@ -164,6 +226,13 @@ test_that("ppc_dens_overlay renders correctly", { p_custom <- ppc_dens_overlay(vdiff_y, vdiff_yrep, size = 1, alpha = 0.2) vdiffr::expect_doppelganger("ppc_dens_overlay (alpha, size)", p_custom) + + # ppd versions + p_base <- ppd_dens_overlay(vdiff_yrep) + vdiffr::expect_doppelganger("ppd_dens_overlay (default)", p_base) + + p_custom <- ppd_dens_overlay(vdiff_yrep, size = 1, alpha = 0.2) + vdiffr::expect_doppelganger("ppd_dens_overlay (alpha, size)", p_custom) }) test_that("ppc_dens_overlay_grouped renders correctly", { diff --git a/tests/testthat/test-ppc-errors.R b/tests/testthat/test-ppc-errors.R index 5ae14e36..f4746639 100644 --- a/tests/testthat/test-ppc-errors.R +++ b/tests/testthat/test-ppc-errors.R @@ -26,16 +26,14 @@ test_that("ppc_error_scatter_avg returns ggplot2 object", { }) test_that("ppc_error_scatter_avg same as ppc_error_scatter if nrow(yrep) = 1", { - expect_equal( - ppc_error_scatter_avg(y2, yrep2), - ppc_error_scatter(y2, yrep2), - check.environment = FALSE - ) - expect_equal( - ppc_error_scatter_avg(y, yrep[1,, drop=FALSE]), - ppc_error_scatter(y, yrep[1,, drop = FALSE]), - check.environment = FALSE - ) + p1 <- ppc_error_scatter_avg(y2, yrep2) + p2 <- ppc_error_scatter(y2, yrep2) + d1 <- p1$data + d2 <- p2$data + + # really only a few columns are _exactly_ the same + cols <- c("y_id", "y_obs", "value") + expect_equal(d1[, cols], d2[, cols]) }) test_that("ppc_error_scatter_avg_vs_x returns ggplot2 object", { @@ -65,6 +63,48 @@ test_that("bin_errors works for edge cases", { # Visual tests ----------------------------------------------------------------- +test_that("ppc_error_hist renders correctly", { + testthat::skip_on_cran() + testthat::skip_if_not_installed("vdiffr") + p_base <- ppc_error_hist(vdiff_y, vdiff_yrep[1:3, ]) + vdiffr::expect_doppelganger("ppc_error_hist (default)", p_base) +}) + +test_that("ppc_error_hist_grouped renders correctly", { + testthat::skip_on_cran() + testthat::skip_if_not_installed("vdiffr") + p_base <- ppc_error_hist_grouped(vdiff_y, vdiff_yrep[1:3, ], vdiff_group) + vdiffr::expect_doppelganger("ppc_error_hist_grouped (default)", p_base) +}) + +test_that("ppc_error_scatter renders correctly", { + testthat::skip_on_cran() + testthat::skip_if_not_installed("vdiffr") + p_base <- ppc_error_scatter(vdiff_y, vdiff_yrep[1:3, ]) + vdiffr::expect_doppelganger("ppc_error_scatter (default)", p_base) +}) + +test_that("ppc_error_scatter_avg renders correctly", { + testthat::skip_on_cran() + testthat::skip_if_not_installed("vdiffr") + p_base <- ppc_error_scatter_avg(vdiff_y, vdiff_yrep) + vdiffr::expect_doppelganger("ppc_error_scatter_avg (default)", p_base) +}) + +test_that("ppc_error_scatter_avg_grouped renders correctly", { + testthat::skip_on_cran() + testthat::skip_if_not_installed("vdiffr") + p_base <- ppc_error_scatter_avg_grouped(vdiff_y, vdiff_yrep, vdiff_group) + vdiffr::expect_doppelganger("ppc_error_scatter_avg_grouped (default)", p_base) +}) + +test_that("ppc_error_scatter_avg_vs_x renders correctly", { + testthat::skip_on_cran() + testthat::skip_if_not_installed("vdiffr") + p_base <- ppc_error_scatter_avg_vs_x(vdiff_y, vdiff_yrep, x = seq_along(vdiff_y)) + vdiffr::expect_doppelganger("ppc_error_scatter_avg_vs_x (default)", p_base) +}) + test_that("ppc_error_binned renders correctly", { testthat::skip_on_cran() testthat::skip_if_not_installed("vdiffr") @@ -90,10 +130,5 @@ test_that("ppc_error_binned renders correctly", { y_rep <- t(apply(four_draws, 1, function(x) rbeta2(50, plogis(x[1]), x[2]))) p_base <- ppc_error_binned(y, y_rep) - - vdiffr::expect_doppelganger( - title = "ppc_error_binned (default)", - fig = p_base - ) - + vdiffr::expect_doppelganger("ppc_error_binned (default)", p_base) }) diff --git a/tests/testthat/test-ppc-input-validation.R b/tests/testthat/test-ppc-input-validation.R index 93bbbd77..ec3b205f 100644 --- a/tests/testthat/test-ppc-input-validation.R +++ b/tests/testthat/test-ppc-input-validation.R @@ -20,32 +20,33 @@ test_that("validate_y throws errors", { }) # validating yrep ---------------------------------------------------------- -test_that("validate_yrep works", { - expect_identical(validate_yrep(yrep, y), yrep) - expect_equal(validate_yrep(yrep2, y2), yrep2) +test_that("validate_predictions works", { + expect_identical(validate_predictions(yrep, length(y)), yrep) + expect_equal(validate_predictions(yrep2, length(y2)), yrep2) colnames(yrep) <- paste0("yrep", 1:ncol(yrep)) - expect_identical(validate_yrep(yrep, y), unname(yrep)) + expect_equivalent(validate_predictions(yrep, length(y)), unname(yrep)) }) -test_that("validate_yrep throws errors", { - expect_error(validate_yrep(as.matrix(LETTERS), y), "numeric") - expect_error(validate_yrep(rbind(yrep, NA), y), "NAs not allowed") - expect_error(validate_yrep(y, y), "matrix") - expect_error(validate_yrep(yrep2, y), "must be equal to") - expect_error(validate_yrep(yrep, y2), "must be equal to ") +test_that("validate_predictions throws errors", { + expect_error(validate_predictions(as.matrix(LETTERS), length(y)), "numeric") + expect_error(validate_predictions(rbind(yrep, NA), length(y)), "NAs not allowed") + expect_error(validate_predictions(y, length(y)), "matrix") + expect_error(validate_predictions(yrep2, length(y)), "must be equal to") + expect_error(validate_predictions(yrep, length(y2)), "must be equal to ") }) # validating group -------------------------------------------------------- test_that("validate_group works", { - expect_identical(validate_group(1:3, y = 1:3), as.factor(1:3)) - expect_identical(validate_group(as.numeric(1:3), y = 4:6), as.factor(1:3)) - expect_identical(validate_group(group, y), group) - expect_identical(validate_group(letters[1:3], y = 1:3), factor(letters[1:3])) + expect_identical(validate_group(1:3, n_obs = 3), as.factor(1:3)) + expect_identical(validate_group(as.numeric(1:3), n_obs = 3), as.factor(1:3)) + expect_identical(validate_group(group, n_obs = length(y)), group) + expect_identical(validate_group(letters[1:3], n_obs = 3), factor(letters[1:3])) }) test_that("validate_group throws errors", { - expect_error(validate_group(array(1:3), y = 1:3), "vector") - expect_error(validate_group(c(1,2,NA), y = 1:3), "NAs not allowed") - expect_error(validate_group(1:4, y = 1:3), "must be equal to") + expect_error(validate_group(array(1:3), n_obs = 3), "vector") + expect_error(validate_group(c(1,2,NA), n_obs = 3), "NAs not allowed") + expect_error(validate_group(1:4, n_obs = 3), + "must be equal to the number of observations") }) diff --git a/tests/testthat/test-ppc-intervals.R b/tests/testthat/test-ppc-intervals.R index fd9b516f..30047441 100644 --- a/tests/testthat/test-ppc-intervals.R +++ b/tests/testthat/test-ppc-intervals.R @@ -8,32 +8,46 @@ test_that("ppc_intervals returns ggplot object", { expect_gg(ppc_intervals(y, yrep, size = 2, fatten = 1)) expect_gg(ppc_intervals(y, yrep, x = seq(1, 2 * length(y), by = 2))) expect_gg(ppc_intervals(y2, yrep2)) + + # ppd versions + expect_gg(ppd_intervals(yrep, x = seq(1, 2 * length(y), by = 2))) + expect_gg(ppd_intervals(yrep2)) }) test_that("ppc_ribbon returns ggplot object", { expect_gg(ppc_ribbon(y, yrep, prob = 0.5)) expect_gg(ppc_ribbon(y, yrep, alpha = 0, size = .5)) expect_gg(ppc_ribbon(y2, yrep2, x = rnorm(length(y2)), prob = 0.5)) + + # ppd versions + expect_gg(ppd_ribbon(yrep, prob = 0.5)) + expect_gg(ppd_ribbon(yrep2, x = rnorm(length(y2)), prob = 0.5)) }) y <- rnorm(50) yrep <- matrix(rnorm(500, 0, 2), ncol = 50) x <- rep(1:10, each = 5) -group <- gl(5, 1, length = 50, labels = LETTERS[1:5]) +grp <- gl(5, 1, length = 50, labels = LETTERS[1:5]) +d <- ppc_intervals_data(y, yrep, x = 1:length(y), prob = .9) +d_group <- ppc_intervals_data(y, yrep, x, grp) test_that("ppc_intervals_grouped returns ggplot object", { - expect_gg(ppc_intervals_grouped(y, yrep, x, group)) + expect_gg(ppc_intervals_grouped(y, yrep, x, grp)) + + # ppd versions + expect_gg(ppd_intervals_grouped(yrep, x, grp)) }) test_that("ppc_ribbon_grouped returns ggplot object", { - expect_gg(ppc_ribbon_grouped(y, yrep, x, group)) - expect_gg(ppc_ribbon_grouped(y, yrep, x, group, facet_args = list(scales = "fixed"))) + expect_gg(ppc_ribbon_grouped(y, yrep, x, grp)) + expect_gg(ppc_ribbon_grouped(y, yrep, x, grp, facet_args = list(scales = "fixed"))) + + # ppd versions + expect_gg(ppd_ribbon_grouped(yrep, x, grp, facet_args = list(scales = "fixed"))) }) test_that("ppc_intervals_data returns correct structure", { - d <- ppc_intervals_data(y, yrep, x = 1:length(y), prob = .9) - d_group <- ppc_intervals_data(y, yrep, x, group) expect_named(d, c("y_id", "y_obs", "x", "outer_width", "inner_width", "ll", "l", "m", "h", "hh")) @@ -54,6 +68,13 @@ test_that("ppc_intervals_data returns correct structure", { ppc_intervals_data(y, yrep, x = 1:length(y), prob_outer = 1.01), "prob_outer") }) +test_that("ppd_intervals_data + y_obs column same as ppc_intervals_data", { + d2 <- ppd_intervals_data(yrep, x = 1:length(y), prob = .9) + d_group2 <- ppd_intervals_data(yrep, x, grp) + expect_equal(tibble::add_column(d2, y_obs = d$y_obs, .after = "y_id"), d) + expect_equal(tibble::add_column(d_group2, y_obs = d_group$y_obs, .after = "y_id"), d_group) +}) + test_that("ppc_intervals_data does math correctly", { d <- ppc_intervals_data(y, yrep, prob = .4, prob_outer = .8) qs <- unname(quantile(yrep[, 1], c(.1, .3, .5, .7, .9))) @@ -82,7 +103,6 @@ test_that("ppc_intervals_data does math correctly", { - # Visual tests ----------------------------------------------------------------- test_that("ppc_intervals renders correctly", { @@ -97,6 +117,16 @@ test_that("ppc_intervals renders correctly", { p_50 <- ppc_intervals(vdiff_y, vdiff_yrep, prob = .50) vdiffr::expect_doppelganger("ppc_intervals (interval width)", p_50) + + # ppd versions + p_base <- ppd_intervals(vdiff_yrep) + vdiffr::expect_doppelganger("ppd_intervals (default)", p_base) + + p_x <- ppd_intervals(vdiff_yrep, x = vdiff_y) + vdiffr::expect_doppelganger("ppd_intervals (x values)", p_x) + + p_50 <- ppd_intervals(vdiff_yrep, prob = .50) + vdiffr::expect_doppelganger("ppd_intervals (interval width)", p_50) }) test_that("ppc_intervals_grouped renders correctly", { @@ -112,6 +142,16 @@ test_that("ppc_intervals_grouped renders correctly", { x = vdiff_y, group = vdiff_group) vdiffr::expect_doppelganger("ppc_intervals_grouped (x values)", p_x) + + # ppd versions + p_base <- ppd_intervals_grouped(vdiff_yrep, group = vdiff_group) + vdiffr::expect_doppelganger("ppd_intervals_grouped (default)", p_base) + + p_x <- ppd_intervals_grouped( + ypred = vdiff_yrep, + x = vdiff_y, + group = vdiff_group) + vdiffr::expect_doppelganger("ppd_intervals_grouped (x values)", p_x) }) test_that("ppc_ribbon renders correctly", { @@ -128,13 +168,23 @@ test_that("ppc_ribbon renders correctly", { vdiffr::expect_doppelganger("ppc_ribbon (interval width)", p_50) p_line <- ppc_ribbon(vdiff_y, vdiff_yrep, y_draw = "line") - vdiffr::expect_doppelganger("ppc_intervals (y_draw = line)", p_line) + vdiffr::expect_doppelganger("ppc_ribbon (y_draw = line)", p_line) p_point <- ppc_ribbon(vdiff_y, vdiff_yrep, y_draw = "point") - vdiffr::expect_doppelganger("ppc_intervals (y_draw = point)", p_point) + vdiffr::expect_doppelganger("ppc_ribbon (y_draw = point)", p_point) p_both <- ppc_ribbon(vdiff_y, vdiff_yrep, y_draw = "both") - vdiffr::expect_doppelganger("ppc_intervals (y_draw = both)", p_both) + vdiffr::expect_doppelganger("ppc_ribbon (y_draw = both)", p_both) + + # ppd versions + p_base <- ppd_ribbon(vdiff_yrep) + vdiffr::expect_doppelganger("ppd_ribbon (default)", p_base) + + p_x <- ppd_ribbon(vdiff_yrep, x = vdiff_y) + vdiffr::expect_doppelganger("ppd_ribbon (x values)", p_x) + + p_50 <- ppd_ribbon(vdiff_yrep, prob = 0.5) + vdiffr::expect_doppelganger("ppd_ribbon (interval width)", p_50) }) test_that("ppc_ribbon_grouped renders correctly", { @@ -162,4 +212,14 @@ test_that("ppc_ribbon_grouped renders correctly", { x = vdiff_y, group = vdiff_group) vdiffr::expect_doppelganger("ppc_ribbon_grouped (x values)", p_x) + + # ppd versions + p_base <- ppd_ribbon_grouped(vdiff_yrep, group = vdiff_group) + vdiffr::expect_doppelganger("ppd_ribbon_grouped (default)", p_base) + + p_x <- ppd_ribbon_grouped( + ypred = vdiff_yrep, + x = vdiff_y, + group = vdiff_group) + vdiffr::expect_doppelganger("ppd_ribbon_grouped (x values)", p_x) }) diff --git a/tests/testthat/test-ppc-scatterplots.R b/tests/testthat/test-ppc-scatterplots.R index abe12a4b..56d74ac2 100644 --- a/tests/testthat/test-ppc-scatterplots.R +++ b/tests/testthat/test-ppc-scatterplots.R @@ -14,17 +14,12 @@ test_that("ppc_scatter_avg returns ggplot object", { expect_gg(ppc_scatter_avg(y2, yrep2)) }) -test_that("ppc_scatter_avg same as ppc_scatter if nrow(yrep) = 1", { - expect_equal( - ppc_scatter_avg(y2, yrep2), - ppc_scatter(y2, yrep2), - check.environment = FALSE - ) - expect_equal( - ppc_scatter_avg(y, yrep[1,, drop=FALSE]), - ppc_scatter(y, yrep[1,, drop = FALSE]), - check.environment = FALSE - ) +test_that("ppc_scatter_avg_data same as ppc_scatter_data if nrow(yrep) = 1", { + # really only a few columns are _exactly_ the same + cols <- c("y_id", "y_obs", "value") + d1 <- ppc_scatter_data(y2, yrep2) + d2 <- ppc_scatter_avg_data(y2, yrep2) + expect_equal(d1[, cols], d2[, cols]) }) test_that("ppc_scatter_avg_grouped returns a ggplot object", { @@ -67,7 +62,7 @@ test_that("ppc_scatter_avg renders correctly", { y = vdiff_y, yrep = vdiff_yrep, size = 1.5, - alpha = .5 + alpha = .1 ) vdiffr::expect_doppelganger( @@ -87,11 +82,11 @@ test_that("ppc_scatter_avg_grouped renders correctly", { yrep = vdiff_yrep, group = vdiff_group, size = 3, - alpha = 0.25 + alpha = 0.25, + ref_line = FALSE ) vdiffr::expect_doppelganger( - title = "ppc_scatter_avg_grouped (size, alpha)", + title = "ppc_scatter_avg_grouped (size, alpha, ref_line)", fig = p_custom) }) - diff --git a/tests/testthat/test-ppc-test-statistics.R b/tests/testthat/test-ppc-test-statistics.R index 6da5c6c2..91ee9877 100644 --- a/tests/testthat/test-ppc-test-statistics.R +++ b/tests/testthat/test-ppc-test-statistics.R @@ -8,14 +8,20 @@ prop0 <- function(x) mean(x == 0) test_that("ppc_stat throws errors if function not found", { expect_error(ppc_stat(y, yrep, stat = "9999"), "not found") + expect_error(ppc_stat_freqpoly(y, yrep, stat = "9999"), "not found") expect_error(ppc_stat_grouped(y, yrep, group, stat = "9999"), "not found") expect_error(ppc_stat_freqpoly_grouped(y, yrep, group, stat = "9999"), "not found") }) test_that("ppc_stat throws errors if 'stat' wrong length", { - expect_error(ppc_stat(y, yrep, stat = c("mean", "sd")), "not a function") - expect_error(ppc_stat_grouped(y, yrep, group, stat = c("mean", "sd")), "not a function") - expect_error(ppc_stat_freqpoly_grouped(y, yrep, group, stat = c(mean, sd)), "not a function") + expect_error(ppc_stat(y, yrep, stat = c("mean", "sd")), + "length(stat) == 1 is not TRUE", fixed = TRUE) + expect_error(ppc_stat_grouped(y, yrep, group, stat = c("mean", "sd")), + "length(stat) == 1 is not TRUE", fixed = TRUE) + expect_error(ppc_stat_freqpoly(y, yrep, stat = c("mean", "sd")), + "length(stat) == 1 is not TRUE", fixed = TRUE) + expect_error(ppc_stat_freqpoly_grouped(y, yrep, group, stat = c(mean, sd)), + "length(stat) == 1 is not TRUE", fixed = TRUE) }) test_that("ppc_stat returns ggplot object", { @@ -25,9 +31,13 @@ test_that("ppc_stat returns ggplot object", { expect_gg(ppc_stat(y, yrep, stat = "q25")) expect_gg(ppc_stat(y, yrep, stat = q25)) expect_gg(ppc_stat(y, yrep, stat = function(x) median(x))) - expect_gg(ppc_stat(y2, yrep2)) expect_gg(ppc_stat(y2, yrep2, stat = "prop0")) + + # ppd versions + expect_gg(ppd_stat(yrep, stat = "q25")) + expect_gg(ppd_stat(yrep, stat = q25)) + expect_gg(ppd_stat(yrep2, stat = "prop0")) }) test_that("ppc_stat_2d returns ggplot object", { @@ -35,11 +45,15 @@ test_that("ppc_stat_2d returns ggplot object", { expect_gg(ppc_stat_2d(y, yrep, stat = c("q25", "median"))) expect_gg(ppc_stat_2d(y, yrep, stat = c("q25", median))) expect_gg(ppc_stat_2d(y, yrep, stat = c(function(x) mean(x), function(y) sd(y)))) - expect_gg(ppc_stat_2d(y2, yrep2)) + + # ppd versions + expect_gg(ppd_stat_2d(yrep, stat = c("q25", median))) + expect_gg(ppd_stat_2d(yrep, stat = c(function(x) mean(x), function(y) sd(y)))) + expect_gg(ppd_stat_2d(yrep2)) }) -test_that("ppc_stat_2d erros if more than 2 stats", { +test_that("ppc_stat_2d errors if more than 2 stats", { expect_error(ppc_stat_2d(y, yrep, stat = c("mean", "sd", "var")), "argument must have length 2") }) @@ -49,9 +63,34 @@ test_that("ppc_stat_grouped returns ggplot object", { expect_gg(ppc_stat_grouped(y, yrep, as.numeric(group), stat = function(z) var(z))) expect_gg(ppc_stat_grouped(y, yrep, as.integer(group), stat = "sd")) }) + test_that("ppc_stat_freqpoly_grouped returns ggplot object", { expect_gg(ppc_stat_freqpoly_grouped(y, yrep, group, stat = "sd", freq = FALSE)) expect_gg(ppc_stat_freqpoly_grouped(y, yrep, group, stat = function(x) sd(x), freq = TRUE)) + + # ppd version + expect_gg(ppd_stat_freqpoly_grouped(yrep, group, stat = "sd", freq = FALSE)) +}) + +test_that("ppc_stat_data without the y values equal to ppd_stat_data", { + d <- ppc_stat_data(y, yrep, group, stat = "median") + d2 <- ppd_stat_data(yrep, group, stat = median) + expect_equal(d$value[d$variable != "y"], d2$value) + expect_equal(d$group[d$variable != "y"], d2$group) + + # with 2 stats + d <- ppc_stat_data(y, yrep, group, stat = c(mean, median)) + d2 <- ppd_stat_data(yrep, group, stat = c("mean", "median")) + expect_equal(d$value[d$variable != "y"], d2$value) + expect_equal(d$value2[d$variable != "y"], d2$value2) + expect_equal(d$group[d$variable != "y"], d2$group) +}) + +test_that("ppc_stat_data and ppd_stat_data throw correct errors", { + expect_error(ppc_stat_data(y, yrep, stat = letters), "'stat' must have length 1 or 2") + expect_error(ppd_stat_data(yrep, stat = letters), "'stat' must have length 1 or 2") + expect_error(ppd_stat_data(yrep, stat = "not_a_known_function"), + "object 'not_a_known_function' of mode 'function' was not found") }) @@ -71,10 +110,23 @@ test_that("ppc_stat renders correctly", { binwidth = .05, freq = FALSE ) + yaxis_text() - vdiffr::expect_doppelganger( title = "ppc_stat (stat, binwidth, freq)", fig = p_custom) + + # ppd versions + p_base <- ppd_stat(vdiff_yrep) + yaxis_text() + vdiffr::expect_doppelganger("ppd_stat (default)", p_base) + + p_custom <- ppd_stat( + ypred = vdiff_yrep, + stat = "mad", + binwidth = .05, + freq = FALSE + ) + yaxis_text() + vdiffr::expect_doppelganger( + title = "ppd_stat (stat, binwidth, freq)", + fig = p_custom) }) test_that("ppc_stat_2d renders correctly", { @@ -91,10 +143,23 @@ test_that("ppc_stat_2d renders correctly", { size = 5, alpha = 1 ) - vdiffr::expect_doppelganger( title = "ppc_stat_2d (stat, size, alpha)", fig = p_custom) + + # ppd versions + p_base <- ppd_stat_2d(vdiff_yrep) + vdiffr::expect_doppelganger("ppd_stat_2d (default)", p_base) + + p_custom <- ppd_stat_2d( + ypred = vdiff_yrep, + stat = c("median", "mad"), + size = 5, + alpha = 1 + ) + vdiffr::expect_doppelganger( + title = "ppd_stat_2d (stat, size, alpha)", + fig = p_custom) }) test_that("ppc_stat_grouped renders correctly", { @@ -112,10 +177,24 @@ test_that("ppc_stat_grouped renders correctly", { facet_args = list(scales = "fixed", ncol = 1), binwidth = .25 ) - vdiffr::expect_doppelganger( title = "ppc_stat_grouped (stat, facet_args, binwidth)", fig = p_custom) + + # ppd versions + p_base <- ppd_stat_grouped(vdiff_yrep, vdiff_group) + vdiffr::expect_doppelganger("ppd_stat_grouped (default)", p_base) + + p_custom <- ppd_stat_grouped( + ypred = vdiff_yrep, + group = vdiff_group, + stat = stats::var, + facet_args = list(scales = "fixed", ncol = 1), + binwidth = .25 + ) + vdiffr::expect_doppelganger( + title = "ppd_stat_grouped (stat, facet_args, binwidth)", + fig = p_custom) }) test_that("ppc_stat_freqpoly_grouped renders correctly", { @@ -133,10 +212,22 @@ test_that("ppc_stat_freqpoly_grouped renders correctly", { facet_args = list(scales = "fixed", ncol = 1), binwidth = .5 ) - vdiffr::expect_doppelganger( title = "ppc_stat_freqpoly_grouped (stat, facet_args, binwidth)", fig = p_custom) -}) + # ppd versions + p_base <- ppd_stat_freqpoly_grouped(vdiff_yrep, vdiff_group) + vdiffr::expect_doppelganger("ppd_stat_freqpoly_grouped (default)", p_base) + p_custom <- ppd_stat_freqpoly_grouped( + ypred = vdiff_yrep, + group = vdiff_group, + stat = "sum", + facet_args = list(scales = "fixed", ncol = 1), + binwidth = .5 + ) + vdiffr::expect_doppelganger( + title = "ppd_stat_freqpoly_grouped (stat, facet_args, binwidth)", + fig = p_custom) +})