From 28057a41cb1e589e75703127e0043ee8fea56483 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Sat, 5 Sep 2026 18:10:00 -0400 Subject: [PATCH 01/16] Switch to join-based PRISM category lookup --- NAMESPACE | 1 + R/categorize_prism.R | 112 ++++++++++++------ R/utils.R | 58 +++++++++ ...ot-raise_prism_cutpoint_retrieval_error.Rd | 13 ++ man/filter_largest_lte.Rd | 50 ++++++++ man/prism_thresholds.Rd | 2 +- man/quantiles_to_category_cdf.Rd | 4 +- tests/testthat/test_categorize_prism.R | 31 +++-- tests/testthat/test_utils.R | 98 +++++++++++++++ 9 files changed, 315 insertions(+), 54 deletions(-) create mode 100644 man/dot-raise_prism_cutpoint_retrieval_error.Rd create mode 100644 man/filter_largest_lte.Rd diff --git a/NAMESPACE b/NAMESPACE index ce88c6f..2ca3beb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -32,6 +32,7 @@ export(epiyear_first_date) export(epiyear_n_days) export(epiyear_n_weeks) export(expected_prism_locations) +export(filter_largest_lte) export(filter_to_shared_forecasts) export(filter_to_subset_forecasts) export(floor_epiweek) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index 3d11955..b849378 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -14,34 +14,6 @@ prism_bin_names_from_cutpoints <- function(cutpoints) { ) } -get_single_prism_cutpoint <- function(signal, disease, location, as_of) { - checkmate::assert_string(signal) - checkmate::assert_string(disease) - checkmate::assert_string(location) - checkmate::assert_date(as_of, len = 1, any.missing = FALSE) - - candidates <- forecasttools::prism_thresholds |> - dplyr::filter( - .data$signal == !!signal, - .data$disease == !!disease, - .data$location == !!location, - .data$as_of <= !!as_of - ) - - if (nrow(candidates) == 0) { - cli::cli_abort( - "No PRISM cutpoints for signal {.val {signal}}, disease - {.val {disease}}, and location {.val {location}} as of {as_of}." - ) - } - - matches <- candidates |> - dplyr::filter(.data$as_of == max(.data$as_of)) - - checkmate::assert_data_frame(matches, nrows = 1) - - return(matches$values[[1]]) -} #' Get PRISM activity level cutpoints given #' disease and location. @@ -99,18 +71,82 @@ get_prism_cutpoints <- function( signal <- default_prism_signal } - target_signal <- stringr::str_to_lower(signal) - target_location <- stringr::str_to_upper(location) - target_disease <- stringr::str_to_lower(disease) + desired_cutpoints <- tibble::tibble( + signal = stringr::str_to_lower(signal), + location = stringr::str_to_upper(location), + disease = stringr::str_to_lower(disease), + target_as_of = lubridate::as_date(as_of) + ) - as_of <- lubridate::as_date(as_of) + candidates <- dplyr::inner_join( + desired_cutpoints, + forecasttools::prism_thresholds, + by = c("signal", "location", "disease") + ) |> + dplyr::group_by( + .data$signal, + .data$location, + .data$disease, + .data$target_as_of + ) - return(purrr::pmap( - list(target_disease, target_location, target_signal), - \(disease, location, signal) { - get_single_prism_cutpoint(signal, disease, location, as_of) - } - )) + matches <- candidates |> + filter_largest_lte(.data$as_of, dplyr::cur_group()$target_as_of) + + if (nrow(matches) != nrow(desired_cutpoints)) { + .raise_prism_cutpoint_retrieval_error( + matches, + candidates, + desired_cutpoints + ) + } + return(matches$values) +} + +#' Helper function for raising informative errors +#' when [get_prism_cutpoints()] fails. +.raise_prism_cutpoint_retrieval_error <- function( + matches, + candidates, + desired_cutpoints +) { + if (nrow(matches) > nrow(desired_cutpoints)) { + cli::cli_abort(paste0( + "Found more rows of matched cutpoints ", + "than requested sets of cutpoints. This ", + "should not occur, and suggests a duplicated ", + "data vintage in ", + "{.var forecasttools::prism_thresholds}" + )) + } + no_cutpoints <- desired_cutpoints |> + dplyr::anti_join(candidates, by = c("signal", "location", "disease")) |> + dplyr::select(-"target_as_of") + ## cli::cli_abort doesn't yet print tibbles nicely + ## https://github.com/r-lib/cli/issues/699 + if (nrow(no_cutpoints) > 0) { + rlang::abort( + message = "At least one requested set of cutpoints not found in dataset for any as-of date", + body = c("Cutpoints not found:", capture.output(no_cutpoints)) + ) + } + + no_vintage <- candidates |> + dplyr::ungroup() |> + dplyr::anti_join( + matches, + by = c("signal", "location", "disease", "target_as_of") + ) |> + dplyr::distinct( + .data$signal, + .data$location, + .data$disease, + .data$target_as_of + ) + rlang::abort( + message = "At least one requested set of cutpoints does not have a vintage matching the target as-of date.", + body = c("Cutpoints missing a vintage:", capture.output(no_vintage)) + ) } #' Categorize a numeric vector into PRISM diff --git a/R/utils.R b/R/utils.R index 6771290..caee716 100644 --- a/R/utils.R +++ b/R/utils.R @@ -326,3 +326,61 @@ sym_limits <- function(values, transform = "identity", center = NULL) { return(transform_fn$inverse(transformed_center + c(-span, span))) } + + +#' Filter a data frame by a column to rows with +#' the largest value of that column that is +#' less than or equal to specified maximum value. +#' +#' Useful for getting the last date prior to or on +#' a given target date (e.g. matching data vintages). +#' +#' Uses [dplyr::filter()] syntax, and accepts data-masked +#' expressions for `column` and `max_value`. +#' +#' Returns a 0-row tibble if no rows match the criteria. +#' +#' @param df data frame to filter +#' @param column column to filter on. +#' @param max_value Maximum value. Filter to the +#' largest value in `column` less than or equal to `max_value`. +#' @param .by Optional grouping columns in `df` for the +#' filter. Passed as the `.by` argument to [dplyr::filter()]. +#' Default `NULL`, matching the [dplyr::filter()] default. +#' @param .preserve Preserve all groups present in grouped input? +#' Passed as the `.preverse` argument to [dplyr::filter()]. +#' Default `FALSE`, matching the [dplyr::filter()] default. +#' @return The filtered data frame. +#' +#' @examples +#' some_dates <- tibble::tibble( +#' row_no = 1:3, +#' date = as.Date(c("2026-01-01", "2026-07-02", "2026-07-03")) +#' ) +#' +#' some_dates |> filter_largest_lte(date, as.Date("2026-07-02")) +#' some_dates |> filter_largest_lte(date, as.Date("2026-07-03")) +#' some_dates |> filter_largest_lte(date, as.Date("2026-07-01")) +#' +#' @export +filter_largest_lte <- function( + df, + column, + target, + .by = NULL, + .preserve = FALSE +) { + # avoid warning when filtering groups of size 0 + max_or_na <- function(x) if (length(x) == 0) NA else max(x) + dplyr::filter( + df, + {{ column }} <= {{ target }}, + .by = {{ .by }}, + .preserve = .preserve + ) |> + dplyr::filter( + {{ column }} == max_or_na({{ column }}), + .by = {{ .by }}, + .preserve = .preserve + ) +} diff --git a/man/dot-raise_prism_cutpoint_retrieval_error.Rd b/man/dot-raise_prism_cutpoint_retrieval_error.Rd new file mode 100644 index 0000000..082e42d --- /dev/null +++ b/man/dot-raise_prism_cutpoint_retrieval_error.Rd @@ -0,0 +1,13 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/categorize_prism.R +\name{.raise_prism_cutpoint_retrieval_error} +\alias{.raise_prism_cutpoint_retrieval_error} +\title{Helper function for raising informative errors +when \code{\link[=get_prism_cutpoints]{get_prism_cutpoints()}} fails.} +\usage{ +.raise_prism_cutpoint_retrieval_error(matches, candidates, desired_cutpoints) +} +\description{ +Helper function for raising informative errors +when \code{\link[=get_prism_cutpoints]{get_prism_cutpoints()}} fails. +} diff --git a/man/filter_largest_lte.Rd b/man/filter_largest_lte.Rd new file mode 100644 index 0000000..1ebf77b --- /dev/null +++ b/man/filter_largest_lte.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{filter_largest_lte} +\alias{filter_largest_lte} +\title{Filter a data frame by a column to rows with +the largest value of that column that is +less than or equal to specified maximum value.} +\usage{ +filter_largest_lte(df, column, target, .by = NULL, .preserve = FALSE) +} +\arguments{ +\item{df}{data frame to filter} + +\item{column}{column to filter on.} + +\item{.by}{Optional grouping columns in \code{df} for the +filter. Passed as the \code{.by} argument to \code{\link[dplyr:filter]{dplyr::filter()}}. +Default \code{NULL}, matching the \code{\link[dplyr:filter]{dplyr::filter()}} default.} + +\item{.preserve}{Preserve all groups present in grouped input? +Passed as the \code{.preverse} argument to \code{\link[dplyr:filter]{dplyr::filter()}}. +Default \code{FALSE}, matching the \code{\link[dplyr:filter]{dplyr::filter()}} default.} + +\item{max_value}{Maximum value. Filter to the +largest value in \code{column} less than or equal to \code{max_value}.} +} +\value{ +The filtered data frame. +} +\description{ +Useful for getting the last date prior to or on +a given target date (e.g. matching data vintages). +} +\details{ +Uses \code{\link[dplyr:filter]{dplyr::filter()}} syntax, and accepts data-masked +expressions for \code{column} and \code{max_value}. + +Returns a 0-row tibble if no rows match the criteria. +} +\examples{ +some_dates <- tibble::tibble( + row_no = 1:3, + date = as.Date(c("2026-01-01", "2026-07-02", "2026-07-03")) +) + +some_dates |> filter_largest_lte(date, as.Date("2026-07-02")) +some_dates |> filter_largest_lte(date, as.Date("2026-07-03")) +some_dates |> filter_largest_lte(date, as.Date("2026-07-01")) + +} diff --git a/man/prism_thresholds.Rd b/man/prism_thresholds.Rd index 2396e8d..49e4ce6 100644 --- a/man/prism_thresholds.Rd +++ b/man/prism_thresholds.Rd @@ -5,7 +5,7 @@ \alias{prism_thresholds} \title{PRISM respiratory virus activity level thresholds.} \format{ -An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 589 rows and 5 columns. +An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 797 rows and 5 columns. } \source{ diff --git a/man/quantiles_to_category_cdf.Rd b/man/quantiles_to_category_cdf.Rd index 1d6522e..f24596c 100644 --- a/man/quantiles_to_category_cdf.Rd +++ b/man/quantiles_to_category_cdf.Rd @@ -95,13 +95,13 @@ values <- c(0.05, 0.2, 0.3) quantiles_to_category_cdf( quantile_levels, values, - cutpoints, + cutpoints ) quantiles_to_category_pmf( quantile_levels, values, - cutpoints, + cutpoints ) } diff --git a/tests/testthat/test_categorize_prism.R b/tests/testthat/test_categorize_prism.R index 1ef5cfb..304c8e0 100644 --- a/tests/testthat/test_categorize_prism.R +++ b/tests/testthat/test_categorize_prism.R @@ -28,10 +28,6 @@ as_ofs_for_signal <- function(signal) { unique() } -latest_as_of_for_signal <- function(signal) { - max(as_ofs_for_signal(signal)) -} - query_date_for <- function(signal, vintage) { vintages <- sort(as_ofs_for_signal(signal)) later_vintages <- vintages[vintages > vintage] @@ -55,11 +51,7 @@ prism_rows <- forecasttools::prism_thresholds |> ) prism_params <- prism_rows |> - dplyr::filter( - .data$as_of == latest_as_of_for_signal(.data$signal), - .by = "signal" - ) |> - dplyr::select("signal", "location", "disease") + dplyr::distinct(.data$signal, .data$location, .data$disease) test_that( @@ -183,9 +175,8 @@ test_that("error is thrown for invalid as_of", { "Influenza", as_of = "1900-01-01", signal = signal - ) |> - suppressWarnings(), - regexp = "No PRISM" + ), + regexp = "does not have a vintage" ) }) }) @@ -193,7 +184,21 @@ test_that("error is thrown for invalid as_of", { test_that("error is thrown for an unknown signal", { expect_error( get_prism_cutpoints("WA", "Influenza", signal = "NREVSS"), - regexp = "signal" + regexp = "for any as-of date" + ) +}) + +test_that("unknown location errors", { + expect_error( + get_prism_cutpoints("ZZ", "Influenza", signal = "NSSP"), + regexp = "for any as-of date" + ) +}) + +test_that("unknown disease errors", { + expect_error( + get_prism_cutpoints("WA", "Norovirus", signal = "NSSP"), + regexp = "for any as-of date" ) }) diff --git a/tests/testthat/test_utils.R b/tests/testthat/test_utils.R index 54e3c5c..36f1238 100644 --- a/tests/testthat/test_utils.R +++ b/tests/testthat/test_utils.R @@ -208,3 +208,101 @@ test_that("sym_limits functions argument checks work", { expect_error(sym_limits(c(1.3, "a")), "character") expect_error(sym_limits(c()), "NULL") }) + +test_filter_lte_df <- tibble::tibble( + number = c(-1, 1, 1, 3), + letter = c("A", "N", "Y", "Y"), + date = as.Date(c("2026-07-01", "2026-07-01", "2026-07-05", "2026-07-09")) +) + +test_that("filter_largest_lte treats values above the bound equally to the bound", { + expect_equal( + test_filter_lte_df |> filter_largest_lte(date, as.Date("2027-01-01")), + test_filter_lte_df |> filter_largest_lte(date, as.Date("2026-07-09")) + ) + + expect_equal( + test_filter_lte_df |> filter_largest_lte(number, 5000), + test_filter_lte_df |> filter_largest_lte(number, 3) + ) + + expect_equal( + test_filter_lte_df |> filter_largest_lte(letter, "Z"), + test_filter_lte_df |> filter_largest_lte(letter, "Y") + ) +}) + +test_that( + paste0( + "filter_largest_lte returns a length 0 tibble without a ", + "warning when the lower bound is below all values" + ), + { + expected_empty <- test_filter_lte_df |> dplyr::filter_out(TRUE) + expect_no_warning(expect_equal( + test_filter_lte_df |> filter_largest_lte(date, as.Date("1900-01-01")), + expected_empty + )) + + expect_no_warning(expect_equal( + test_filter_lte_df |> filter_largest_lte(number, -2), + expected_empty + )) + + expect_no_warning(expect_equal( + test_filter_lte_df |> filter_largest_lte(letter, ""), + expected_empty + )) + } +) + +test_that( + paste0( + "filter_largest_lte agrees with manual expectation on internal ", + "values and preserves multiple row matches" + ), + { + expect_equal( + test_filter_lte_df |> filter_largest_lte(date, as.Date("2026-07-02")), + test_filter_lte_df |> dplyr::filter(date == as.Date("2026-07-01")) + ) + + expect_equal( + test_filter_lte_df |> filter_largest_lte(number, 2), + test_filter_lte_df |> dplyr::filter(number == 1) + ) + + expect_equal( + test_filter_lte_df |> filter_largest_lte(letter, "O"), + test_filter_lte_df |> dplyr::filter(letter == "N") + ) + } +) + +test_that("filter_largest_lte works grouped", { + # .by and piping in a grouped df are equivalent + expect_equal( + test_filter_lte_df |> + dplyr::group_by(.data$letter) |> + filter_largest_lte(date, as.Date("2026-07-02")) |> + dplyr::ungroup(), + test_filter_lte_df |> + filter_largest_lte(date, as.Date("2026-07-02"), .by = "letter") + ) + ## .preserve is respected, so if we set it to true even the group + ## that gets filtered to size 0 ("Y") is retained. + expect_equal( + test_filter_lte_df |> + dplyr::group_by(letter) |> + filter_largest_lte(date, as.Date("2026-07-02")) |> + dplyr::n_groups(), + 2 + ) + expect_equal( + test_filter_lte_df |> + dplyr::group_by(letter) |> + filter_largest_lte(date, as.Date("2026-07-02"), .preserve = TRUE) |> + dplyr::n_groups(), + 3 + ) +}) From 451c6336f6b4e46b38ae5ba0cbc2bdc6829b0ebe Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Sat, 5 Sep 2026 18:15:16 -0400 Subject: [PATCH 02/16] Exclude helper function docs --- R/categorize_prism.R | 1 + man/dot-raise_prism_cutpoint_retrieval_error.Rd | 13 ------------- 2 files changed, 1 insertion(+), 13 deletions(-) delete mode 100644 man/dot-raise_prism_cutpoint_retrieval_error.Rd diff --git a/R/categorize_prism.R b/R/categorize_prism.R index b849378..9675fae 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -105,6 +105,7 @@ get_prism_cutpoints <- function( #' Helper function for raising informative errors #' when [get_prism_cutpoints()] fails. +#' @noRd .raise_prism_cutpoint_retrieval_error <- function( matches, candidates, diff --git a/man/dot-raise_prism_cutpoint_retrieval_error.Rd b/man/dot-raise_prism_cutpoint_retrieval_error.Rd deleted file mode 100644 index 082e42d..0000000 --- a/man/dot-raise_prism_cutpoint_retrieval_error.Rd +++ /dev/null @@ -1,13 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/categorize_prism.R -\name{.raise_prism_cutpoint_retrieval_error} -\alias{.raise_prism_cutpoint_retrieval_error} -\title{Helper function for raising informative errors -when \code{\link[=get_prism_cutpoints]{get_prism_cutpoints()}} fails.} -\usage{ -.raise_prism_cutpoint_retrieval_error(matches, candidates, desired_cutpoints) -} -\description{ -Helper function for raising informative errors -when \code{\link[=get_prism_cutpoints]{get_prism_cutpoints()}} fails. -} From 14ef8ff4001f07fb7f44ccb2ce7233f3e51d4136 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Sat, 5 Sep 2026 18:19:36 -0400 Subject: [PATCH 03/16] Namespace qualification for capture.output --- R/categorize_prism.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index 9675fae..d61282a 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -128,7 +128,7 @@ get_prism_cutpoints <- function( if (nrow(no_cutpoints) > 0) { rlang::abort( message = "At least one requested set of cutpoints not found in dataset for any as-of date", - body = c("Cutpoints not found:", capture.output(no_cutpoints)) + body = c("Cutpoints not found:", utils::capture.output(no_cutpoints)) ) } @@ -146,7 +146,7 @@ get_prism_cutpoints <- function( ) rlang::abort( message = "At least one requested set of cutpoints does not have a vintage matching the target as-of date.", - body = c("Cutpoints missing a vintage:", capture.output(no_vintage)) + body = c("Cutpoints missing a vintage:", utils::capture.output(no_vintage)) ) } From f2e33fe8d71066fe07f7edd642883c34178555c2 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Sat, 5 Sep 2026 18:29:54 -0400 Subject: [PATCH 04/16] Docs and function body consistent --- R/utils.R | 4 ++-- man/filter_largest_lte.Rd | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/R/utils.R b/R/utils.R index caee716..0d0cb91 100644 --- a/R/utils.R +++ b/R/utils.R @@ -366,7 +366,7 @@ sym_limits <- function(values, transform = "identity", center = NULL) { filter_largest_lte <- function( df, column, - target, + max_value, .by = NULL, .preserve = FALSE ) { @@ -374,7 +374,7 @@ filter_largest_lte <- function( max_or_na <- function(x) if (length(x) == 0) NA else max(x) dplyr::filter( df, - {{ column }} <= {{ target }}, + {{ column }} <= {{ max_value }}, .by = {{ .by }}, .preserve = .preserve ) |> diff --git a/man/filter_largest_lte.Rd b/man/filter_largest_lte.Rd index 1ebf77b..555b382 100644 --- a/man/filter_largest_lte.Rd +++ b/man/filter_largest_lte.Rd @@ -6,13 +6,16 @@ the largest value of that column that is less than or equal to specified maximum value.} \usage{ -filter_largest_lte(df, column, target, .by = NULL, .preserve = FALSE) +filter_largest_lte(df, column, max_value, .by = NULL, .preserve = FALSE) } \arguments{ \item{df}{data frame to filter} \item{column}{column to filter on.} +\item{max_value}{Maximum value. Filter to the +largest value in \code{column} less than or equal to \code{max_value}.} + \item{.by}{Optional grouping columns in \code{df} for the filter. Passed as the \code{.by} argument to \code{\link[dplyr:filter]{dplyr::filter()}}. Default \code{NULL}, matching the \code{\link[dplyr:filter]{dplyr::filter()}} default.} @@ -20,9 +23,6 @@ Default \code{NULL}, matching the \code{\link[dplyr:filter]{dplyr::filter()}} de \item{.preserve}{Preserve all groups present in grouped input? Passed as the \code{.preverse} argument to \code{\link[dplyr:filter]{dplyr::filter()}}. Default \code{FALSE}, matching the \code{\link[dplyr:filter]{dplyr::filter()}} default.} - -\item{max_value}{Maximum value. Filter to the -largest value in \code{column} less than or equal to \code{max_value}.} } \value{ The filtered data frame. From b3add59113f8f87cc6b0d89aaec523dfa4ee53b2 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Tue, 8 Sep 2026 12:51:23 -0400 Subject: [PATCH 05/16] Validation function scope --- R/categorize_prism.R | 95 ++++++++++++++++++++++++-------------------- 1 file changed, 51 insertions(+), 44 deletions(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index d61282a..d63ca97 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -93,61 +93,68 @@ get_prism_cutpoints <- function( matches <- candidates |> filter_largest_lte(.data$as_of, dplyr::cur_group()$target_as_of) - if (nrow(matches) != nrow(desired_cutpoints)) { - .raise_prism_cutpoint_retrieval_error( - matches, - candidates, - desired_cutpoints - ) - } + .validate_prism_cutpoint_matches( + matches, + candidates, + desired_cutpoints + ) + return(matches$values) } -#' Helper function for raising informative errors -#' when [get_prism_cutpoints()] fails. +#' Helper function for checking that retrieved PRISM cutpoints +#' have a unique match for each requested value, and raising an +#' informative errors if not. +#' #' @noRd -.raise_prism_cutpoint_retrieval_error <- function( +.validate_prism_cutpoint_matches <- function( matches, candidates, desired_cutpoints ) { - if (nrow(matches) > nrow(desired_cutpoints)) { - cli::cli_abort(paste0( - "Found more rows of matched cutpoints ", - "than requested sets of cutpoints. This ", - "should not occur, and suggests a duplicated ", - "data vintage in ", - "{.var forecasttools::prism_thresholds}" - )) - } - no_cutpoints <- desired_cutpoints |> - dplyr::anti_join(candidates, by = c("signal", "location", "disease")) |> - dplyr::select(-"target_as_of") - ## cli::cli_abort doesn't yet print tibbles nicely - ## https://github.com/r-lib/cli/issues/699 - if (nrow(no_cutpoints) > 0) { + if (nrow(matches) != nrow(desired_cutpoints)) { + if (nrow(matches) > nrow(desired_cutpoints)) { + cli::cli_abort(paste0( + "Found more rows of matched cutpoints ", + "than requested sets of cutpoints. This ", + "should not occur, and suggests a duplicated ", + "data vintage in ", + "{.var forecasttools::prism_thresholds}" + )) + } + no_cutpoints <- desired_cutpoints |> + dplyr::anti_join(candidates, by = c("signal", "location", "disease")) |> + dplyr::select(-"target_as_of") + ## cli::cli_abort doesn't yet print tibbles nicely + ## https://github.com/r-lib/cli/issues/699 + if (nrow(no_cutpoints) > 0) { + rlang::abort( + message = "At least one requested set of cutpoints not found in dataset for any as-of date", + body = c("Cutpoints not found:", utils::capture.output(no_cutpoints)) + ) + } + + no_vintage <- candidates |> + dplyr::ungroup() |> + dplyr::anti_join( + matches, + by = c("signal", "location", "disease", "target_as_of") + ) |> + dplyr::distinct( + .data$signal, + .data$location, + .data$disease, + .data$target_as_of + ) rlang::abort( - message = "At least one requested set of cutpoints not found in dataset for any as-of date", - body = c("Cutpoints not found:", utils::capture.output(no_cutpoints)) + message = "At least one requested set of cutpoints does not have a vintage matching the target as-of date.", + body = c( + "Cutpoints missing a vintage:", + utils::capture.output(no_vintage) + ) ) } - - no_vintage <- candidates |> - dplyr::ungroup() |> - dplyr::anti_join( - matches, - by = c("signal", "location", "disease", "target_as_of") - ) |> - dplyr::distinct( - .data$signal, - .data$location, - .data$disease, - .data$target_as_of - ) - rlang::abort( - message = "At least one requested set of cutpoints does not have a vintage matching the target as-of date.", - body = c("Cutpoints missing a vintage:", utils::capture.output(no_vintage)) - ) + invisible() } #' Categorize a numeric vector into PRISM From f5431a11cb7b9ea3e953ebccb986dc6b0e87ff5b Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Tue, 8 Sep 2026 13:03:00 -0400 Subject: [PATCH 06/16] Update docs, change optional argument order --- R/categorize_prism.R | 48 +++++++++++++++++++++--------------- man/categorize_prism.Rd | 18 ++++++-------- man/get_prism_cutpoints.Rd | 50 +++++++++++++++++++++----------------- 3 files changed, 64 insertions(+), 52 deletions(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index d63ca97..9e2213b 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -15,28 +15,36 @@ prism_bin_names_from_cutpoints <- function(cutpoints) { } -#' Get PRISM activity level cutpoints given -#' disease and location. +#' Get PRISM activity level cutpoint sets. #' -#' @param disease disease(s) for which to return the -#' cutpoints. One of `"ARI"`, `"COVID-19"`, -#' `"Influenza"`, or `"RSV"`, or an array of those -#' values. NHSN provides no `"ARI"` thresholds. -#' @param location location(s) for which to return the +#' Cutpoint sets are specific to a particular +#' combination of disease, location, and signal. +#' They are also vintaged; you can look up the set of +#' cutpoints that were in place for a given disease, +#' location, and signal as of any particular date (with +#' an error if none were defined as of that date). +#' +#' This function is vectorized. It recycles +#' the `disease`, `location`, `signal``, and `as_of` +#' arguments to a common length and returns a +#' corresponding list of cutpoint vectors. +#' +#' @param disease disease for which to return the +#' cutpoints. Options are `"ARI"` (NSSP-only), +#' `"COVID-19"`, `"Influenza"`, and `"RSV"`. +#' @param location location for which to return the #' cutpoints, as a two-letter abbreviation. Use #' [forecasttools::us_location_recode] with #' `location_output_format = "abbr"` to convert to this #' format. -#' @param as_of single date for which the cutpoints are -#' valid, applied to every `location`, `disease`, and -#' `signal`. Defaults to today. -#' @param signal surveillance signal(s) for which to -#' return the cutpoints. One of `"NSSP"` (proportions -#' of emergency department visits) or `"NHSN"` (weekly -#' hospital admissions per 100k population), or an -#' array of those values. If not given, defaults to -#' `"NSSP"` with a deprecation warning (a future -#' version will require it). +#' @param signal surveillance signal for which to +#' return the cutpoints. Options are `"NSSP"` (proportions +#' of emergency department visits) and `"NHSN"` (weekly +#' hospital admissions per 100k population). +#' If not specified, default to `"NSSP"` with a +#' deprecation warning. +#' @param as_of Retrieve cutpoints that were in place as of +#' this date. Defaults to today (current cuptoints). #' @return The cutpoints, as a list of vectors, named #' `very_low`, `low`, `moderate`, `high`, `very_high`, #' and `upper_bound` for every signal. @@ -49,8 +57,8 @@ prism_bin_names_from_cutpoints <- function(cutpoints) { #' get_prism_cutpoints( #' c("US", "WA"), #' c("COVID-19", "RSV"), -#' as.Date("2025-01-01"), #' signal = "NSSP" +#' as_of = as.Date("2025-01-01"), #' ) #' #' get_prism_cutpoints("WA", "Influenza", signal = c("NSSP", "NHSN")) @@ -59,8 +67,8 @@ prism_bin_names_from_cutpoints <- function(cutpoints) { get_prism_cutpoints <- function( location, disease, - as_of = lubridate::today(), - signal = lifecycle::deprecated() + signal = lifecycle::deprecated(), + as_of = lubridate::today() ) { if (!lifecycle::is_present(signal)) { lifecycle::deprecate_warn( diff --git a/man/categorize_prism.Rd b/man/categorize_prism.Rd index f333484..4ec5c18 100644 --- a/man/categorize_prism.Rd +++ b/man/categorize_prism.Rd @@ -23,9 +23,8 @@ to \code{value} or a single location for all \code{value}.} \item{disease}{vector of disease of length equal to \code{value} or a single disease for all \code{value}.} -\item{as_of}{single date for which the cutpoints are -valid, applied to every \code{location}, \code{disease}, and -\code{signal}. Defaults to today.} +\item{as_of}{Retrieve cutpoints that were in place as of +this date. Defaults to today (current cuptoints).} \item{prism_bin_names}{Bin names for the PRISM bins, in order from lowest to highest. Must be a vector of @@ -36,13 +35,12 @@ names by dropping the upper bound and converting to title case, giving \code{"Very Low"}, \code{"Low"}, \code{"Moderate"}, \code{"High"}, and \code{"Very High"}.} -\item{signal}{surveillance signal(s) for which to -return the cutpoints. One of \code{"NSSP"} (proportions -of emergency department visits) or \code{"NHSN"} (weekly -hospital admissions per 100k population), or an -array of those values. If not given, defaults to -\code{"NSSP"} with a deprecation warning (a future -version will require it).} +\item{signal}{surveillance signal for which to +return the cutpoints. Options are \code{"NSSP"} (proportions +of emergency department visits) and \code{"NHSN"} (weekly +hospital admissions per 100k population). +If not specified, default to \code{"NSSP"} with a +deprecation warning.} } \value{ A factor vector of category labels, equal in diff --git a/man/get_prism_cutpoints.Rd b/man/get_prism_cutpoints.Rd index 9d2c521..6fd2583 100644 --- a/man/get_prism_cutpoints.Rd +++ b/man/get_prism_cutpoints.Rd @@ -2,39 +2,35 @@ % Please edit documentation in R/categorize_prism.R \name{get_prism_cutpoints} \alias{get_prism_cutpoints} -\title{Get PRISM activity level cutpoints given -disease and location.} +\title{Get PRISM activity level cutpoint sets.} \usage{ get_prism_cutpoints( location, disease, - as_of = lubridate::today(), - signal = lifecycle::deprecated() + signal = lifecycle::deprecated(), + as_of = lubridate::today() ) } \arguments{ -\item{location}{location(s) for which to return the +\item{location}{location for which to return the cutpoints, as a two-letter abbreviation. Use \link{us_location_recode} with \code{location_output_format = "abbr"} to convert to this format.} -\item{disease}{disease(s) for which to return the -cutpoints. One of \code{"ARI"}, \code{"COVID-19"}, -\code{"Influenza"}, or \code{"RSV"}, or an array of those -values. NHSN provides no \code{"ARI"} thresholds.} +\item{disease}{disease for which to return the +cutpoints. Options are \code{"ARI"} (NSSP-only), +\code{"COVID-19"}, \code{"Influenza"}, and \code{"RSV"}.} -\item{as_of}{single date for which the cutpoints are -valid, applied to every \code{location}, \code{disease}, and -\code{signal}. Defaults to today.} +\item{signal}{surveillance signal for which to +return the cutpoints. Options are \code{"NSSP"} (proportions +of emergency department visits) and \code{"NHSN"} (weekly +hospital admissions per 100k population). +If not specified, default to \code{"NSSP"} with a +deprecation warning.} -\item{signal}{surveillance signal(s) for which to -return the cutpoints. One of \code{"NSSP"} (proportions -of emergency department visits) or \code{"NHSN"} (weekly -hospital admissions per 100k population), or an -array of those values. If not given, defaults to -\code{"NSSP"} with a deprecation warning (a future -version will require it).} +\item{as_of}{Retrieve cutpoints that were in place as of +this date. Defaults to today (current cuptoints).} } \value{ The cutpoints, as a list of vectors, named @@ -42,8 +38,18 @@ The cutpoints, as a list of vectors, named and \code{upper_bound} for every signal. } \description{ -Get PRISM activity level cutpoints given -disease and location. +Cutpoint sets are specific to a particular +combination of disease, location, and signal. +They are also vintaged; you can look up the set of +cutpoints that were in place for a given disease, +location, and signal as of any particular date (with +an error if none were defined as of that date). +} +\details{ +This function is vectorized. It recycles +the \code{disease}, \code{location}, \verb{signal``, and }as_of` +arguments to a common length and returns a +corresponding list of cutpoint vectors. } \examples{ get_prism_cutpoints("WA", "Influenza", signal = "NHSN") @@ -53,8 +59,8 @@ get_prism_cutpoints(c("US", "WA"), "COVID-19", signal = "NSSP") get_prism_cutpoints( c("US", "WA"), c("COVID-19", "RSV"), - as.Date("2025-01-01"), signal = "NSSP" + as_of = as.Date("2025-01-01"), ) get_prism_cutpoints("WA", "Influenza", signal = c("NSSP", "NHSN")) From 3215f65ca4ec2a02e03288f932820f705d5b4289 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Tue, 8 Sep 2026 13:13:04 -0400 Subject: [PATCH 07/16] Early return --- R/categorize_prism.R | 84 +++++++++++++++++++++++--------------------- 1 file changed, 44 insertions(+), 40 deletions(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index 9e2213b..1b61e92 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -120,49 +120,53 @@ get_prism_cutpoints <- function( candidates, desired_cutpoints ) { - if (nrow(matches) != nrow(desired_cutpoints)) { - if (nrow(matches) > nrow(desired_cutpoints)) { - cli::cli_abort(paste0( - "Found more rows of matched cutpoints ", - "than requested sets of cutpoints. This ", - "should not occur, and suggests a duplicated ", - "data vintage in ", - "{.var forecasttools::prism_thresholds}" - )) - } - no_cutpoints <- desired_cutpoints |> - dplyr::anti_join(candidates, by = c("signal", "location", "disease")) |> - dplyr::select(-"target_as_of") - ## cli::cli_abort doesn't yet print tibbles nicely - ## https://github.com/r-lib/cli/issues/699 - if (nrow(no_cutpoints) > 0) { - rlang::abort( - message = "At least one requested set of cutpoints not found in dataset for any as-of date", - body = c("Cutpoints not found:", utils::capture.output(no_cutpoints)) - ) - } - - no_vintage <- candidates |> - dplyr::ungroup() |> - dplyr::anti_join( - matches, - by = c("signal", "location", "disease", "target_as_of") - ) |> - dplyr::distinct( - .data$signal, - .data$location, - .data$disease, - .data$target_as_of - ) + if (nrow(matches) == nrow(desired_cutpoints)) { + return(invisible()) + } + + if (nrow(matches) > nrow(desired_cutpoints)) { + cli::cli_abort(paste0( + "Found more rows of matched cutpoints ", + "than requested sets of cutpoints. This ", + "should not occur, and suggests a duplicated ", + "data vintage in ", + "{.var forecasttools::prism_thresholds}" + )) + } + + # otherwise fewer matches than cutpoints; find which are missing + + # globally missing or just for the requested vintage? + no_cutpoints <- desired_cutpoints |> + dplyr::anti_join(candidates, by = c("signal", "location", "disease")) |> + dplyr::select(-"target_as_of") + + ## cli::cli_abort doesn't yet print tibbles nicely + ## https://github.com/r-lib/cli/issues/699 + if (nrow(no_cutpoints) > 0) { rlang::abort( - message = "At least one requested set of cutpoints does not have a vintage matching the target as-of date.", - body = c( - "Cutpoints missing a vintage:", - utils::capture.output(no_vintage) - ) + message = "At least one requested set of cutpoints not found in dataset for any as-of date", + body = c("Cutpoints not found:", utils::capture.output(no_cutpoints)) ) } - invisible() + + # else missing for the requested vintage + no_vintage <- candidates |> + dplyr::ungroup() |> + dplyr::anti_join( + matches, + by = c("signal", "location", "disease", "target_as_of") + ) |> + dplyr::distinct( + .data$signal, + .data$location, + .data$disease, + .data$target_as_of + ) + rlang::abort( + message = "At least one requested set of cutpoints does not have a vintage matching the target as-of date.", + body = c("Cutpoints missing a vintage:", utils::capture.output(no_vintage)) + ) } #' Categorize a numeric vector into PRISM From f5af3211be16a1ae6a8c447b9020970d9721ad11 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Tue, 8 Sep 2026 13:26:32 -0400 Subject: [PATCH 08/16] Use a rolling join --- R/categorize_prism.R | 39 +++++++++++++++++++-------------------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index 1b61e92..12eebc7 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -86,24 +86,19 @@ get_prism_cutpoints <- function( target_as_of = lubridate::as_date(as_of) ) - candidates <- dplyr::inner_join( + matches <- dplyr::inner_join( desired_cutpoints, forecasttools::prism_thresholds, - by = c("signal", "location", "disease") - ) |> - dplyr::group_by( - .data$signal, - .data$location, - .data$disease, - .data$target_as_of + by = dplyr::join_by( + "signal", + "location", + "disease", + dplyr::closest(x$target_as_of >= y$as_of) ) - - matches <- candidates |> - filter_largest_lte(.data$as_of, dplyr::cur_group()$target_as_of) + ) .validate_prism_cutpoint_matches( matches, - candidates, desired_cutpoints ) @@ -117,7 +112,6 @@ get_prism_cutpoints <- function( #' @noRd .validate_prism_cutpoint_matches <- function( matches, - candidates, desired_cutpoints ) { if (nrow(matches) == nrow(desired_cutpoints)) { @@ -138,9 +132,10 @@ get_prism_cutpoints <- function( # globally missing or just for the requested vintage? no_cutpoints <- desired_cutpoints |> - dplyr::anti_join(candidates, by = c("signal", "location", "disease")) |> - dplyr::select(-"target_as_of") - + dplyr::anti_join( + forecasttools::prism_thresholds, + by = c("signal", "location", "disease") + ) ## cli::cli_abort doesn't yet print tibbles nicely ## https://github.com/r-lib/cli/issues/699 if (nrow(no_cutpoints) > 0) { @@ -151,11 +146,15 @@ get_prism_cutpoints <- function( } # else missing for the requested vintage - no_vintage <- candidates |> - dplyr::ungroup() |> + no_vintage <- desired_cutpoints |> dplyr::anti_join( - matches, - by = c("signal", "location", "disease", "target_as_of") + forecasttools::prism_thresholds, + by = dplyr::join_by( + "signal", + "location", + "disease", + dplyr::closest(x$target_as_of >= y$as_of) + ) ) |> dplyr::distinct( .data$signal, From 2c5ca75b86ca82620e517acdd85e511f4a7ae9d0 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Tue, 8 Sep 2026 18:36:13 -0400 Subject: [PATCH 09/16] Rely on dplyr validation --- R/categorize_prism.R | 110 ++++++++++++++++++++----------------------- 1 file changed, 51 insertions(+), 59 deletions(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index 12eebc7..c113d74 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -86,88 +86,80 @@ get_prism_cutpoints <- function( target_as_of = lubridate::as_date(as_of) ) - matches <- dplyr::inner_join( - desired_cutpoints, - forecasttools::prism_thresholds, - by = dplyr::join_by( - "signal", - "location", - "disease", - dplyr::closest(x$target_as_of >= y$as_of) - ) - ) - - .validate_prism_cutpoint_matches( - matches, - desired_cutpoints + matches <- rlang::try_fetch( + dplyr::inner_join( + desired_cutpoints, + forecasttools::prism_thresholds, + by = dplyr::join_by( + "location", + "disease", + "signal", + dplyr::closest(x$target_as_of >= y$as_of) + ), + unmatched = c("error", "drop"), + relationship = "many-to-one" + ), + error = function(cnd) { + .raise_prism_cutpoint_lookup_error( + desired_cutpoints, + cnd + ) + } ) return(matches$values) } -#' Helper function for checking that retrieved PRISM cutpoints -#' have a unique match for each requested value, and raising an -#' informative errors if not. +#' Raise a more informative error when PRISM cutpoint lookup +#' fails. In particular, flag the missing cutpoints when possible. #' #' @noRd -.validate_prism_cutpoint_matches <- function( - matches, - desired_cutpoints -) { - if (nrow(matches) == nrow(desired_cutpoints)) { - return(invisible()) - } - - if (nrow(matches) > nrow(desired_cutpoints)) { - cli::cli_abort(paste0( - "Found more rows of matched cutpoints ", - "than requested sets of cutpoints. This ", - "should not occur, and suggests a duplicated ", - "data vintage in ", - "{.var forecasttools::prism_thresholds}" - )) - } - - # otherwise fewer matches than cutpoints; find which are missing +.raise_prism_cutpoint_lookup_error <- function(desired_cutpoints, cnd) { + fully_missing_cutpoints <- dplyr::anti_join( + desired_cutpoints, + forecasttools::prism_thresholds, + by = c("location", "disease", "signal") + ) - # globally missing or just for the requested vintage? - no_cutpoints <- desired_cutpoints |> - dplyr::anti_join( - forecasttools::prism_thresholds, - by = c("signal", "location", "disease") - ) - ## cli::cli_abort doesn't yet print tibbles nicely - ## https://github.com/r-lib/cli/issues/699 - if (nrow(no_cutpoints) > 0) { + if (nrow(fully_missing_cutpoints) > 0) { + ## cli::cli_abort doesn't yet print tibbles nicely + ## https://github.com/r-lib/cli/issues/699 rlang::abort( - message = "At least one requested set of cutpoints not found in dataset for any as-of date", - body = c("Cutpoints not found:", utils::capture.output(no_cutpoints)) + message = "At least one requested set of cutpoints not found for any as-of date", + body = c( + "Cutpoints not found:", + utils::capture.output(fully_missing_cutpoints) + ), + parent = cnd ) } - # else missing for the requested vintage no_vintage <- desired_cutpoints |> dplyr::anti_join( forecasttools::prism_thresholds, by = dplyr::join_by( - "signal", "location", "disease", + "signal", dplyr::closest(x$target_as_of >= y$as_of) ) - ) |> - dplyr::distinct( - .data$signal, - .data$location, - .data$disease, - .data$target_as_of ) - rlang::abort( - message = "At least one requested set of cutpoints does not have a vintage matching the target as-of date.", - body = c("Cutpoints missing a vintage:", utils::capture.output(no_vintage)) - ) + + if (nrow(no_vintage > 0)) { + rlang::abort( + message = "At least one requested set of cutpoints does not have a vintage matching the requested as-of date.", + body = c( + "Cutpoints missing a requested vintage:", + utils::capture.output(no_vintage) + ), + parent = cnd + ) + } + + rlang::abort("Unexpected error retrieving PRISM cutpoints", parent = cnd) } + #' Categorize a numeric vector into PRISM #' activity level bins. #' From 088a168da904fef9e2bbd9322dac3df6e8774d4d Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Tue, 8 Sep 2026 18:47:42 -0400 Subject: [PATCH 10/16] Update R/categorize_prism.R Co-authored-by: Damon Bayer --- R/categorize_prism.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index c113d74..2d3b228 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -44,7 +44,7 @@ prism_bin_names_from_cutpoints <- function(cutpoints) { #' If not specified, default to `"NSSP"` with a #' deprecation warning. #' @param as_of Retrieve cutpoints that were in place as of -#' this date. Defaults to today (current cuptoints). +#' this date. Defaults to today (current cutpoints). #' @return The cutpoints, as a list of vectors, named #' `very_low`, `low`, `moderate`, `high`, `very_high`, #' and `upper_bound` for every signal. From ba7f06df2821d1d0a94595ec71994586052c91b6 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Tue, 8 Sep 2026 21:07:41 -0400 Subject: [PATCH 11/16] Fix example --- R/categorize_prism.R | 4 ++-- man/categorize_prism.Rd | 2 +- man/get_prism_cutpoints.Rd | 6 +++--- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index 2d3b228..1931342 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -57,8 +57,8 @@ prism_bin_names_from_cutpoints <- function(cutpoints) { #' get_prism_cutpoints( #' c("US", "WA"), #' c("COVID-19", "RSV"), -#' signal = "NSSP" -#' as_of = as.Date("2025-01-01"), +#' signal = "NSSP", +#' as_of = as.Date("2025-01-01") #' ) #' #' get_prism_cutpoints("WA", "Influenza", signal = c("NSSP", "NHSN")) diff --git a/man/categorize_prism.Rd b/man/categorize_prism.Rd index 4ec5c18..329331c 100644 --- a/man/categorize_prism.Rd +++ b/man/categorize_prism.Rd @@ -24,7 +24,7 @@ to \code{value} or a single location for all \code{value}.} \code{value} or a single disease for all \code{value}.} \item{as_of}{Retrieve cutpoints that were in place as of -this date. Defaults to today (current cuptoints).} +this date. Defaults to today (current cutpoints).} \item{prism_bin_names}{Bin names for the PRISM bins, in order from lowest to highest. Must be a vector of diff --git a/man/get_prism_cutpoints.Rd b/man/get_prism_cutpoints.Rd index 6fd2583..05bbdda 100644 --- a/man/get_prism_cutpoints.Rd +++ b/man/get_prism_cutpoints.Rd @@ -30,7 +30,7 @@ If not specified, default to \code{"NSSP"} with a deprecation warning.} \item{as_of}{Retrieve cutpoints that were in place as of -this date. Defaults to today (current cuptoints).} +this date. Defaults to today (current cutpoints).} } \value{ The cutpoints, as a list of vectors, named @@ -59,8 +59,8 @@ get_prism_cutpoints(c("US", "WA"), "COVID-19", signal = "NSSP") get_prism_cutpoints( c("US", "WA"), c("COVID-19", "RSV"), - signal = "NSSP" - as_of = as.Date("2025-01-01"), + signal = "NSSP", + as_of = as.Date("2025-01-01") ) get_prism_cutpoints("WA", "Influenza", signal = c("NSSP", "NHSN")) From 4b30a1801fe2a1fc3b253b95cf357c2829e5db1e Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Wed, 9 Sep 2026 13:33:49 -0400 Subject: [PATCH 12/16] Update R/categorize_prism.R Co-authored-by: O957 <127630341+O957@users.noreply.github.com> --- R/categorize_prism.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index 1931342..6b66397 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -145,7 +145,7 @@ get_prism_cutpoints <- function( ) ) - if (nrow(no_vintage > 0)) { + if (nrow(no_vintage) > 0) { rlang::abort( message = "At least one requested set of cutpoints does not have a vintage matching the requested as-of date.", body = c( From dfd0feb9a35bf24f94808a33314a542272d6f1c7 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Wed, 9 Sep 2026 13:38:26 -0400 Subject: [PATCH 13/16] Stronger regex assertion --- tests/testthat/test_categorize_prism.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test_categorize_prism.R b/tests/testthat/test_categorize_prism.R index 304c8e0..0a16661 100644 --- a/tests/testthat/test_categorize_prism.R +++ b/tests/testthat/test_categorize_prism.R @@ -176,7 +176,7 @@ test_that("error is thrown for invalid as_of", { as_of = "1900-01-01", signal = signal ), - regexp = "does not have a vintage" + regexp = "does not have a vintage matching the requested" ) }) }) From cbaea1ccbbe94e4bd2621fee59ada127a1f46336 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Wed, 9 Sep 2026 14:36:05 -0400 Subject: [PATCH 14/16] Pin minimum dplyr --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8ed8d0b..bf92893 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,7 +28,7 @@ Imports: checkmate, cli, copula, - dplyr, + dplyr (>= 1.2.0), fs, gert, ggdist, From fdb9e652c3dfd8187b1b9312302646b1656cdfc0 Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Wed, 9 Sep 2026 14:58:30 -0400 Subject: [PATCH 15/16] Use utils::globalVariables for join_by names --- R/categorize_prism.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index 6b66397..4209d8e 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -5,6 +5,10 @@ prism_signal_deprecation_details <- glue::glue( "PRISM thresholds are now available for both NSSP and NHSN." ) +## current dplyr guidance for handling join_by expressions +## https://dplyr.tidyverse.org/articles/in-packages.html#join-helpers +utils::globalVariables("closest", "x", "y") + prism_bin_names_from_cutpoints <- function(cutpoints) { return( names(cutpoints) |> @@ -94,7 +98,7 @@ get_prism_cutpoints <- function( "location", "disease", "signal", - dplyr::closest(x$target_as_of >= y$as_of) + closest(x$target_as_of >= y$as_of) ), unmatched = c("error", "drop"), relationship = "many-to-one" @@ -141,7 +145,7 @@ get_prism_cutpoints <- function( "location", "disease", "signal", - dplyr::closest(x$target_as_of >= y$as_of) + closest(x$target_as_of >= y$as_of) ) ) From 10c83e0146c67861ed3b70e97f28c2fc26b8257e Mon Sep 17 00:00:00 2001 From: "Dylan H. Morris" Date: Wed, 9 Sep 2026 15:05:28 -0400 Subject: [PATCH 16/16] Fix missing c() --- R/categorize_prism.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/categorize_prism.R b/R/categorize_prism.R index 4209d8e..aa282d6 100644 --- a/R/categorize_prism.R +++ b/R/categorize_prism.R @@ -7,7 +7,7 @@ prism_signal_deprecation_details <- glue::glue( ## current dplyr guidance for handling join_by expressions ## https://dplyr.tidyverse.org/articles/in-packages.html#join-helpers -utils::globalVariables("closest", "x", "y") +utils::globalVariables(c("closest", "x", "y")) prism_bin_names_from_cutpoints <- function(cutpoints) { return(