From e5221f08aaf6b498471af9650aa2b4ef317aab46 Mon Sep 17 00:00:00 2001 From: Sakuski Date: Tue, 20 May 2025 21:40:30 +0300 Subject: [PATCH 1/9] Add extrapolation_factor parameter to ppc_km_overlay and ppc_km_overlay_grouped --- R/ppc-censoring.R | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index 7f39a78b..4cee19f6 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -88,7 +88,8 @@ ppc_km_overlay <- function( status_y, left_truncation_y = NULL, size = 0.25, - alpha = 0.7 + alpha = 0.7, + extrapolation_factor = 1.2 ) { check_ignored_arguments(..., ok_args = "add_group") add_group <- list(...)$add_group @@ -106,6 +107,10 @@ ppc_km_overlay <- function( } } + if (extrapolation_factor < 1) { + stop("`extrapolation_factor` must be greater than or equal to 1.") + } + data <- ppc_data(y, yrep, group = status_y) # Modify the status indicator: @@ -149,6 +154,10 @@ ppc_km_overlay <- function( fsf$is_y_size <- ifelse(fsf$is_y_color == "yrep", size, 1) fsf$is_y_alpha <- ifelse(fsf$is_y_color == "yrep", alpha, 1) + max_time_y <- max(y, na.rm = TRUE) + fsf <- fsf %>% + dplyr::filter(is_y_color != "yrep" | time <= max_time_y * extrapolation_factor) + # Ensure that the observed data gets plotted last by reordering the # levels of the factor "strata" fsf$strata <- factor(fsf$strata, levels = rev(levels(fsf$strata))) From 0d48ddda1aa109cd33fe85452dcae6e4d20779c8 Mon Sep 17 00:00:00 2001 From: Sakuski Date: Mon, 26 May 2025 17:58:44 +0300 Subject: [PATCH 2/9] Add unit tests for extrapolation-factor and fix existing visual tests --- R/ppc-censoring.R | 6 +- .../ppc-km-overlay-default-2.svg | 44 +++++----- .../ppc-km-overlay-grouped-default-2.svg | 88 ++++++++++--------- ...c-km-overlay-grouped-left-truncation-y.svg | 88 ++++++++++--------- .../ppc-km-overlay-left-truncation-y.svg | 44 +++++----- tests/testthat/test-ppc-censoring.R | 11 ++- 6 files changed, 152 insertions(+), 129 deletions(-) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index 4cee19f6..2a454638 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -204,7 +204,8 @@ ppc_km_overlay_grouped <- function( status_y, left_truncation_y = NULL, size = 0.25, - alpha = 0.7 + alpha = 0.7, + extrapolation_factor = 1.2 ) { check_ignored_arguments(...) @@ -216,7 +217,8 @@ ppc_km_overlay_grouped <- function( status_y = status_y, left_truncation_y = left_truncation_y, size = size, - alpha = alpha + alpha = alpha, + extrapolation_factor = extrapolation_factor ) p_overlay + diff --git a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-default-2.svg b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-default-2.svg index 792f234d..a04d8745 100644 --- a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-default-2.svg +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-default-2.svg @@ -25,17 +25,17 @@ - - - - - - - - - - - + + + + + + + + + + + @@ -49,16 +49,18 @@ - - - - - -0 -10 -20 -30 -40 + + + + + + +0 +5 +10 +15 +20 +25 y diff --git a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-default-2.svg b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-default-2.svg index a24e432f..73ef1f39 100644 --- a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-default-2.svg +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-default-2.svg @@ -25,17 +25,17 @@ - - - - - - - - - - - + + + + + + + + + + + @@ -50,17 +50,17 @@ - - - - - - - - - - - + + + + + + + + + + + @@ -89,27 +89,31 @@ - - - - - -0 -10 -20 -30 -40 + + + + + + +0 +5 +10 +15 +20 +25 - - - - - -0 -10 -20 -30 -40 + + + + + + +0 +5 +10 +15 +20 +25 0.0 0.5 diff --git a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-left-truncation-y.svg b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-left-truncation-y.svg index 8b812eda..1d094bde 100644 --- a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-left-truncation-y.svg +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-left-truncation-y.svg @@ -25,17 +25,17 @@ - - - - - - - - - - - + + + + + + + + + + + @@ -50,17 +50,17 @@ - - - - - - - - - - - + + + + + + + + + + + @@ -89,27 +89,31 @@ - - - - - -0 -10 -20 -30 -40 + + + + + + +0 +5 +10 +15 +20 +25 - - - - - -0 -10 -20 -30 -40 + + + + + + +0 +5 +10 +15 +20 +25 0.0 0.5 diff --git a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-left-truncation-y.svg b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-left-truncation-y.svg index 9496f17d..7ad60bab 100644 --- a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-left-truncation-y.svg +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-left-truncation-y.svg @@ -25,17 +25,17 @@ - - - - - - - - - - - + + + + + + + + + + + @@ -49,16 +49,18 @@ - - - - - -0 -10 -20 -30 -40 + + + + + + +0 +5 +10 +15 +20 +25 y diff --git a/tests/testthat/test-ppc-censoring.R b/tests/testthat/test-ppc-censoring.R index 611d2c3f..b9008750 100644 --- a/tests/testthat/test-ppc-censoring.R +++ b/tests/testthat/test-ppc-censoring.R @@ -5,7 +5,8 @@ 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, left_truncation_y = left_truncation_y, size = 0.5, alpha = 0.2)) + expect_gg(ppc_km_overlay(y, yrep, status_y = status_y, left_truncation_y = left_truncation_y, size = 0.5, alpha = 0.2, extrapolation_factor = Inf)) + expect_gg(ppc_km_overlay(y, yrep, status_y = status_y, left_truncation_y = left_truncation_y, size = 0.5, alpha = 0.2, extrapolation_factor = 1)) expect_gg(ppc_km_overlay(y2, yrep2, status_y = status_y2)) }) @@ -60,6 +61,14 @@ test_that("ppc_km_overlay errors if bad left_truncation_y value", { ) }) +test_that("ppc_km_overlay errors if bad extrapolation_factor value", { + skip_if_not_installed("ggfortify") + expect_error( + ppc_km_overlay(y, yrep, status_y = status_y, extrapolation_factor = 0.99), + "`extrapolation_factor` must be greater than or equal to 1." + ) +}) + # Visual tests ----------------------------------------------------------------- test_that("ppc_km_overlay renders correctly", { From 6d71247b1f700aa0e0391ca4f6181f1dd82a3e38 Mon Sep 17 00:00:00 2001 From: Sakuski Date: Mon, 26 May 2025 20:46:21 +0300 Subject: [PATCH 3/9] Add documentation for the extrapolation_factor parameter in ppc_km_overlay --- R/ppc-censoring.R | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index 2a454638..ff5e397b 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -81,6 +81,13 @@ NULL #' (delayed entry) times for the observations from `y`. This must #' be a numeric vector of the same length as `y`. If `NULL` (default), #' no left-truncation is assumed. +#' @param extrapolation_factor A numeric value (>=1) that controls how far the +#' plot is extended beyond the largest observed value in `y`. The default +#' value is 1.2, which corresponds to 20 % extrapolation. To display all +#' posterior predictive draws, set `extrapolation_factor = Inf`. +#' Note that the plot is never extrapolated further than the largest +#' value in `yrep`. +#' ppc_km_overlay <- function( y, yrep, From 3ba7489d79dc8d7d94dc06520df35d83f369965d Mon Sep 17 00:00:00 2001 From: Sakuski Date: Mon, 26 May 2025 21:33:46 +0300 Subject: [PATCH 4/9] Add examples for extrapolation_factor parameter in ppc_km_overlay --- R/ppc-censoring.R | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index ff5e397b..c39c53b3 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -53,6 +53,14 @@ #' \donttest{ #' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y) #' } +#' # With extrapolation_factor = 1 (no extrapolation) +#' \donttest{ +#' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, extrapolation_factor = 1) +#' } +#' # With extrapolation_factor = Inf (show all posterior predictive draws) +#' \donttest{ +#' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, extrapolation_factor = Inf) +#' } #' # With separate facets by group: #' group <- example_group_data() #' \donttest{ @@ -83,10 +91,10 @@ NULL #' no left-truncation is assumed. #' @param extrapolation_factor A numeric value (>=1) that controls how far the #' plot is extended beyond the largest observed value in `y`. The default -#' value is 1.2, which corresponds to 20 % extrapolation. To display all -#' posterior predictive draws, set `extrapolation_factor = Inf`. -#' Note that the plot is never extrapolated further than the largest -#' value in `yrep`. +#' value is 1.2, which corresponds to 20 % extrapolation. Note that all +#' posterior predictive draws may not be shown by default because of +#' the controlled extrapolation. To display all posterior predictive draws, +#' set `extrapolation_factor = Inf`. #' ppc_km_overlay <- function( y, From 4349844be46a3e3fcf70f6f180c69e45f75ce321 Mon Sep 17 00:00:00 2001 From: Sakuski Date: Mon, 26 May 2025 21:54:47 +0300 Subject: [PATCH 5/9] Add visual tests for extrapolation_factor parameter in ppc_km_overlay --- ...c-km-overlay-grouped-max-extrapolation.svg | 129 ++++++++++++++++++ ...pc-km-overlay-grouped-no-extrapolation.svg | 129 ++++++++++++++++++ .../ppc-km-overlay-max-extrapolation.svg | 71 ++++++++++ .../ppc-km-overlay-no-extrapolation.svg | 71 ++++++++++ tests/testthat/test-ppc-censoring.R | 52 ++++++- 5 files changed, 448 insertions(+), 4 deletions(-) create mode 100644 tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-max-extrapolation.svg create mode 100644 tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-no-extrapolation.svg create mode 100644 tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-max-extrapolation.svg create mode 100644 tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-no-extrapolation.svg diff --git a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-max-extrapolation.svg b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-max-extrapolation.svg new file mode 100644 index 00000000..ec169b9e --- /dev/null +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-max-extrapolation.svg @@ -0,0 +1,129 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 + + + + + + + + + +2 + + + + + + + + +0 +10 +20 +30 +40 + + + + + + +0 +10 +20 +30 +40 + +0.0 +0.5 +1.0 + + + + + +y +y +r +e +p +ppc_km_overlay_grouped (max extrapolation) + + diff --git a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-no-extrapolation.svg b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-no-extrapolation.svg new file mode 100644 index 00000000..c3d814cd --- /dev/null +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-no-extrapolation.svg @@ -0,0 +1,129 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 + + + + + + + + + +2 + + + + + + + + +0 +5 +10 +15 +20 + + + + + + +0 +5 +10 +15 +20 + +0.0 +0.5 +1.0 + + + + + +y +y +r +e +p +ppc_km_overlay_grouped (no extrapolation) + + diff --git a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-max-extrapolation.svg b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-max-extrapolation.svg new file mode 100644 index 00000000..84cf51e6 --- /dev/null +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-max-extrapolation.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.5 +1.0 + + + + + + + + + +0 +10 +20 +30 +40 + + +y +y +r +e +p +ppc_km_overlay (max extrapolation) + + diff --git a/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-no-extrapolation.svg b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-no-extrapolation.svg new file mode 100644 index 00000000..5b220bc5 --- /dev/null +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-no-extrapolation.svg @@ -0,0 +1,71 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.5 +1.0 + + + + + + + + + +0 +5 +10 +15 +20 + + +y +y +r +e +p +ppc_km_overlay (no extrapolation) + + diff --git a/tests/testthat/test-ppc-censoring.R b/tests/testthat/test-ppc-censoring.R index b9008750..94009b6d 100644 --- a/tests/testthat/test-ppc-censoring.R +++ b/tests/testthat/test-ppc-censoring.R @@ -91,13 +91,31 @@ test_that("ppc_km_overlay renders correctly", { p_base2 <- ppc_km_overlay(vdiff_y3, vdiff_yrep3, status_y = vdiff_status_y3) vdiffr::expect_doppelganger("ppc_km_overlay (default 2)", p_base2) - p_custom2 <- ppc_km_overlay( + p_custom2_left_truncation <- ppc_km_overlay( vdiff_y3, vdiff_yrep3, status_y = vdiff_status_y3, left_truncation_y = vdiff_left_truncation_y3) vdiffr::expect_doppelganger("ppc_km_overlay (left_truncation_y)", - p_custom2) + p_custom2_left_truncation) + + p_custom2_no_extrapolation <- ppc_km_overlay( + vdiff_y3, + vdiff_yrep3, + status_y = vdiff_status_y3, + extrapolation_factor = 1 + ) + vdiffr::expect_doppelganger("ppc_km_overlay (no extrapolation)", + p_custom2_no_extrapolation) + + p_custom2_max_extrapolation <- ppc_km_overlay( + vdiff_y3, + vdiff_yrep3, + status_y = vdiff_status_y3, + extrapolation_factor = Inf + ) + vdiffr::expect_doppelganger("ppc_km_overlay (max extrapolation)", + p_custom2_max_extrapolation) }) test_that("ppc_km_overlay_grouped renders correctly", { @@ -128,7 +146,7 @@ test_that("ppc_km_overlay_grouped renders correctly", { status_y = vdiff_status_y3) vdiffr::expect_doppelganger("ppc_km_overlay_grouped (default 2)", p_base2) - p_custom2 <- ppc_km_overlay_grouped( + p_custom2_left_truncation <- ppc_km_overlay_grouped( vdiff_y3, vdiff_yrep3, vdiff_group3, @@ -138,6 +156,32 @@ test_that("ppc_km_overlay_grouped renders correctly", { vdiffr::expect_doppelganger( "ppc_km_overlay_grouped (left_truncation_y)", - p_custom2 + p_custom2_left_truncation + ) + + p_custom2_no_extrapolation <- ppc_km_overlay_grouped( + vdiff_y3, + vdiff_yrep3, + vdiff_group3, + status_y = vdiff_status_y3, + extrapolation_factor = 1 + ) + + vdiffr::expect_doppelganger( + "ppc_km_overlay_grouped (no extrapolation)", + p_custom2_no_extrapolation + ) + + p_custom2_max_extrapolation <- ppc_km_overlay_grouped( + vdiff_y3, + vdiff_yrep3, + vdiff_group3, + status_y = vdiff_status_y3, + extrapolation_factor = Inf + ) + + vdiffr::expect_doppelganger( + "ppc_km_overlay_grouped (max extrapolation)", + p_custom2_max_extrapolation ) }) From c0dc282ce387d1c953fc8af78cffe247d470af7c Mon Sep 17 00:00:00 2001 From: Sakuski Date: Mon, 26 May 2025 22:03:10 +0300 Subject: [PATCH 6/9] Update NEWS.md --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index c4baf42a..c572080e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # bayesplot (development version) +* Add extrapolation_factor parameter to `ppc_km_overlay()` and `ppc_km_overlay_grouped()` by @Sakuski * Add possibility for left-truncation to `ppc_km_overlay()` and `ppc_km_overlay_grouped()` by @Sakuski * Added `ppc_loo_pit_ecdf()` by @TeemuSailynoja From 228434cc4b333eeeab8219cb7ee55ff200e78b9e Mon Sep 17 00:00:00 2001 From: jgabry Date: Tue, 27 May 2025 10:05:24 -0600 Subject: [PATCH 7/9] regenerate Rd file --- man/PPC-censoring.Rd | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/man/PPC-censoring.Rd b/man/PPC-censoring.Rd index 736a15a9..d2dca866 100644 --- a/man/PPC-censoring.Rd +++ b/man/PPC-censoring.Rd @@ -13,7 +13,8 @@ ppc_km_overlay( status_y, left_truncation_y = NULL, size = 0.25, - alpha = 0.7 + alpha = 0.7, + extrapolation_factor = 1.2 ) ppc_km_overlay_grouped( @@ -24,7 +25,8 @@ ppc_km_overlay_grouped( status_y, left_truncation_y = NULL, size = 0.25, - alpha = 0.7 + alpha = 0.7, + extrapolation_factor = 1.2 ) } \arguments{ @@ -52,6 +54,13 @@ no left-truncation is assumed.} \item{size, alpha}{Passed to the appropriate geom to control the appearance of the \code{yrep} distributions.} +\item{extrapolation_factor}{A numeric value (>=1) that controls how far the +plot is extended beyond the largest observed value in \code{y}. The default +value is 1.2, which corresponds to 20 \% extrapolation. Note that all +posterior predictive draws may not be shown by default because of +the controlled extrapolation. To display all posterior predictive draws, +set \code{extrapolation_factor = Inf}.} + \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 @@ -102,6 +111,14 @@ dim(yrep) \donttest{ ppc_km_overlay(y, yrep[1:25, ], status_y = status_y) } +# With extrapolation_factor = 1 (no extrapolation) +\donttest{ +ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, extrapolation_factor = 1) +} +# With extrapolation_factor = Inf (show all posterior predictive draws) +\donttest{ +ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, extrapolation_factor = Inf) +} # With separate facets by group: group <- example_group_data() \donttest{ From 4724f3b0294ae43a2b1d79f44eb19623316de67e Mon Sep 17 00:00:00 2001 From: jgabry Date: Tue, 27 May 2025 10:53:11 -0600 Subject: [PATCH 8/9] Add message if user doesn't change extrapolation_factor default --- R/ppc-censoring.R | 51 ++++++++++++++++------------- man/PPC-censoring.Rd | 45 ++++++++++++------------- tests/testthat/test-ppc-censoring.R | 8 +++++ 3 files changed, 60 insertions(+), 44 deletions(-) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index c39c53b3..b957c9a5 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -24,11 +24,12 @@ #' @section Plot Descriptions: #' \describe{ #' \item{`ppc_km_overlay()`}{ -#' Empirical CCDF estimates of each dataset (row) in `yrep` are overlaid, -#' with the Kaplan-Meier estimate (Kaplan and Meier, 1958) for `y` itself on -#' top (and in a darker shade). This is a PPC suitable for right-censored -#' `y`. Note that the replicated data from `yrep` is assumed to be -#' uncensored. +#' Empirical CCDF estimates of each dataset (row) in `yrep` are overlaid, with +#' the Kaplan-Meier estimate (Kaplan and Meier, 1958) for `y` itself on top +#' (and in a darker shade). This is a PPC suitable for right-censored `y`. +#' Note that the replicated data from `yrep` is assumed to be uncensored. Left +#' truncation (delayed entry) times for `y` can be specified using +#' `left_truncation_y`. #' } #' \item{`ppc_km_overlay_grouped()`}{ #' The same as `ppc_km_overlay()`, but with separate facets by `group`. @@ -40,32 +41,33 @@ #' @template reference-km #' #' @examples +#' \donttest{ #' color_scheme_set("brightblue") -#' y <- example_y_data() +#' #' # For illustrative purposes, (right-)censor values y > 110: +#' y <- example_y_data() #' status_y <- as.numeric(y <= 110) #' y <- pmin(y, 110) +#' #' # In reality, the replicated data (yrep) would be obtained from a #' # model which takes the censoring of y properly into account. Here, #' # for illustrative purposes, we simply use example_yrep_draws(): #' yrep <- example_yrep_draws() #' dim(yrep) -#' \donttest{ +#' +#' # Overlay 25 curves #' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y) -#' } +#' #' # With extrapolation_factor = 1 (no extrapolation) -#' \donttest{ #' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, extrapolation_factor = 1) -#' } +#' #' # With extrapolation_factor = Inf (show all posterior predictive draws) -#' \donttest{ #' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, extrapolation_factor = Inf) -#' } +#' #' # With separate facets by group: #' group <- example_group_data() -#' \donttest{ #' ppc_km_overlay_grouped(y, yrep[1:25, ], group = group, status_y = status_y) -#' } +#' #' # With left-truncation (delayed entry) times: #' min_vals <- pmin(y, apply(yrep, 2, min)) #' left_truncation_y <- rep(0, length(y)) @@ -74,7 +76,6 @@ #' runif(sum(condition), min = 0.6, max = 0.99) * y[condition], #' min_vals[condition] - 0.001 #' ) -#' \donttest{ #' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, #' left_truncation_y = left_truncation_y) #' } @@ -102,9 +103,9 @@ ppc_km_overlay <- function( ..., status_y, left_truncation_y = NULL, + extrapolation_factor = 1.2, size = 0.25, - alpha = 0.7, - extrapolation_factor = 1.2 + alpha = 0.7 ) { check_ignored_arguments(..., ok_args = "add_group") add_group <- list(...)$add_group @@ -113,17 +114,23 @@ ppc_km_overlay <- function( suggested_package("ggfortify") if (!is.numeric(status_y) || length(status_y) != length(y) || !all(status_y %in% c(0, 1))) { - stop("`status_y` must be a numeric vector of 0s and 1s the same length as `y`.") + stop("`status_y` must be a numeric vector of 0s and 1s the same length as `y`.", call. = FALSE) } if (!is.null(left_truncation_y)) { if (!is.numeric(left_truncation_y) || length(left_truncation_y) != length(y)) { - stop("`left_truncation_y` must be a numeric vector of the same length as `y`.") + stop("`left_truncation_y` must be a numeric vector of the same length as `y`.", call. = FALSE) } } if (extrapolation_factor < 1) { - stop("`extrapolation_factor` must be greater than or equal to 1.") + stop("`extrapolation_factor` must be greater than or equal to 1.", call. = FALSE) + } + if (extrapolation_factor == 1.2) { + message( + "Note: `extrapolation_factor` now defaults to 1.2 (20%).\n", + "To display all posterior predictive draws, set `extrapolation_factor = Inf`." + ) } data <- ppc_data(y, yrep, group = status_y) @@ -218,9 +225,9 @@ ppc_km_overlay_grouped <- function( ..., status_y, left_truncation_y = NULL, + extrapolation_factor = 1.2, size = 0.25, - alpha = 0.7, - extrapolation_factor = 1.2 + alpha = 0.7 ) { check_ignored_arguments(...) diff --git a/man/PPC-censoring.Rd b/man/PPC-censoring.Rd index d2dca866..04224863 100644 --- a/man/PPC-censoring.Rd +++ b/man/PPC-censoring.Rd @@ -12,9 +12,9 @@ ppc_km_overlay( ..., status_y, left_truncation_y = NULL, + extrapolation_factor = 1.2, size = 0.25, - alpha = 0.7, - extrapolation_factor = 1.2 + alpha = 0.7 ) ppc_km_overlay_grouped( @@ -24,9 +24,9 @@ ppc_km_overlay_grouped( ..., status_y, left_truncation_y = NULL, + extrapolation_factor = 1.2, size = 0.25, - alpha = 0.7, - extrapolation_factor = 1.2 + alpha = 0.7 ) } \arguments{ @@ -51,9 +51,6 @@ right censored, 1 = event).} be a numeric vector of the same length as \code{y}. If \code{NULL} (default), no left-truncation is assumed.} -\item{size, alpha}{Passed to the appropriate geom to control the appearance of -the \code{yrep} distributions.} - \item{extrapolation_factor}{A numeric value (>=1) that controls how far the plot is extended beyond the largest observed value in \code{y}. The default value is 1.2, which corresponds to 20 \% extrapolation. Note that all @@ -61,6 +58,9 @@ posterior predictive draws may not be shown by default because of the controlled extrapolation. To display all posterior predictive draws, set \code{extrapolation_factor = Inf}.} +\item{size, alpha}{Passed to the appropriate geom to control the appearance of +the \code{yrep} distributions.} + \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 @@ -85,11 +85,12 @@ additional plots at \describe{ \item{\code{ppc_km_overlay()}}{ -Empirical CCDF estimates of each dataset (row) in \code{yrep} are overlaid, -with the Kaplan-Meier estimate (Kaplan and Meier, 1958) for \code{y} itself on -top (and in a darker shade). This is a PPC suitable for right-censored -\code{y}. Note that the replicated data from \code{yrep} is assumed to be -uncensored. +Empirical CCDF estimates of each dataset (row) in \code{yrep} are overlaid, with +the Kaplan-Meier estimate (Kaplan and Meier, 1958) for \code{y} itself on top +(and in a darker shade). This is a PPC suitable for right-censored \code{y}. +Note that the replicated data from \code{yrep} is assumed to be uncensored. Left +truncation (delayed entry) times for \code{y} can be specified using +\code{left_truncation_y}. } \item{\code{ppc_km_overlay_grouped()}}{ The same as \code{ppc_km_overlay()}, but with separate facets by \code{group}. @@ -98,32 +99,33 @@ The same as \code{ppc_km_overlay()}, but with separate facets by \code{group}. } \examples{ +\donttest{ color_scheme_set("brightblue") -y <- example_y_data() + # For illustrative purposes, (right-)censor values y > 110: +y <- example_y_data() status_y <- as.numeric(y <= 110) y <- pmin(y, 110) + # In reality, the replicated data (yrep) would be obtained from a # model which takes the censoring of y properly into account. Here, # for illustrative purposes, we simply use example_yrep_draws(): yrep <- example_yrep_draws() dim(yrep) -\donttest{ + +# Overlay 25 curves ppc_km_overlay(y, yrep[1:25, ], status_y = status_y) -} + # With extrapolation_factor = 1 (no extrapolation) -\donttest{ ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, extrapolation_factor = 1) -} + # With extrapolation_factor = Inf (show all posterior predictive draws) -\donttest{ ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, extrapolation_factor = Inf) -} + # With separate facets by group: group <- example_group_data() -\donttest{ ppc_km_overlay_grouped(y, yrep[1:25, ], group = group, status_y = status_y) -} + # With left-truncation (delayed entry) times: min_vals <- pmin(y, apply(yrep, 2, min)) left_truncation_y <- rep(0, length(y)) @@ -132,7 +134,6 @@ left_truncation_y[condition] <- pmin( runif(sum(condition), min = 0.6, max = 0.99) * y[condition], min_vals[condition] - 0.001 ) -\donttest{ ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, left_truncation_y = left_truncation_y) } diff --git a/tests/testthat/test-ppc-censoring.R b/tests/testthat/test-ppc-censoring.R index 94009b6d..d733c0ee 100644 --- a/tests/testthat/test-ppc-censoring.R +++ b/tests/testthat/test-ppc-censoring.R @@ -69,6 +69,14 @@ test_that("ppc_km_overlay errors if bad extrapolation_factor value", { ) }) +test_that("ppc_km_overlay messages if extrapolation_factor left at default value", { + skip_if_not_installed("ggfortify") + expect_message( + ppc_km_overlay(y, yrep, status_y = status_y), + "To display all posterior predictive draws, set `extrapolation_factor = Inf`.", + ) +}) + # Visual tests ----------------------------------------------------------------- test_that("ppc_km_overlay renders correctly", { From a5d48291f54b9c572343815d1a124212de40333a Mon Sep 17 00:00:00 2001 From: jgabry Date: Tue, 27 May 2025 10:54:27 -0600 Subject: [PATCH 9/9] Update ppc-censoring.R --- R/ppc-censoring.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index b957c9a5..d11312ee 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -87,15 +87,15 @@ NULL #' be a numeric vector of the same length as `y` with values in \{0, 1\} (0 = #' right censored, 1 = event). #' @param left_truncation_y Optional parameter that specifies left-truncation -#' (delayed entry) times for the observations from `y`. This must -#' be a numeric vector of the same length as `y`. If `NULL` (default), -#' no left-truncation is assumed. +#' (delayed entry) times for the observations from `y`. This must be a numeric +#' vector of the same length as `y`. If `NULL` (default), no left-truncation +#' is assumed. #' @param extrapolation_factor A numeric value (>=1) that controls how far the #' plot is extended beyond the largest observed value in `y`. The default #' value is 1.2, which corresponds to 20 % extrapolation. Note that all -#' posterior predictive draws may not be shown by default because of -#' the controlled extrapolation. To display all posterior predictive draws, -#' set `extrapolation_factor = Inf`. +#' posterior predictive draws may not be shown by default because of the +#' controlled extrapolation. To display all posterior predictive draws, set +#' `extrapolation_factor = Inf`. #' ppc_km_overlay <- function( y,