From 16f13386bee33ddb446f8887f95f7b4573b3bd90 Mon Sep 17 00:00:00 2001 From: BehramUlukir Date: Wed, 28 Jan 2026 15:11:41 +0200 Subject: [PATCH] adding ppc_rootogram_grouped --- NAMESPACE | 1 + R/ppc-discrete.R | 109 ++++++++++-- man/PPC-discrete.Rd | 25 ++- .../ppc-rootogram-grouped-default.svg | 119 +++++++++++++ ...ogram-grouped-style-discrete-prob-size.svg | 156 ++++++++++++++++++ ...ped-style-hanging-prob-size-facet-args.svg | 127 ++++++++++++++ tests/testthat/test-ppc-discrete.R | 51 ++++++ 7 files changed, 572 insertions(+), 16 deletions(-) create mode 100644 tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-default.svg create mode 100644 tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-style-discrete-prob-size.svg create mode 100644 tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-style-hanging-prob-size-facet-args.svg diff --git a/NAMESPACE b/NAMESPACE index 4823d8df..1b82b4ec 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -155,6 +155,7 @@ export(ppc_ribbon) export(ppc_ribbon_data) export(ppc_ribbon_grouped) export(ppc_rootogram) +export(ppc_rootogram_grouped) export(ppc_scatter) export(ppc_scatter_avg) export(ppc_scatter_avg_data) diff --git a/R/ppc-discrete.R b/R/ppc-discrete.R index c346247f..106d7182 100644 --- a/R/ppc-discrete.R +++ b/R/ppc-discrete.R @@ -24,7 +24,7 @@ #' [ggplot2::geom_line()] and [ggplot2::geom_pointrange()]. #' @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. -#' @param bound_distinct For `ppc_rootogram(style = "discrete)`, +#' @param bound_distinct For `ppc_rootogram(style = "discrete)` and `ppc_rootogram_grouped(style = "discrete)`, #' if `TRUE` then the observed counts will be plotted with different shapes #' depending on whether they are within the bounds of the `y` quantiles. #' @@ -75,6 +75,10 @@ #' and Zeileis (2016) for advice on interpreting rootograms and selecting #' among the different styles. #' } +#' \item{`ppc_rootogram_grouped()`}{ +#' Same as `ppc_rootogram()` but a separate plot (facet) is generated for each +#' level of a grouping variable. +#' } #' } #' #' @section Related functions: @@ -147,6 +151,24 @@ #' ) #' } #' +#' # rootograms for counts +#' y <- rpois(100, 20) +#' yrep <- matrix(rpois(10000, 20), ncol = 100) +#' +#' color_scheme_set("brightblue") +#' ppc_rootogram(y, yrep) +#' ppc_rootogram(y, yrep, prob = 0) +#' +#' ppc_rootogram(y, yrep, style = "hanging", prob = 0.8) +#' ppc_rootogram(y, yrep, style = "suspended") +#' ppc_rootogram(y, yrep, style = "discrete") +#' +#' # rootograms for counts with groups +#' group <- gl(2, 50, length = 100, labels = c("GroupA", "GroupB")) +#' ppc_rootogram_grouped(y, yrep, group) +#' ppc_rootogram_grouped(y, yrep, group, style = "hanging", facet_args = list(nrow = 2)) +#' ppc_rootogram_grouped(y, yrep, group, style = "discrete", prob = 0.5) +#' NULL #' @rdname PPC-discrete @@ -253,19 +275,6 @@ ppc_bars_grouped <- #' *The American Statistician*. 70(3): 296--303. #' . #' -#' @examples -#' # rootograms for counts -#' y <- rpois(100, 20) -#' yrep <- matrix(rpois(10000, 20), ncol = 100) -#' -#' color_scheme_set("brightblue") -#' ppc_rootogram(y, yrep) -#' ppc_rootogram(y, yrep, prob = 0) -#' -#' ppc_rootogram(y, yrep, style = "hanging", prob = 0.8) -#' ppc_rootogram(y, yrep, style = "suspended") -#' ppc_rootogram(y, yrep, style = "discrete") -#' ppc_rootogram <- function(y, yrep, style = c("standing", "hanging", "suspended", "discrete"), @@ -273,12 +282,19 @@ ppc_rootogram <- function(y, prob = 0.9, size = 1, bound_distinct = TRUE) { - check_ignored_arguments(...) + + dots <- list(...) + if (!from_grouped(dots)) { + check_ignored_arguments(...) + dots$group <- NULL + } + style <- match.arg(style) data <- .ppc_rootogram_data( y = y, yrep = yrep, + group = dots$group, style = style, prob = prob, bound_distinct = bound_distinct @@ -367,6 +383,33 @@ ppc_rootogram <- function(y, } +#' @rdname PPC-discrete +#' @export +ppc_rootogram_grouped <- + function(y, + yrep, + group, + style = c("standing", "hanging", "suspended", "discrete"), + ..., + facet_args = list(), + prob = 0.9, + size = 1, + bound_distinct = TRUE) { + check_ignored_arguments(...) + style <- match.arg(style) + call <- match.call(expand.dots = FALSE) + g <- eval(ungroup_call("ppc_rootogram", call), parent.frame()) + + # In style = discrete, scale_y_sqrt() can't handle -Inf values in axis segments + # so force_axes_in_facets() results in errors + if (style != "discrete") { + g <- g + force_axes_in_facets() + } + + g + bars_group_facets(facet_args) + } + + #' @rdname PPC-discrete #' @export ppc_bars_data <- @@ -481,11 +524,13 @@ fixed_y <- function(facet_args) { #' Internal function for `ppc_rootogram()` #' @param y,yrep User's `y` and `yrep` arguments. +#' @param group User's `group` argument (can be NULL). #' @param style,prob,bound_distinct User's `style`, `prob`, and #' (if applicable) `bound_distinct` arguments. #' @noRd .ppc_rootogram_data <- function(y, yrep, + group = NULL, style = c("standing", "hanging", "suspended", "discrete"), prob = 0.9, bound_distinct) { @@ -498,7 +543,41 @@ fixed_y <- function(facet_args) { if (!all_counts(yrep)) { abort("ppc_rootogram expects counts as inputs to 'yrep'.") } + + if (!is.null(group)) { + group <- validate_group(group, length(y)) + } + + # Handle grouped data + if (!is.null(group)) { + group_levels <- unique(group) + all_data <- list() + + for (g in seq_along(group_levels)) { + grp <- group_levels[g] + idx <- which(group == grp) + + y_g <- y[idx] + yrep_g <- yrep[, idx, drop = FALSE] + + # Call this function recursively without group + data_g <- .ppc_rootogram_data( + y = y_g, + yrep = yrep_g, + group = NULL, + style = style, + prob = prob, + bound_distinct = bound_distinct + ) + + data_g$group <- grp + all_data[[g]] <- data_g + } + + return(do.call(rbind, all_data)) + } + # Ungrouped data processing alpha <- (1 - prob) / 2 probs <- c(alpha, 1 - alpha) ymax <- max(y, yrep) diff --git a/man/PPC-discrete.Rd b/man/PPC-discrete.Rd index d996cd95..2b19c3ef 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_rootogram_grouped} \alias{ppc_bars_data} \title{PPCs for discrete outcomes} \usage{ @@ -44,6 +45,18 @@ ppc_rootogram( bound_distinct = TRUE ) +ppc_rootogram_grouped( + y, + yrep, + group, + style = c("standing", "hanging", "suspended", "discrete"), + ..., + facet_args = list(), + prob = 0.9, + size = 1, + bound_distinct = TRUE +) + ppc_bars_data(y, yrep, group = NULL, prob = 0.9, freq = TRUE) } \arguments{ @@ -88,7 +101,7 @@ style. The options are \code{"discrete"}, \code{"standing"}, \code{"hanging"}, a \code{"suspended"}. See the \strong{Plot Descriptions} section, below, for details on the different styles.} -\item{bound_distinct}{For \verb{ppc_rootogram(style = "discrete)}, +\item{bound_distinct}{For \verb{ppc_rootogram(style = "discrete)} and \verb{ppc_rootogram_grouped(style = "discrete)}, if \code{TRUE} then the observed counts will be plotted with different shapes depending on whether they are within the bounds of the \code{y} quantiles.} } @@ -155,6 +168,10 @@ using \code{discrete} style is suggested. and Zeileis (2016) for advice on interpreting rootograms and selecting among the different styles. } +\item{\code{ppc_rootogram_grouped()}}{ +Same as \code{ppc_rootogram()} but a separate plot (facet) is generated for each +level of a grouping variable. +} } } @@ -244,6 +261,12 @@ ppc_rootogram(y, yrep, style = "hanging", prob = 0.8) ppc_rootogram(y, yrep, style = "suspended") ppc_rootogram(y, yrep, style = "discrete") +# rootograms for counts with groups +group <- gl(2, 50, length = 100, labels = c("GroupA", "GroupB")) +ppc_rootogram_grouped(y, yrep, group) +ppc_rootogram_grouped(y, yrep, group, style = "hanging", facet_args = list(nrow = 2)) +ppc_rootogram_grouped(y, yrep, group, style = "discrete", prob = 0.5) + } \references{ Kleiber, C. and Zeileis, A. (2016). diff --git a/tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-default.svg b/tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-default.svg new file mode 100644 index 00000000..7d110586 --- /dev/null +++ b/tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-default.svg @@ -0,0 +1,119 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 + + + + + + + + + +2 + + + + + + +0 +2 +4 + + + + +0 +2 +4 + +0 +1 +2 +3 + + + + +y + +C +o +u +n +t + +Observed + + +Expected +ppc_rootogram_grouped (default) + + diff --git a/tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-style-discrete-prob-size.svg b/tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-style-discrete-prob-size.svg new file mode 100644 index 00000000..fb2079f3 --- /dev/null +++ b/tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-style-discrete-prob-size.svg @@ -0,0 +1,156 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 + + + + + + + + + +2 + + + + + + + + + +0 +1 +2 +3 +4 +5 + + + + + + + +0 +1 +2 +3 +4 +5 + +0.0 +2.5 +5.0 +7.5 + + + + +y +Count +y + +w +i +t +h +i +n + +b +o +u +n +d +s + + +In +Out + + +y +r +e +p +ppc_rootogram_grouped (style='discrete', prob, size) + + diff --git a/tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-style-hanging-prob-size-facet-args.svg b/tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-style-hanging-prob-size-facet-args.svg new file mode 100644 index 00000000..f93002f6 --- /dev/null +++ b/tests/testthat/_snaps/ppc-discrete/ppc-rootogram-grouped-style-hanging-prob-size-facet-args.svg @@ -0,0 +1,127 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 + + + + + + + + + +1 + + + + + + +0 +2 +4 + +-1 +0 +1 +2 +3 + + + + + + +-1 +0 +1 +2 +3 + + + + + +y + +C +o +u +n +t + +Observed + + +Expected +ppc_rootogram_grouped (style='hanging', prob, size, facet_args) + + diff --git a/tests/testthat/test-ppc-discrete.R b/tests/testthat/test-ppc-discrete.R index 005fdc94..9a6dd9a9 100644 --- a/tests/testthat/test-ppc-discrete.R +++ b/tests/testthat/test-ppc-discrete.R @@ -97,6 +97,20 @@ test_that("ppc_rootogram errors if y/yrep not counts", { "ncol(yrep) must be equal to length(y)", fixed = TRUE) }) +test_that("ppc_rootogram_grouped returns a ggplot object", { + expect_gg(ppc_rootogram_grouped(y2, yrep2, group = vdiff_group2)) + expect_gg(ppc_rootogram_grouped(y2, yrep3, group = vdiff_group2, style = "hanging", prob = 0.5)) + expect_gg(ppc_rootogram_grouped(y2, yrep3, group = vdiff_group2, style = "suspended")) + expect_gg(ppc_rootogram_grouped(y2, yrep3, group = vdiff_group2, style = "discrete")) +}) + +test_that("ppc_rootogram_grouped errors if y/yrep not counts", { + expect_error(ppc_rootogram_grouped(y, yrep, group = vdiff_group2), + "ppc_rootogram expects counts as inputs to 'y'") + expect_error(ppc_rootogram_grouped(y2, yrep[1:5, seq_along(y2)], group = vdiff_group2), + "ppc_rootogram expects counts as inputs to 'yrep'") +}) + # Visual tests ------------------------------------------------------------ @@ -202,3 +216,40 @@ test_that("ppc_rootogram renders correctly", { fig = p_discrete_nonbound) }) +test_that("ppc_rootogram_grouped renders correctly", { + testthat::skip_on_cran() + testthat::skip_if_not_installed("vdiffr") + skip_on_r_oldrel() + + p_base <- ppc_rootogram_grouped(vdiff_y2, vdiff_yrep2, vdiff_group2) + vdiffr::expect_doppelganger("ppc_rootogram_grouped (default)", p_base) + + p_custom_hanging <- ppc_rootogram_grouped( + y = vdiff_y2, + yrep = vdiff_yrep2, + group = vdiff_group2, + prob = 2/3, + size = 2, + style = "hanging", + facet_args = list(nrow = 2) + ) + + vdiffr::expect_doppelganger( + title = "ppc_rootogram_grouped (style='hanging', prob, size, facet_args)", + fig = p_custom_hanging) + + p_discrete <- ppc_rootogram_grouped( + y = vdiff_y2, + yrep = vdiff_yrep2, + group = vdiff_group2, + prob = 0.5, + size = 1, + style = "discrete" + ) + + vdiffr::expect_doppelganger( + title = "ppc_rootogram_grouped (style='discrete', prob, size)", + fig = p_discrete) +}) + +