From 6194c04f9f0d501e2d62d1d18effb5e1fd769812 Mon Sep 17 00:00:00 2001 From: Sakuski Date: Tue, 29 Apr 2025 18:51:01 +0300 Subject: [PATCH 01/13] Add left_truncation_y parameter to ppc_km_overlay() and ppc_km_overlay_grouped() --- R/ppc-censoring.R | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index 2677cb58..92d1ec78 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -70,6 +70,7 @@ ppc_km_overlay <- function( yrep, ..., status_y, + left_truncation_y = NULL, size = 0.25, alpha = 0.7 ) { @@ -82,8 +83,20 @@ ppc_km_overlay <- function( stopifnot(is.numeric(status_y)) stopifnot(all(status_y %in% c(0, 1))) + 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`.") + } + } + data <- ppc_data(y, yrep, group = status_y) + if (!is.null(left_truncation_y)) { + data$left_trunc <- left_truncation_y[data$y_id] + } else { + data$left_trunc <- 0 + } + # Modify the status indicator: # * For the observed data ("y"), convert the status indicator back to # a numeric. @@ -96,7 +109,7 @@ ppc_km_overlay <- function( as.numeric(as.character(.data$group)), 1)) - sf_form <- survival::Surv(value, group) ~ rep_label + sf_form <- survival::Surv(time = data$left_trunc, time2 = data$value, event = data$group) ~ rep_label if (!is.null(add_group)) { data <- dplyr::inner_join(data, tibble::tibble(y_id = seq_along(y), @@ -164,6 +177,7 @@ ppc_km_overlay_grouped <- function( group, ..., status_y, + left_truncation_y = NULL, size = 0.25, alpha = 0.7 ) { @@ -175,6 +189,7 @@ ppc_km_overlay_grouped <- function( add_group = group, ..., status_y = status_y, + left_truncation_y = left_truncation_y, size = size, alpha = alpha ) From d6e2135f417e6d4c3d1f48a447cdaaf3128a0328 Mon Sep 17 00:00:00 2001 From: Sakuski Date: Tue, 29 Apr 2025 19:16:08 +0300 Subject: [PATCH 02/13] Update NEWS.md --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 83d34833..c4baf42a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # bayesplot (development version) +* Add possibility for left-truncation to `ppc_km_overlay()` and `ppc_km_overlay_grouped()` by @Sakuski * Added `ppc_loo_pit_ecdf()` by @TeemuSailynoja # bayesplot 1.12.0 From d4274f2562a2e340191af3ff01133a55d73f72a5 Mon Sep 17 00:00:00 2001 From: Sakuski Date: Wed, 30 Apr 2025 18:23:17 +0300 Subject: [PATCH 03/13] Fix wrong assumption that time > 0 in ppc_km_overlay() --- R/ppc-censoring.R | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index 92d1ec78..7359c6b5 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -91,12 +91,6 @@ ppc_km_overlay <- function( data <- ppc_data(y, yrep, group = status_y) - if (!is.null(left_truncation_y)) { - data$left_trunc <- left_truncation_y[data$y_id] - } else { - data$left_trunc <- 0 - } - # Modify the status indicator: # * For the observed data ("y"), convert the status indicator back to # a numeric. @@ -109,7 +103,12 @@ ppc_km_overlay <- function( as.numeric(as.character(.data$group)), 1)) - sf_form <- survival::Surv(time = data$left_trunc, time2 = data$value, event = data$group) ~ rep_label + if (is.null(left_truncation_y)) { + sf_form <- survival::Surv(time = data$value, event = data$group) ~ rep_label + } else { + sf_form <- survival::Surv(time = left_truncation_y[data$y_id], time2 = data$value, event = data$group) ~ rep_label + } + if (!is.null(add_group)) { data <- dplyr::inner_join(data, tibble::tibble(y_id = seq_along(y), From f59e38e3ffe3c36faf2b79827e95e503521dc8b5 Mon Sep 17 00:00:00 2001 From: Sakuski Date: Wed, 30 Apr 2025 19:52:54 +0300 Subject: [PATCH 04/13] Add documentation and example for left_truncation_y --- R/ppc-censoring.R | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index 7359c6b5..5d96c22e 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -58,6 +58,12 @@ #' \donttest{ #' ppc_km_overlay_grouped(y, yrep[1:25, ], group = group, status_y = status_y) #' } +#' # With left-truncation (delayed entry) times: +#' left_truncation_y <- runif(length(y), min = 0, max = 0.6) * y +#' \donttest{ +#' ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, +#' left_truncation_y = left_truncation_y) +#' } NULL #' @export @@ -65,6 +71,10 @@ NULL #' @param status_y The status indicator for the observations from `y`. This must #' 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. ppc_km_overlay <- function( y, yrep, From c16fce37100769f2bc91d19f8af0ba2689c3b06b Mon Sep 17 00:00:00 2001 From: Sakuski Date: Tue, 6 May 2025 15:50:26 +0300 Subject: [PATCH 05/13] Add tests for ppc_km_overlay() with left-truncation --- .../ppc-km-overlay-default-2.svg | 69 ++++++++++ .../ppc-km-overlay-grouped-default-2.svg | 125 ++++++++++++++++++ ...c-km-overlay-grouped-left-truncation-y.svg | 125 ++++++++++++++++++ .../ppc-km-overlay-left-truncation-y.svg | 69 ++++++++++ tests/testthat/data-for-ppc-tests.R | 17 +++ tests/testthat/test-ppc-censoring.R | 42 +++++- 6 files changed, 443 insertions(+), 4 deletions(-) create mode 100644 tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-default-2.svg create mode 100644 tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-default-2.svg create mode 100644 tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-left-truncation-y.svg create mode 100644 tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-left-truncation-y.svg 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 new file mode 100644 index 00000000..249eb546 --- /dev/null +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-default-2.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.5 +1.0 + + + + + + + + +0 +10 +20 +30 + + +y +y +r +e +p +ppc_km_overlay (default 2) + + 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 new file mode 100644 index 00000000..6e4111b4 --- /dev/null +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-default-2.svg @@ -0,0 +1,125 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 + + + + + + + + + +2 + + + + + + + +0 +10 +20 +30 + + + + + +0 +10 +20 +30 + +0.0 +0.5 +1.0 + + + + + +y +y +r +e +p +ppc_km_overlay_grouped (default 2) + + 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 new file mode 100644 index 00000000..7ef4b240 --- /dev/null +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-grouped-left-truncation-y.svg @@ -0,0 +1,125 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 + + + + + + + + + +2 + + + + + + + +0 +10 +20 +30 + + + + + +0 +10 +20 +30 + +0.0 +0.5 +1.0 + + + + + +y +y +r +e +p +ppc_km_overlay_grouped (left_truncation_y) + + 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 new file mode 100644 index 00000000..6dca103c --- /dev/null +++ b/tests/testthat/_snaps/ppc-censoring/ppc-km-overlay-left-truncation-y.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +0.5 +1.0 + + + + + + + + +0 +10 +20 +30 + + +y +y +r +e +p +ppc_km_overlay (left_truncation_y) + + diff --git a/tests/testthat/data-for-ppc-tests.R b/tests/testthat/data-for-ppc-tests.R index 46c9bdec..d55d5f0f 100644 --- a/tests/testthat/data-for-ppc-tests.R +++ b/tests/testthat/data-for-ppc-tests.R @@ -3,6 +3,7 @@ y <- rnorm(100) yrep <- matrix(rnorm(2500), ncol = 100) group <- gl(4, 25, labels = LETTERS[1:4]) status_y <- rep_len(0:1, length.out = length(y)) +left_truncation_y <- y - 10 y2 <- rpois(30, 1) yrep2 <- matrix(rpois(30, 1), ncol = 30) @@ -22,6 +23,22 @@ vdiff_yrep2 <- matrix(rpois(30 * 10, 1), ncol = 30, nrow = 10) vdiff_group2 <- rep_len(c(1,2), length.out = 30) vdiff_status_y2 <- rep_len(0:1, length.out = length(vdiff_y2)) +vdiff_y3 <- rexp(50, rate = 0.2) +vdiff_status_y3 <- rep_len(0:1, length.out = length(vdiff_y3)) +vdiff_group3 <- rep_len(c(1,2), length.out = 50) +vdiff_left_truncation_y3 <- runif(length(vdiff_y3), min = 0, max = 0.6) * vdiff_y3 + +simulate_truncated_exp <- function(n, rate, trunc_point) { + u <- runif(n) + return(trunc_point - log(u) / rate) +} + +rate <- 0.2 +vdiff_yrep3 <- matrix(NA, nrow = 10, ncol = 50) +for (i in 1:50) { + vdiff_yrep3[, i] <- simulate_truncated_exp(10, rate, vdiff_left_truncation_y3[i]) +} + vdiff_loo_y <- rnorm(100, 30, 5) vdiff_loo_yrep <- matrix(rnorm(100 * 400, 30, 5), nrow = 400) vdiff_loo_lw <- vdiff_loo_yrep diff --git a/tests/testthat/test-ppc-censoring.R b/tests/testthat/test-ppc-censoring.R index f78639cb..b351d13d 100644 --- a/tests/testthat/test-ppc-censoring.R +++ b/tests/testthat/test-ppc-censoring.R @@ -5,18 +5,24 @@ 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(y, yrep, status_y = status_y, left_truncation_y = left_truncation_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)) + status_y = status_y, + left_truncation_y = left_truncation_y, + size = 0.5, alpha = 0.2)) expect_gg(ppc_km_overlay_grouped(y, yrep, as.numeric(group), - status_y = status_y)) + status_y = status_y, + left_truncation_y = left_truncation_y, + size = 0.5, alpha = 0.2)) expect_gg(ppc_km_overlay_grouped(y, yrep, as.integer(group), - status_y = status_y)) + status_y = status_y, + left_truncation_y = left_truncation_y, + size = 0.5, alpha = 0.2)) expect_gg(ppc_km_overlay_grouped(y2, yrep2, group2, status_y = status_y2)) @@ -44,6 +50,17 @@ test_that("ppc_km_overlay renders correctly", { size = 2, alpha = .2) vdiffr::expect_doppelganger("ppc_km_overlay (size, alpha)", p_custom) + + 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( + 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) }) test_that("ppc_km_overlay_grouped renders correctly", { @@ -69,4 +86,21 @@ test_that("ppc_km_overlay_grouped renders correctly", { "ppc_km_overlay_grouped (size, alpha)", p_custom ) + + p_base2 <- ppc_km_overlay_grouped(vdiff_y3, vdiff_yrep3, vdiff_group3, + status_y = vdiff_status_y3) + vdiffr::expect_doppelganger("ppc_km_overlay_grouped (default 2)", p_base2) + + p_custom2 <- ppc_km_overlay_grouped( + vdiff_y3, + vdiff_yrep3, + vdiff_group3, + status_y = vdiff_status_y3, + left_truncation_y = vdiff_left_truncation_y3 + ) + + vdiffr::expect_doppelganger( + "ppc_km_overlay_grouped (left_truncation_y)", + p_custom2 + ) }) From f4b5e0ec45ad98da40787ade62b2971dbac5b986 Mon Sep 17 00:00:00 2001 From: jgabry Date: Thu, 8 May 2025 09:47:09 -0600 Subject: [PATCH 06/13] Generate Rd file from new documentation --- man/PPC-censoring.Rd | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/man/PPC-censoring.Rd b/man/PPC-censoring.Rd index 8e449ed9..d31bba75 100644 --- a/man/PPC-censoring.Rd +++ b/man/PPC-censoring.Rd @@ -6,9 +6,26 @@ \alias{ppc_km_overlay_grouped} \title{PPC censoring} \usage{ -ppc_km_overlay(y, yrep, ..., status_y, size = 0.25, alpha = 0.7) +ppc_km_overlay( + y, + yrep, + ..., + status_y, + left_truncation_y = NULL, + size = 0.25, + alpha = 0.7 +) -ppc_km_overlay_grouped(y, yrep, group, ..., status_y, size = 0.25, alpha = 0.7) +ppc_km_overlay_grouped( + y, + yrep, + group, + ..., + status_y, + left_truncation_y = NULL, + size = 0.25, + alpha = 0.7 +) } \arguments{ \item{y}{A vector of observations. See \strong{Details}.} @@ -27,6 +44,11 @@ additional advice specific to particular plots.} be a numeric vector of the same length as \code{y} with values in \{0, 1\} (0 = right censored, 1 = event).} +\item{left_truncation_y}{Optional parameter that specifies left-truncation +(delayed entry) times for the observations from \code{y}. This must +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.} @@ -85,6 +107,12 @@ 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: +left_truncation_y <- runif(length(y), min = 0, max = 0.6) * y +\donttest{ +ppc_km_overlay(y, yrep[1:25, ], status_y = status_y, + left_truncation_y = left_truncation_y) +} } \references{ Gelman, A., Carlin, J. B., Stern, H. S., Dunson, D. B., Vehtari, From fced0094005d235d77e76956a762f91eebb367f6 Mon Sep 17 00:00:00 2001 From: jgabry Date: Thu, 8 May 2025 10:08:06 -0600 Subject: [PATCH 07/13] Reorder random number generation for testing data --- tests/testthat/data-for-ppc-tests.R | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/tests/testthat/data-for-ppc-tests.R b/tests/testthat/data-for-ppc-tests.R index d55d5f0f..8e2dfd4e 100644 --- a/tests/testthat/data-for-ppc-tests.R +++ b/tests/testthat/data-for-ppc-tests.R @@ -23,6 +23,12 @@ vdiff_yrep2 <- matrix(rpois(30 * 10, 1), ncol = 30, nrow = 10) vdiff_group2 <- rep_len(c(1,2), length.out = 30) vdiff_status_y2 <- rep_len(0:1, length.out = length(vdiff_y2)) +vdiff_loo_y <- rnorm(100, 30, 5) +vdiff_loo_yrep <- matrix(rnorm(100 * 400, 30, 5), nrow = 400) +vdiff_loo_lw <- vdiff_loo_yrep +vdiff_loo_lw[] <- rnorm(100 * 400, -8, 2) + + vdiff_y3 <- rexp(50, rate = 0.2) vdiff_status_y3 <- rep_len(0:1, length.out = length(vdiff_y3)) vdiff_group3 <- rep_len(c(1,2), length.out = 50) @@ -39,8 +45,4 @@ for (i in 1:50) { vdiff_yrep3[, i] <- simulate_truncated_exp(10, rate, vdiff_left_truncation_y3[i]) } -vdiff_loo_y <- rnorm(100, 30, 5) -vdiff_loo_yrep <- matrix(rnorm(100 * 400, 30, 5), nrow = 400) -vdiff_loo_lw <- vdiff_loo_yrep -vdiff_loo_lw[] <- rnorm(100 * 400, -8, 2) set.seed(seed = NULL) From c7d848576608fd9b1cd398ada17561edcefbd875 Mon Sep 17 00:00:00 2001 From: jgabry Date: Thu, 8 May 2025 10:26:04 -0600 Subject: [PATCH 08/13] upload new snapshots --- .../ppc-km-overlay-default-2.svg | 40 +++++----- .../ppc-km-overlay-grouped-default-2.svg | 80 ++++++++++--------- ...c-km-overlay-grouped-left-truncation-y.svg | 80 ++++++++++--------- .../ppc-km-overlay-left-truncation-y.svg | 40 +++++----- 4 files changed, 126 insertions(+), 114 deletions(-) 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 249eb546..792f234d 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,14 +49,16 @@ - - - - -0 -10 -20 -30 + + + + + +0 +10 +20 +30 +40 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 6e4111b4..a24e432f 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,23 +89,27 @@ - - - - -0 -10 -20 -30 + + + + + +0 +10 +20 +30 +40 - - - - -0 -10 -20 -30 + + + + + +0 +10 +20 +30 +40 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 7ef4b240..8b812eda 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,23 +89,27 @@ - - - - -0 -10 -20 -30 + + + + + +0 +10 +20 +30 +40 - - - - -0 -10 -20 -30 + + + + + +0 +10 +20 +30 +40 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 6dca103c..9496f17d 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,14 +49,16 @@ - - - - -0 -10 -20 -30 + + + + + +0 +10 +20 +30 +40 y From 8d59871d078d267329b493eb5c8718c17fe60468 Mon Sep 17 00:00:00 2001 From: jgabry Date: Thu, 8 May 2025 10:45:54 -0600 Subject: [PATCH 09/13] add test for error message --- tests/testthat/test-ppc-censoring.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/testthat/test-ppc-censoring.R b/tests/testthat/test-ppc-censoring.R index b351d13d..144d938e 100644 --- a/tests/testthat/test-ppc-censoring.R +++ b/tests/testthat/test-ppc-censoring.R @@ -32,6 +32,18 @@ test_that("ppc_km_overlay_grouped returns a ggplot object", { status_y = status_y2)) }) +test_that("ppc_km_overlay errors if bad left_truncation_y value", { + skip_if_not_installed("ggfortify") + expect_error( + ppc_km_overlay(y, yrep, status_y = status_y, left_truncation_y = "a"), + "`left_truncation_y` must be a numeric vector of the same length as `y`" + ) + expect_error( + ppc_km_overlay(y, yrep, status_y = status_y, left_truncation_y = 1:10), + "`left_truncation_y` must be a numeric vector of the same length as `y`" + ) +}) + # Visual tests ----------------------------------------------------------------- test_that("ppc_km_overlay renders correctly", { From 17370069c3b7342761889f55bbadd14026da0f31 Mon Sep 17 00:00:00 2001 From: jgabry Date: Thu, 8 May 2025 10:52:24 -0600 Subject: [PATCH 10/13] also test status_y error messages --- R/ppc-censoring.R | 5 +++-- tests/testthat/test-ppc-censoring.R | 16 ++++++++++++++++ 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index 5d96c22e..3b22a80d 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -90,8 +90,9 @@ ppc_km_overlay <- function( suggested_package("survival") suggested_package("ggfortify") - stopifnot(is.numeric(status_y)) - stopifnot(all(status_y %in% c(0, 1))) + 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`.") + } if (!is.null(left_truncation_y)) { if (!is.numeric(left_truncation_y) || length(left_truncation_y) != length(y)) { diff --git a/tests/testthat/test-ppc-censoring.R b/tests/testthat/test-ppc-censoring.R index 144d938e..611d2c3f 100644 --- a/tests/testthat/test-ppc-censoring.R +++ b/tests/testthat/test-ppc-censoring.R @@ -32,6 +32,22 @@ test_that("ppc_km_overlay_grouped returns a ggplot object", { status_y = status_y2)) }) +test_that("ppc_km_overlay errors if bad status_y value", { + skip_if_not_installed("ggfortify") + expect_error( + ppc_km_overlay(y, yrep, status_y = FALSE), + "`status_y` must be a numeric vector of 0s and 1s the same length as `y`." + ) + expect_error( + ppc_km_overlay(y, yrep, status_y = 1:10), + "`status_y` must be a numeric vector of 0s and 1s the same length as `y`." + ) + expect_error( + ppc_km_overlay(y, yrep, status_y = rep(10, length(y))), + "`status_y` must be a numeric vector of 0s and 1s the same length as `y`." + ) +}) + test_that("ppc_km_overlay errors if bad left_truncation_y value", { skip_if_not_installed("ggfortify") expect_error( From 45a6d88861e7a474c340db16f3f835ec55799b41 Mon Sep 17 00:00:00 2001 From: Sakuski Date: Thu, 8 May 2025 20:57:33 +0300 Subject: [PATCH 11/13] Make left-truncation example cleaner --- R/ppc-censoring.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index 3b22a80d..cd3ae31b 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -59,7 +59,11 @@ #' ppc_km_overlay_grouped(y, yrep[1:25, ], group = group, status_y = status_y) #' } #' # With left-truncation (delayed entry) times: -#' left_truncation_y <- runif(length(y), min = 0, max = 0.6) * y +#' condition <- y > mean(y) / 2 +#' 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) From 294637a0d79d2022f8a10c6a4c392bd657308671 Mon Sep 17 00:00:00 2001 From: Sakuski Date: Fri, 9 May 2025 20:40:20 +0300 Subject: [PATCH 12/13] Add two missing lines to ppc_km_overlay example --- R/ppc-censoring.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/ppc-censoring.R b/R/ppc-censoring.R index cd3ae31b..7f39a78b 100644 --- a/R/ppc-censoring.R +++ b/R/ppc-censoring.R @@ -59,6 +59,8 @@ #' 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)) #' condition <- y > mean(y) / 2 #' left_truncation_y[condition] <- pmin( #' runif(sum(condition), min = 0.6, max = 0.99) * y[condition], From 004484583cf5716db8802d3d4576b501309ce079 Mon Sep 17 00:00:00 2001 From: jgabry Date: Fri, 9 May 2025 11:48:28 -0600 Subject: [PATCH 13/13] regenerate Rd file --- man/PPC-censoring.Rd | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/man/PPC-censoring.Rd b/man/PPC-censoring.Rd index d31bba75..736a15a9 100644 --- a/man/PPC-censoring.Rd +++ b/man/PPC-censoring.Rd @@ -108,7 +108,13 @@ group <- example_group_data() ppc_km_overlay_grouped(y, yrep[1:25, ], group = group, status_y = status_y) } # With left-truncation (delayed entry) times: -left_truncation_y <- runif(length(y), min = 0, max = 0.6) * y +min_vals <- pmin(y, apply(yrep, 2, min)) +left_truncation_y <- rep(0, length(y)) +condition <- y > mean(y) / 2 +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)