From 468bfc059f9530da730184adad2cbafd02b09120 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 21 Jun 2023 18:13:54 -0400 Subject: [PATCH 01/32] drop arg specifying number of args to expect --- R/grouped_epi_archive.R | 2 +- R/slide.R | 2 +- R/utils.R | 6 ++---- 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/R/grouped_epi_archive.R b/R/grouped_epi_archive.R index fd91ed4d..28236a91 100644 --- a/R/grouped_epi_archive.R +++ b/R/grouped_epi_archive.R @@ -232,7 +232,7 @@ grouped_epi_archive = # Check that `f` takes enough args if (!missing(f) && is.function(f)) { - assert_sufficient_f_args(f, ..., n_mandatory_f_args = 3L) + assert_sufficient_f_args(f, ...) } # Validate and pre-process `before`: diff --git a/R/slide.R b/R/slide.R index 635d4d3d..3ebf9b26 100644 --- a/R/slide.R +++ b/R/slide.R @@ -170,7 +170,7 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, # Check that `f` takes enough args if (!missing(f) && is.function(f)) { - assert_sufficient_f_args(f, ..., n_mandatory_f_args = 3L) + assert_sufficient_f_args(f, ...) } if (missing(ref_time_values)) { diff --git a/R/utils.R b/R/utils.R index e4625a4f..6c4a50e1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -106,16 +106,14 @@ Warn = function(msg, ...) rlang::warn(break_str(msg, init = "Warning: "), ...) #' `epi_archive` in `epi_slide` or `epix_slide`. #' @param ... Dots that will be forwarded to `f` from the dots of `epi_slide` or #' `epix_slide`. -#' @param n_mandatory_f_args Integer; specifies the number of arguments `f` -#' is required to take before any `...` arg. Defaults to 2. #' #' @importFrom rlang is_missing #' @importFrom purrr map_lgl #' @importFrom utils tail #' #' @noRd -assert_sufficient_f_args <- function(f, ..., n_mandatory_f_args = 2L) { - mandatory_f_args_labels <- c("window data", "group key", "reference time value")[seq(n_mandatory_f_args)] +assert_sufficient_f_args <- function(f, ...) { + mandatory_f_args_labels <- c("window data", "group key", "reference time value") n_mandatory_f_args <- length(mandatory_f_args_labels) args = formals(args(f)) args_names = names(args) From 460fe63987440aec4fda2153d37c3140ffeb41e5 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 21 Jun 2023 18:14:02 -0400 Subject: [PATCH 02/32] update tests --- tests/testthat/test-utils.R | 38 ++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 4b1c38d2..bf073174 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -110,14 +110,14 @@ test_that("enlist works",{ }) test_that("assert_sufficient_f_args alerts if the provided f doesn't take enough args", { - f_xg = function(x, g) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) - f_xg_dots = function(x, g, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) + f_xgt = function(x, g, t) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) + f_xgt_dots = function(x, g, t, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) # If `regexp` is NA, asserts that there should be no errors/messages. - expect_error(assert_sufficient_f_args(f_xg), regexp = NA) - expect_warning(assert_sufficient_f_args(f_xg), regexp = NA) - expect_error(assert_sufficient_f_args(f_xg_dots), regexp = NA) - expect_warning(assert_sufficient_f_args(f_xg_dots), regexp = NA) + expect_error(assert_sufficient_f_args(f_xgt), regexp = NA) + expect_warning(assert_sufficient_f_args(f_xgt), regexp = NA) + expect_error(assert_sufficient_f_args(f_xgt_dots), regexp = NA) + expect_warning(assert_sufficient_f_args(f_xgt_dots), regexp = NA) f_x_dots = function(x, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) f_dots = function(...) dplyr::tibble(value=c(5), count=c(2)) @@ -125,10 +125,10 @@ test_that("assert_sufficient_f_args alerts if the provided f doesn't take enough f = function() dplyr::tibble(value=c(5), count=c(2)) expect_warning(assert_sufficient_f_args(f_x_dots), - regexp = ", the group key will be included", + regexp = ", the group key and reference time value will be included", class = "epiprocess__assert_sufficient_f_args__mandatory_f_args_passed_to_f_dots") expect_warning(assert_sufficient_f_args(f_dots), - regexp = ", the window data and group key will be included", + regexp = ", the window data, group key, and reference time value will be included", class = "epiprocess__assert_sufficient_f_args__mandatory_f_args_passed_to_f_dots") expect_error(assert_sufficient_f_args(f_x), class = "epiprocess__assert_sufficient_f_args__f_needs_min_args") @@ -142,39 +142,39 @@ test_that("assert_sufficient_f_args alerts if the provided f doesn't take enough expect_error(assert_sufficient_f_args(f_xs, setting="b"), class = "epiprocess__assert_sufficient_f_args__f_needs_min_args_plus_forwarded") - expect_error(assert_sufficient_f_args(f_xg, "b"), + expect_error(assert_sufficient_f_args(f_xgt, "b"), class = "epiprocess__assert_sufficient_f_args__f_needs_min_args_plus_forwarded") }) test_that("assert_sufficient_f_args alerts if the provided f has defaults for the required args", { - f_xg = function(x, g=1) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) - f_xg_dots = function(x=1, g, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) + f_xgt = function(x, g=1, t) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) + f_xgt_dots = function(x=1, g, t, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) f_x_dots = function(x=1, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) - expect_error(assert_sufficient_f_args(f_xg), + expect_error(assert_sufficient_f_args(f_xgt), regexp = "pass the group key to `f`'s g argument,", class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") - expect_error(assert_sufficient_f_args(f_xg_dots), + expect_error(assert_sufficient_f_args(f_xgt_dots), regexp = "pass the window data to `f`'s x argument,", class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") expect_error(suppressWarnings(assert_sufficient_f_args(f_x_dots)), class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") - f_xsg = function(x, setting="a", g) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) - f_xsg_dots = function(x, setting="a", g, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) + f_xsgt = function(x, setting="a", g, t) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) + f_xsgt_dots = function(x, setting="a", g, t, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) f_xs_dots = function(x=1, setting="a", ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary)) # forwarding named dots should prevent some complaints: - expect_no_error(assert_sufficient_f_args(f_xsg, setting = "b")) - expect_no_error(assert_sufficient_f_args(f_xsg_dots, setting = "b")) + expect_no_error(assert_sufficient_f_args(f_xsgt, setting = "b")) + expect_no_error(assert_sufficient_f_args(f_xsgt_dots, setting = "b")) expect_error(suppressWarnings(assert_sufficient_f_args(f_xs_dots, setting = "b")), regexp = "window data to `f`'s x argument", class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") # forwarding unnamed dots should not: - expect_error(assert_sufficient_f_args(f_xsg, "b"), + expect_error(assert_sufficient_f_args(f_xsgt, "b"), class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") - expect_error(assert_sufficient_f_args(f_xsg_dots, "b"), + expect_error(assert_sufficient_f_args(f_xsgt_dots, "b"), class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") expect_error(assert_sufficient_f_args(f_xs_dots, "b"), class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") From 18ae844200e43b1c85bacf827b206560619f003f Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Thu, 22 Jun 2023 16:57:31 -0400 Subject: [PATCH 03/32] move f arg check to as_slide_computation --- R/grouped_epi_archive.R | 7 +------ R/slide.R | 7 +------ R/utils.R | 4 ++-- 3 files changed, 4 insertions(+), 14 deletions(-) diff --git a/R/grouped_epi_archive.R b/R/grouped_epi_archive.R index 28236a91..ed98c4f7 100644 --- a/R/grouped_epi_archive.R +++ b/R/grouped_epi_archive.R @@ -229,11 +229,6 @@ grouped_epi_archive = # implementation doesn't take advantage of it. ref_time_values = sort(ref_time_values) } - - # Check that `f` takes enough args - if (!missing(f) && is.function(f)) { - assert_sufficient_f_args(f, ...) - } # Validate and pre-process `before`: if (missing(before)) { @@ -298,7 +293,7 @@ grouped_epi_archive = # If f is not missing, then just go ahead, slide by group if (!missing(f)) { - if (rlang::is_formula(f)) f = as_slide_computation(f) + f = as_slide_computation(f, ...) x = purrr::map_dfr(ref_time_values, function(ref_time_value) { # Ungrouped as-of data; `epi_df` if `all_versions` is `FALSE`, # `epi_archive` if `all_versions` is `TRUE`: diff --git a/R/slide.R b/R/slide.R index 3ebf9b26..511bbe8a 100644 --- a/R/slide.R +++ b/R/slide.R @@ -167,11 +167,6 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, # Check we have an `epi_df` object if (!inherits(x, "epi_df")) Abort("`x` must be of class `epi_df`.") - - # Check that `f` takes enough args - if (!missing(f) && is.function(f)) { - assert_sufficient_f_args(f, ...) - } if (missing(ref_time_values)) { ref_time_values = unique(x$time_value) @@ -358,7 +353,7 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, # If f is not missing, then just go ahead, slide by group if (!missing(f)) { - if (rlang::is_formula(f)) f = as_slide_computation(f) + f = as_slide_computation(f, ...) f_rtv_wrapper = function(x, g, ...) { ref_time_value = min(x$time_value) + before x <- x[x$.real,] diff --git a/R/utils.R b/R/utils.R index 6c4a50e1..f198afd7 100644 --- a/R/utils.R +++ b/R/utils.R @@ -239,9 +239,9 @@ as_slide_computation <- function(x, ..., arg = caller_arg(x), call = caller_env()) { - check_dots_empty0(...) - if (is_function(x)) { + # Check that `f` takes enough args + assert_sufficient_f_args(x, ...) return(x) } From 5ffb590bfecdddf3ab4df62a0279f9ebfc6cd157 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Thu, 22 Jun 2023 17:45:44 -0400 Subject: [PATCH 04/32] add more testing for .x and .data access --- tests/testthat/test-epi_slide.R | 6 ++++++ tests/testthat/test-epix_slide.R | 7 +++++++ 2 files changed, 13 insertions(+) diff --git a/tests/testthat/test-epi_slide.R b/tests/testthat/test-epi_slide.R index 23bab72f..2e61e088 100644 --- a/tests/testthat/test-epi_slide.R +++ b/tests/testthat/test-epi_slide.R @@ -509,6 +509,12 @@ test_that("epi_slide computation via dots outputs the same result using col name slide_value = max(.x$time_value)) expect_identical(result1, expected_output) + + result2 <- small_x %>% + epi_slide(before = 2, + slide_value = max(.data$time_value)) + + expect_identical(result2, expected_output) }) test_that("`epi_slide` can access objects inside of helper functions", { diff --git a/tests/testthat/test-epix_slide.R b/tests/testthat/test-epix_slide.R index b3353bac..9e091642 100644 --- a/tests/testthat/test-epix_slide.R +++ b/tests/testthat/test-epix_slide.R @@ -669,6 +669,13 @@ test_that("epix_slide computation via dots outputs the same result using col nam sum_binary = sum(.x$time_value)) expect_identical(xx1, xx_ref) + + xx2 <- xx %>% + group_by(.data$geo_value) %>% + epix_slide(before = 2, + sum_binary = sum(.data$time_value)) + + expect_identical(xx2, xx_ref) }) test_that("`epix_slide` doesn't decay date output", { From 3ae827ded8d5b300fbf744b3cbd514484c440a7b Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Thu, 22 Jun 2023 18:41:34 -0400 Subject: [PATCH 05/32] make epi_slide data mask creation match epix_slide --- R/slide.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/slide.R b/R/slide.R index 511bbe8a..7dfe5bfb 100644 --- a/R/slide.R +++ b/R/slide.R @@ -386,7 +386,10 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, .ref_time_value = min(.x$time_value) + before .x <- .x[.x$.real,] .x$.real <- NULL - data_mask = rlang::as_data_mask(.x) + + data_env = rlang::as_environment(.x) + data_mask = rlang::new_data_mask(bottom = data_env, top = data_env) + data_mask$.data <- rlang::as_data_pronoun(data_mask) # We'll also install `.x` directly, not as an `rlang_data_pronoun`, so # that we can, e.g., use more dplyr and epiprocess operations. data_mask$.x = .x From e188e2b1e9ead4d34b92a9e20457bacdde5d29bc Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Mon, 26 Jun 2023 18:29:34 -0400 Subject: [PATCH 06/32] move quosure -> function creation to as_slide_computation --- R/grouped_epi_archive.R | 18 +------ R/slide.R | 38 ++++--------- R/utils.R | 115 ++++++++++++++++++++++++++++++---------- 3 files changed, 98 insertions(+), 73 deletions(-) diff --git a/R/grouped_epi_archive.R b/R/grouped_epi_archive.R index ed98c4f7..30ad9bec 100644 --- a/R/grouped_epi_archive.R +++ b/R/grouped_epi_archive.R @@ -293,7 +293,7 @@ grouped_epi_archive = # If f is not missing, then just go ahead, slide by group if (!missing(f)) { - f = as_slide_computation(f, ...) + f = as_slide_computation(f, calc_ref_time_value = FALSE, ...) x = purrr::map_dfr(ref_time_values, function(ref_time_value) { # Ungrouped as-of data; `epi_df` if `all_versions` is `FALSE`, # `epi_archive` if `all_versions` is `TRUE`: @@ -365,21 +365,7 @@ grouped_epi_archive = } quo = quos[[1]] - f = function(.x, .group_key, .ref_time_value, quo, ...) { - # Convert to environment to standardize between tibble and R6 - # based inputs. In both cases, we should get a simple - # environment with the empty environment as its parent. - data_env = rlang::as_environment(.x) - data_mask = rlang::new_data_mask(bottom = data_env, top = data_env) - data_mask$.data <- rlang::as_data_pronoun(data_mask) - # We'll also install `.x` directly, not as an - # `rlang_data_pronoun`, so that we can, e.g., use more dplyr and - # epiprocess operations. - data_mask$.x = .x - data_mask$.group_key = .group_key - data_mask$.ref_time_value = .ref_time_value - rlang::eval_tidy(quo, data_mask) - } + f = as_slide_computation(quo, calc_ref_time_value = FALSE, ...) new_col = sym(names(rlang::quos_auto_name(quos))) x = purrr::map_dfr(ref_time_values, function(ref_time_value) { diff --git a/R/slide.R b/R/slide.R index 7dfe5bfb..8cff4840 100644 --- a/R/slide.R +++ b/R/slide.R @@ -353,24 +353,18 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, # If f is not missing, then just go ahead, slide by group if (!missing(f)) { - f = as_slide_computation(f, ...) - f_rtv_wrapper = function(x, g, ...) { - ref_time_value = min(x$time_value) + before - x <- x[x$.real,] - x$.real <- NULL - f(x, g, ref_time_value, ...) - } - x = x %>% + f = as_slide_computation(f, calc_ref_time_value = TRUE, before = before, ...) + x = x %>% group_modify(slide_one_grp, - f = f_rtv_wrapper, ..., + f = f, ..., starts = starts, stops = stops, - time_values = ref_time_values, + time_values = ref_time_values, all_rows = all_rows, new_col = new_col, .keep = FALSE) } - + # Else interpret ... as an expression for tidy evaluation else { quos = enquos(...) @@ -382,29 +376,15 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, } quo = quos[[1]] - f = function(.x, .group_key, quo, ...) { - .ref_time_value = min(.x$time_value) + before - .x <- .x[.x$.real,] - .x$.real <- NULL - - data_env = rlang::as_environment(.x) - data_mask = rlang::new_data_mask(bottom = data_env, top = data_env) - data_mask$.data <- rlang::as_data_pronoun(data_mask) - # We'll also install `.x` directly, not as an `rlang_data_pronoun`, so - # that we can, e.g., use more dplyr and epiprocess operations. - data_mask$.x = .x - data_mask$.group_key = .group_key - data_mask$.ref_time_value = .ref_time_value - rlang::eval_tidy(quo, data_mask) - } new_col = sym(names(rlang::quos_auto_name(quos))) - - x = x %>% + + f = as_slide_computation(quo, calc_ref_time_value = TRUE, before = before, ...) + x = x %>% group_modify(slide_one_grp, f = f, quo = quo, starts = starts, stops = stops, - time_values = ref_time_values, + time_values = ref_time_values, all_rows = all_rows, new_col = new_col, .keep = FALSE) diff --git a/R/utils.R b/R/utils.R index f198afd7..740817cf 100644 --- a/R/utils.R +++ b/R/utils.R @@ -215,6 +215,15 @@ assert_sufficient_f_args <- function(f, ...) { #' scoping issues involved. Package developers should avoid #' supplying functions by name and instead supply them by value. #' +#' @param calc_ref_time_value Boolean indicating whether the computation +#' function should include a step to calculate `ref_time_value` based on the +#' contents of the group data `.x`. This is used in `epi_slide`. When this +#' flag is `FALSE`, as is the default, the resulting computation takes the +#' three standard arguments, group data, group key(s), and reference time +#' value, plus any extra arguments. When this flag is `TRUE`, the resulting +#' computation only takes two of the standard arguments, group data and +#' group key(s), plus any extra arguments. The `ref_time_value` argument is +#' unnecessary since its value is being calculated within the computation. #' @param env Environment in which to fetch the function in case `x` #' is a string. #' @inheritParams rlang::args_dots_empty @@ -235,47 +244,97 @@ assert_sufficient_f_args <- function(f, ...) { #' #' @noRd as_slide_computation <- function(x, + calc_ref_time_value = FALSE, + before, env = global_env(), ..., arg = caller_arg(x), call = caller_env()) { - if (is_function(x)) { - # Check that `f` takes enough args - assert_sufficient_f_args(x, ...) - return(x) + # A quosure is a type of formula, so be careful with `if` logic here. + if (is_quosure(x)) { + if (calc_ref_time_value) { + f_wrapper = function(.x, .group_key, quo, ...) { + .ref_time_value = min(.x$time_value) + before + .x <- .x[.x$.real,] + .x$.real <- NULL + + data_env = rlang::as_environment(.x) + data_mask = rlang::new_data_mask(bottom = data_env, top = data_env) + data_mask$.data <- rlang::as_data_pronoun(data_mask) + # We'll also install `.x` directly, not as an `rlang_data_pronoun`, so + # that we can, e.g., use more dplyr and epiprocess operations. + data_mask$.x = .x + data_mask$.group_key = .group_key + data_mask$.ref_time_value = .ref_time_value + rlang::eval_tidy(quo, data_mask) + } + return(f_wrapper) + } + + f_wrapper = function(.x, .group_key, .ref_time_value, quo, ...) { + # Convert to environment to standardize between tibble and R6 + # based inputs. In both cases, we should get a simple + # environment with the empty environment as its parent. + data_env = rlang::as_environment(.x) + data_mask = rlang::new_data_mask(bottom = data_env, top = data_env) + data_mask$.data <- rlang::as_data_pronoun(data_mask) + # We'll also install `.x` directly, not as an + # `rlang_data_pronoun`, so that we can, e.g., use more dplyr and + # epiprocess operations. + data_mask$.x = .x + data_mask$.group_key = .group_key + data_mask$.ref_time_value = .ref_time_value + rlang::eval_tidy(quo, data_mask) + } + return(f_wrapper) } - if (is_formula(x)) { - if (length(x) > 2) { - Abort(sprintf("%s must be a one-sided formula", arg), - class = "epiprocess__as_slide_computation__formula_is_twosided", - epiprocess__x = x, - call = call) + if (is_function(x) || is_formula(x)) { + if (is_function(x)) { + # Check that `f` takes enough args + assert_sufficient_f_args(x, ...) + fn <- x + } + + if (is_formula(x)) { + if (length(x) > 2) { + Abort(sprintf("%s must be a one-sided formula", arg), + class = "epiprocess__as_slide_computation__formula_is_twosided", + epiprocess__x = x, + call = call) + } + + env <- f_env(x) + if (!is_environment(env)) { + Abort("Formula must carry an environment.", + class = "epiprocess__as_slide_computation__formula_has_no_env", + epiprocess__x = x, + epiprocess__x_env = env, + arg = arg, call = call) + } + + args <- list( + ... = missing_arg(), + .x = quote(..1), .y = quote(..2), .z = quote(..3), + . = quote(..1), .group_key = quote(..2), .ref_time_value = quote(..3) + ) + fn <- new_function(args, f_rhs(x), env) + fn <- structure(fn, class = c("epiprocess_slide_computation", "function")) } - env <- f_env(x) - if (!is_environment(env)) { - Abort("Formula must carry an environment.", - class = "epiprocess__as_slide_computation__formula_has_no_env", - epiprocess__x = x, - epiprocess__x_env = env, - arg = arg, call = call) + if (calc_ref_time_value) { + f_wrapper = function(.x, .group_key, ...) { + .ref_time_value = min(.x$time_value) + before + .x <- .x[.x$.real,] + .x$.real <- NULL + fn(.x, .group_key, .ref_time_value, ...) + } + return(f_wrapper) } - args <- list( - ... = missing_arg(), - .x = quote(..1), .y = quote(..2), .z = quote(..3), - . = quote(..1), .group_key = quote(..2), .ref_time_value = quote(..3) - ) - fn <- new_function(args, f_rhs(x), env) - fn <- structure(fn, class = c("epiprocess_slide_computation", "function")) return(fn) } - if (is_string(x)) { - return(get(x, envir = env, mode = "function")) - } - Abort(sprintf("Can't convert a %s to a slide computation", class(x)), class = "epiprocess__as_slide_computation__cant_convert_catchall", epiprocess__x = x, From 54b744c7f47bf11b9d451cd6646526f274b35842 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Tue, 27 Jun 2023 11:51:43 -0400 Subject: [PATCH 07/32] deduplicate function/formula and quosure slides In `as_slide_computation`, call `eval_tidy` on the quosure `x` passed directly to `as_slide_computation`, rather than generating an `f_wrapper` computation function that takes the quosure as an argument. The computation function is regenerated each time `slide` is called, with a new quosure, so the computation function doesn't need to be flexible enough to run with different `quo`s. This change makes the function/formula and quosure forks more similar, since `group_modify`, `slide_one_grp` in the `epi_slide` case, and `comp_one_grp` in the `epix_slide` case no longer need a `quo` argument in the quosure fork. To make the two forks fully identical, the quosure fork was changed to pass an empty set of dots to the computation functions. The `as_slide_computation` call and `group_modify` call can now be pulled out of the if/else block. --- R/grouped_epi_archive.R | 185 ++++++++++++++-------------------------- R/slide.R | 45 ++++------ R/utils.R | 13 ++- 3 files changed, 84 insertions(+), 159 deletions(-) diff --git a/R/grouped_epi_archive.R b/R/grouped_epi_archive.R index 30ad9bec..704d597d 100644 --- a/R/grouped_epi_archive.R +++ b/R/grouped_epi_archive.R @@ -186,7 +186,8 @@ grouped_epi_archive = #' object. See the documentation for the wrapper function [`epix_slide()`] for #' details. #' @importFrom data.table key address -#' @importFrom rlang !! !!! enquo quo_is_missing enquos is_quosure sym syms env +#' @importFrom rlang !! !!! enquo quo_is_missing enquos is_quosure sym syms +#' env missing_arg slide = function(f, ..., before, ref_time_values, time_step, new_col_name = "slide_value", as_list_col = FALSE, names_sep = "_", @@ -291,71 +292,8 @@ grouped_epi_archive = !!new_col := .env$comp_value)) } - # If f is not missing, then just go ahead, slide by group - if (!missing(f)) { - f = as_slide_computation(f, calc_ref_time_value = FALSE, ...) - x = purrr::map_dfr(ref_time_values, function(ref_time_value) { - # Ungrouped as-of data; `epi_df` if `all_versions` is `FALSE`, - # `epi_archive` if `all_versions` is `TRUE`: - as_of_raw = private$ungrouped$as_of(ref_time_value, min_time_value = ref_time_value - before, all_versions = all_versions) - - # Set: - # * `as_of_df`, the data.frame/tibble/epi_df/etc. that we will - # `group_modify` as the `.data` argument. Might or might not - # include version column. - # * `group_modify_fn`, the corresponding `.f` argument - if (!all_versions) { - as_of_df = as_of_raw - group_modify_fn = comp_one_grp - } else { - as_of_archive = as_of_raw - # We essentially want to `group_modify` the archive, but - # haven't implemented this method yet. Next best would be - # `group_modify` on its `$DT`, but that has different - # behavior based on whether or not `dtplyr` is loaded. - # Instead, go through an ordinary data frame, trying to avoid - # copies. - if (address(as_of_archive$DT) == address(private$ungrouped$DT)) { - # `as_of` aliased its the full `$DT`; copy before mutating: - as_of_archive$DT <- copy(as_of_archive$DT) - } - dt_key = data.table::key(as_of_archive$DT) - as_of_df = as_of_archive$DT - data.table::setDF(as_of_df) - - # Convert each subgroup chunk to an archive before running the calculation. - group_modify_fn = function(.data_group, .group_key, - f, ..., - ref_time_value, - new_col) { - # .data_group is coming from as_of_df as a tibble, but we - # want to feed `comp_one_grp` an `epi_archive` backed by a - # DT; convert and wrap: - data.table::setattr(.data_group, "sorted", dt_key) - data.table::setDT(.data_group, key=dt_key) - .data_group_archive = as_of_archive$clone() - .data_group_archive$DT = .data_group - comp_one_grp(.data_group_archive, .group_key, f = f, ..., - ref_time_value = ref_time_value, - new_col = new_col - ) - } - } - - return( - dplyr::group_by(as_of_df, dplyr::across(tidyselect::all_of(private$vars)), - .drop=private$drop) %>% - dplyr::group_modify(group_modify_fn, - f = f, ..., - ref_time_value = ref_time_value, - new_col = new_col, - .keep = TRUE) - ) - }) - } - - # Else interpret ... as an expression for tidy evaluation - else { + # Interpret ... as an expression for tidy evaluation + if (missing(f)) { quos = enquos(...) if (length(quos) == 0) { Abort("If `f` is missing then a computation must be specified via `...`.") @@ -364,69 +302,70 @@ grouped_epi_archive = Abort("If `f` is missing then only a single computation can be specified via `...`.") } - quo = quos[[1]] - f = as_slide_computation(quo, calc_ref_time_value = FALSE, ...) + f = quos[[1]] new_col = sym(names(rlang::quos_auto_name(quos))) + ... = missing_arg() + } - x = purrr::map_dfr(ref_time_values, function(ref_time_value) { - # Ungrouped as-of data; `epi_df` if `all_versions` is `FALSE`, - # `epi_archive` if `all_versions` is `TRUE`: - as_of_raw = private$ungrouped$as_of(ref_time_value, min_time_value = ref_time_value - before, all_versions = all_versions) + f = as_slide_computation(f, calc_ref_time_value = FALSE, ...) + x = purrr::map_dfr(ref_time_values, function(ref_time_value) { + # Ungrouped as-of data; `epi_df` if `all_versions` is `FALSE`, + # `epi_archive` if `all_versions` is `TRUE`: + as_of_raw = private$ungrouped$as_of(ref_time_value, min_time_value = ref_time_value - before, all_versions = all_versions) - # Set: - # * `as_of_df`, the data.frame/tibble/epi_df/etc. that we will - # `group_modify` as the `.data` argument. Might or might not - # include version column. - # * `group_modify_fn`, the corresponding `.f` argument - if (!all_versions) { - as_of_df = as_of_raw - group_modify_fn = comp_one_grp - } else { - as_of_archive = as_of_raw - # We essentially want to `group_modify` the archive, but don't - # provide an implementation yet. Next best would be - # `group_modify` on its `$DT`, but that has different behavior - # based on whether or not `dtplyr` is loaded. Instead, go - # through an ordinary data frame, trying to avoid copies. - if (address(as_of_archive$DT) == address(private$ungrouped$DT)) { - # `as_of` aliased its the full `$DT`; copy before mutating: - as_of_archive$DT <- copy(as_of_archive$DT) - } - dt_key = data.table::key(as_of_archive$DT) - as_of_df = as_of_archive$DT - data.table::setDF(as_of_df) + # Set: + # * `as_of_df`, the data.frame/tibble/epi_df/etc. that we will + # `group_modify` as the `.data` argument. Might or might not + # include version column. + # * `group_modify_fn`, the corresponding `.f` argument + if (!all_versions) { + as_of_df = as_of_raw + group_modify_fn = comp_one_grp + } else { + as_of_archive = as_of_raw + # We essentially want to `group_modify` the archive, but + # haven't implemented this method yet. Next best would be + # `group_modify` on its `$DT`, but that has different + # behavior based on whether or not `dtplyr` is loaded. + # Instead, go through an ordinary data frame, trying to avoid + # copies. + if (address(as_of_archive$DT) == address(private$ungrouped$DT)) { + # `as_of` aliased its the full `$DT`; copy before mutating: + as_of_archive$DT <- copy(as_of_archive$DT) + } + dt_key = data.table::key(as_of_archive$DT) + as_of_df = as_of_archive$DT + data.table::setDF(as_of_df) - # Convert each subgroup chunk to an archive before running the calculation. - group_modify_fn = function(.data_group, .group_key, - f, ..., - ref_time_value, - new_col) { - # .data_group is coming from as_of_df as a tibble, but we - # want to feed `comp_one_grp` an `epi_archive` backed by a - # DT; convert and wrap: - data.table::setattr(.data_group, "sorted", dt_key) - data.table::setDT(.data_group, key=dt_key) - .data_group_archive = as_of_archive$clone() - .data_group_archive$DT = .data_group - comp_one_grp(.data_group_archive, .group_key, f = f, quo = quo, - ref_time_value = ref_time_value, - new_col = new_col - ) - } + # Convert each subgroup chunk to an archive before running the calculation. + group_modify_fn = function(.data_group, .group_key, + f, ..., + ref_time_value, + new_col) { + # .data_group is coming from as_of_df as a tibble, but we + # want to feed `comp_one_grp` an `epi_archive` backed by a + # DT; convert and wrap: + data.table::setattr(.data_group, "sorted", dt_key) + data.table::setDT(.data_group, key=dt_key) + .data_group_archive = as_of_archive$clone() + .data_group_archive$DT = .data_group + comp_one_grp(.data_group_archive, .group_key, f = f, ..., + ref_time_value = ref_time_value, + new_col = new_col + ) } + } - return( - dplyr::group_by(as_of_df, dplyr::across(tidyselect::all_of(private$vars)), - .drop=private$drop) %>% - dplyr::group_modify(group_modify_fn, - f = f, quo = quo, - ref_time_value = ref_time_value, - comp_effective_key_vars = comp_effective_key_vars, - new_col = new_col, - .keep = TRUE) - ) - }) - } + return( + dplyr::group_by(as_of_df, dplyr::across(tidyselect::all_of(private$vars)), + .drop=private$drop) %>% + dplyr::group_modify(group_modify_fn, + f = f, ..., + ref_time_value = ref_time_value, + new_col = new_col, + .keep = TRUE) + ) + }) # Unchop/unnest if we need to if (!as_list_col) { diff --git a/R/slide.R b/R/slide.R index 8cff4840..a1029a88 100644 --- a/R/slide.R +++ b/R/slide.R @@ -123,7 +123,7 @@ #' #' @importFrom lubridate days weeks #' @importFrom dplyr bind_rows group_vars filter select -#' @importFrom rlang .data .env !! enquo enquos sym env +#' @importFrom rlang .data .env !! enquo enquos sym env missing_arg #' @export #' @examples #' # slide a 7-day trailing average formula on cases @@ -351,22 +351,8 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, return(mutate(.data_group, !!new_col := slide_values)) } - # If f is not missing, then just go ahead, slide by group - if (!missing(f)) { - f = as_slide_computation(f, calc_ref_time_value = TRUE, before = before, ...) - x = x %>% - group_modify(slide_one_grp, - f = f, ..., - starts = starts, - stops = stops, - time_values = ref_time_values, - all_rows = all_rows, - new_col = new_col, - .keep = FALSE) - } - - # Else interpret ... as an expression for tidy evaluation - else { + # Interpret ... as an expression for tidy evaluation + if (missing(f)) { quos = enquos(...) if (length(quos) == 0) { Abort("If `f` is missing then a computation must be specified via `...`.") @@ -375,20 +361,21 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, Abort("If `f` is missing then only a single computation can be specified via `...`.") } - quo = quos[[1]] + f = quos[[1]] new_col = sym(names(rlang::quos_auto_name(quos))) - - f = as_slide_computation(quo, calc_ref_time_value = TRUE, before = before, ...) - x = x %>% - group_modify(slide_one_grp, - f = f, quo = quo, - starts = starts, - stops = stops, - time_values = ref_time_values, - all_rows = all_rows, - new_col = new_col, - .keep = FALSE) + ... = missing_arg() } + + f = as_slide_computation(f, calc_ref_time_value = TRUE, before = before, ...) + x = x %>% + group_modify(slide_one_grp, + f = f, ..., + starts = starts, + stops = stops, + time_values = ref_time_values, + all_rows = all_rows, + new_col = new_col, + .keep = FALSE) # Unnest if we need to, and return if (!as_list_col) { diff --git a/R/utils.R b/R/utils.R index 740817cf..4022734f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -253,7 +253,7 @@ as_slide_computation <- function(x, # A quosure is a type of formula, so be careful with `if` logic here. if (is_quosure(x)) { if (calc_ref_time_value) { - f_wrapper = function(.x, .group_key, quo, ...) { + f_wrapper = function(.x, .group_key, ...) { .ref_time_value = min(.x$time_value) + before .x <- .x[.x$.real,] .x$.real <- NULL @@ -266,25 +266,24 @@ as_slide_computation <- function(x, data_mask$.x = .x data_mask$.group_key = .group_key data_mask$.ref_time_value = .ref_time_value - rlang::eval_tidy(quo, data_mask) + rlang::eval_tidy(x, data_mask) } return(f_wrapper) } - f_wrapper = function(.x, .group_key, .ref_time_value, quo, ...) { + f_wrapper = function(.x, .group_key, .ref_time_value, ...) { # Convert to environment to standardize between tibble and R6 # based inputs. In both cases, we should get a simple # environment with the empty environment as its parent. data_env = rlang::as_environment(.x) data_mask = rlang::new_data_mask(bottom = data_env, top = data_env) data_mask$.data <- rlang::as_data_pronoun(data_mask) - # We'll also install `.x` directly, not as an - # `rlang_data_pronoun`, so that we can, e.g., use more dplyr and - # epiprocess operations. + # We'll also install `.x` directly, not as an `rlang_data_pronoun`, so + # that we can, e.g., use more dplyr and epiprocess operations. data_mask$.x = .x data_mask$.group_key = .group_key data_mask$.ref_time_value = .ref_time_value - rlang::eval_tidy(quo, data_mask) + rlang::eval_tidy(x, data_mask) } return(f_wrapper) } From 0666c8ac8e50976a96d0dd46b3e791f0d126db64 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Tue, 27 Jun 2023 11:58:37 -0400 Subject: [PATCH 08/32] build docs --- man/epi_slide.Rd | 4 ++-- man/epix_slide.Rd | 4 ++-- man/reexports.Rd | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/man/epi_slide.Rd b/man/epi_slide.Rd index 33c3a7fb..c0ff4e7b 100644 --- a/man/epi_slide.Rd +++ b/man/epi_slide.Rd @@ -76,9 +76,9 @@ contain the derivative values. Default is "slide_value"; note that setting \code{new_col_name} equal to an existing column name will overwrite this column.} \item{as_list_col}{Should the slide results be held in a list column, or be -\link[tidyr:chop]{unchopped}/\link[tidyr:unnest]{unnested}? Default is \code{FALSE}, +\link[tidyr:chop]{unchopped}/\link[tidyr:nest]{unnested}? Default is \code{FALSE}, in which case a list object returned by \code{f} would be unnested (using -\code{\link[tidyr:unnest]{tidyr::unnest()}}), and, if the slide computations output data frames, +\code{\link[tidyr:nest]{tidyr::unnest()}}), and, if the slide computations output data frames, the names of the resulting columns are given by prepending \code{new_col_name} to the names of the list elements.} diff --git a/man/epix_slide.Rd b/man/epix_slide.Rd index c0f07d88..2b254876 100644 --- a/man/epix_slide.Rd +++ b/man/epix_slide.Rd @@ -80,9 +80,9 @@ contain the derivative values. Default is "slide_value"; note that setting \code{new_col_name} equal to an existing column name will overwrite this column.} \item{as_list_col}{Should the slide results be held in a list column, or be -\link[tidyr:chop]{unchopped}/\link[tidyr:unnest]{unnested}? Default is \code{FALSE}, +\link[tidyr:chop]{unchopped}/\link[tidyr:nest]{unnested}? Default is \code{FALSE}, in which case a list object returned by \code{f} would be unnested (using -\code{\link[tidyr:unnest]{tidyr::unnest()}}), and, if the slide computations output data frames, +\code{\link[tidyr:nest]{tidyr::unnest()}}), and, if the slide computations output data frames, the names of the resulting columns are given by prepending \code{new_col_name} to the names of the list elements.} diff --git a/man/reexports.Rd b/man/reexports.Rd index 46e961d9..b633e86c 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -23,7 +23,7 @@ below to see their documentation. \describe{ \item{dplyr}{\code{\link[dplyr]{arrange}}, \code{\link[dplyr]{filter}}, \code{\link[dplyr]{group_by}}, \code{\link[dplyr:group_map]{group_modify}}, \code{\link[dplyr]{mutate}}, \code{\link[dplyr]{relocate}}, \code{\link[dplyr]{rename}}, \code{\link[dplyr]{slice}}, \code{\link[dplyr:group_by]{ungroup}}} - \item{tidyr}{\code{\link[tidyr]{unnest}}} + \item{tidyr}{\code{\link[tidyr:nest]{unnest}}} \item{tsibble}{\code{\link[tsibble:as-tsibble]{as_tsibble}}} }} From 30ff15136e23f3084a1c0759196d035b4f9d7474 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Tue, 27 Jun 2023 16:08:21 -0400 Subject: [PATCH 09/32] comments --- R/grouped_epi_archive.R | 2 +- R/slide.R | 2 +- R/utils.R | 10 +++++++--- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/R/grouped_epi_archive.R b/R/grouped_epi_archive.R index 704d597d..2a18a419 100644 --- a/R/grouped_epi_archive.R +++ b/R/grouped_epi_archive.R @@ -292,7 +292,7 @@ grouped_epi_archive = !!new_col := .env$comp_value)) } - # Interpret ... as an expression for tidy evaluation + # If `f` is missing, interpret ... as an expression for tidy evaluation if (missing(f)) { quos = enquos(...) if (length(quos) == 0) { diff --git a/R/slide.R b/R/slide.R index a1029a88..2cd1aed7 100644 --- a/R/slide.R +++ b/R/slide.R @@ -351,7 +351,7 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, return(mutate(.data_group, !!new_col := slide_values)) } - # Interpret ... as an expression for tidy evaluation + # If `f` is missing, interpret ... as an expression for tidy evaluation if (missing(f)) { quos = enquos(...) if (length(quos) == 0) { diff --git a/R/utils.R b/R/utils.R index 4022734f..3a3328b1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -215,6 +215,11 @@ assert_sufficient_f_args <- function(f, ...) { #' scoping issues involved. Package developers should avoid #' supplying functions by name and instead supply them by value. #' +#' @param before how far `before` each `ref_time_value` the sliding window +#' should extend, as specified in the parent `epi[x]_slide` call Must be a +#' single, non-`NA`, non-negative,[integer-compatible] +#' [vctrs::vec_cast] number of time steps. Used only when +#' `calc_ref_time_value` is `TRUE` #' @param calc_ref_time_value Boolean indicating whether the computation #' function should include a step to calculate `ref_time_value` based on the #' contents of the group data `.x`. This is used in `epi_slide`. When this @@ -244,8 +249,8 @@ assert_sufficient_f_args <- function(f, ...) { #' #' @noRd as_slide_computation <- function(x, - calc_ref_time_value = FALSE, before, + calc_ref_time_value = FALSE, env = global_env(), ..., arg = caller_arg(x), @@ -261,8 +266,7 @@ as_slide_computation <- function(x, data_env = rlang::as_environment(.x) data_mask = rlang::new_data_mask(bottom = data_env, top = data_env) data_mask$.data <- rlang::as_data_pronoun(data_mask) - # We'll also install `.x` directly, not as an `rlang_data_pronoun`, so - # that we can, e.g., use more dplyr and epiprocess operations. + # Also install `.x` directly. data_mask$.x = .x data_mask$.group_key = .group_key data_mask$.ref_time_value = .ref_time_value From 6a594f15ea03424a59a560cace73c98bc4e1ac4b Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 28 Jun 2023 09:47:12 -0400 Subject: [PATCH 10/32] comments --- R/utils.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 3a3328b1..b1b32a78 100644 --- a/R/utils.R +++ b/R/utils.R @@ -255,7 +255,8 @@ as_slide_computation <- function(x, ..., arg = caller_arg(x), call = caller_env()) { - # A quosure is a type of formula, so be careful with `if` logic here. + # A quosure is a type of formula, so be careful with the order and contents + # of the conditional logic here. if (is_quosure(x)) { if (calc_ref_time_value) { f_wrapper = function(.x, .group_key, ...) { From a18be4992cb9b73285ebf0543ac58ccfaeae651c Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 28 Jun 2023 13:21:59 -0400 Subject: [PATCH 11/32] as_slide_computation documentation --- R/utils.R | 42 ++++++++++++++++++++++++------------------ 1 file changed, 24 insertions(+), 18 deletions(-) diff --git a/R/utils.R b/R/utils.R index b1b32a78..5a19ec6f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -181,39 +181,45 @@ assert_sufficient_f_args <- function(f, ...) { } } -#' Convert to function +#' Generate a `epi[x]_slide` computation function from a function, formula, or quosure #' -#' @description -#' `as_slide_computation()` transforms a one-sided formula into a function. -#' This powers the lambda syntax in packages like purrr. +#' @description `as_slide_computation()` transforms a one-sided formula or a +#' quosure into a function; functions are returned as-is or with light +#' modifications to calculate `ref_time_value`. #' #' This code and documentation borrows heavily from [`rlang::as_function`] #' (https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L343-L427). #' #' This code extends `rlang::as_function` to create functions that take three -#' arguments. The arguments can be accessed via the idiomatic `.x`, `.y`, -#' etc, positional references (`..1`, `..2`, etc), and also by `epi -#' [x]_slide`-specific names. +#' arguments. The arguments can be accessed via the idiomatic `.`, `.x`, and +#' `.y`, extended to include `.z`; positional references `..1` and `..2`, +#' extended to include `..3`; and also by `epi[x]_slide`-specific names +#' `.group_key` and `.ref_time_value`. #' #' @source https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L343-L427 #' -#' @param x A function or formula. +#' @param x A function, one-sided formula, or quosure. #' -#' If a **function**, it is used as is. +#' If a **function** and `calc_ref_time_value` is `FALSE`, the function is +#' returned as-is, with no modifications. If `calc_ref_time_value` is +#' `TRUE`, a wrapper function is returned. The wrapper calculates +#' `ref_time_value` based on the input data and passes it to the original +#' function. #' -#' If a **formula**, e.g. `~ mean(.x$cases)`, it is converted to a function with up -#' to three arguments: `.x` (single argument), or `.x` and `.y` +#' If a **formula**, e.g. `~ mean(.x$cases)`, it is converted to a function +#' with up to three arguments: `.x` (single argument), or `.x` and `.y` #' (two arguments), or `.x`, `.y`, and `.z` (three arguments). The `.` #' placeholder can be used instead of `.x`, `.group_key` can be used in #' place of `.y`, and `.ref_time_value` can be used in place of `.z`. This #' allows you to create very compact anonymous functions (lambdas) with up -#' to three inputs. Functions created from formulas have a special class. Use -#' `rlang::is_lambda()` to test for it. -#' -#' If a **string**, the function is looked up in `env`. Note that -#' this interface is strictly for user convenience because of the -#' scoping issues involved. Package developers should avoid -#' supplying functions by name and instead supply them by value. +#' to three inputs. Functions created from formulas have a special class. +#' Use `rlang::is_lambda()` to test for it. +#' +#' If a **quosure**, in the case that `f` was not provided to the parent +#' `epi[x]_slide` call and the `...` is interpreted as an expression for +#' tidy evaluation, it is evaluated within a wrapper function. The wrapper +#' sets up object access via a data mask. `ref_time_value` is calculated +#' depending on the `cal_ref_time_value` setting. #' #' @param before how far `before` each `ref_time_value` the sliding window #' should extend, as specified in the parent `epi[x]_slide` call Must be a From 894ba234fc044466ccca93df439f1c6fe04de075 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 28 Jun 2023 16:15:51 -0400 Subject: [PATCH 12/32] drop env arg; as_slide_computation no longer handles functions-as-strings --- R/utils.R | 3 --- 1 file changed, 3 deletions(-) diff --git a/R/utils.R b/R/utils.R index 5a19ec6f..48d4e97c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -235,8 +235,6 @@ assert_sufficient_f_args <- function(f, ...) { #' computation only takes two of the standard arguments, group data and #' group key(s), plus any extra arguments. The `ref_time_value` argument is #' unnecessary since its value is being calculated within the computation. -#' @param env Environment in which to fetch the function in case `x` -#' is a string. #' @inheritParams rlang::args_dots_empty #' @inheritParams rlang::args_error_context #' @examples @@ -257,7 +255,6 @@ assert_sufficient_f_args <- function(f, ...) { as_slide_computation <- function(x, before, calc_ref_time_value = FALSE, - env = global_env(), ..., arg = caller_arg(x), call = caller_env()) { From 7a1e0ba57c81fcdfd73cfe906fdd6a792df056ea Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 28 Jun 2023 16:16:26 -0400 Subject: [PATCH 13/32] periods --- R/utils.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utils.R b/R/utils.R index 48d4e97c..fd01b325 100644 --- a/R/utils.R +++ b/R/utils.R @@ -222,10 +222,10 @@ assert_sufficient_f_args <- function(f, ...) { #' depending on the `cal_ref_time_value` setting. #' #' @param before how far `before` each `ref_time_value` the sliding window -#' should extend, as specified in the parent `epi[x]_slide` call Must be a +#' should extend, as specified in the parent `epi[x]_slide` call. Must be a #' single, non-`NA`, non-negative,[integer-compatible] #' [vctrs::vec_cast] number of time steps. Used only when -#' `calc_ref_time_value` is `TRUE` +#' `calc_ref_time_value` is `TRUE`. #' @param calc_ref_time_value Boolean indicating whether the computation #' function should include a step to calculate `ref_time_value` based on the #' contents of the group data `.x`. This is used in `epi_slide`. When this From 93e965fb5799ef0c189f131a5ab2b38bb5992f51 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 28 Jun 2023 16:43:18 -0400 Subject: [PATCH 14/32] document non-empty dots and update function imports --- NAMESPACE | 3 --- R/utils.R | 9 +++++---- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 1d8affef..4f9b8151 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -96,19 +96,16 @@ importFrom(rlang,.env) importFrom(rlang,arg_match) importFrom(rlang,caller_arg) importFrom(rlang,caller_env) -importFrom(rlang,check_dots_empty0) importFrom(rlang,enquo) importFrom(rlang,enquos) importFrom(rlang,env) importFrom(rlang,f_env) importFrom(rlang,f_rhs) -importFrom(rlang,global_env) importFrom(rlang,is_environment) importFrom(rlang,is_formula) importFrom(rlang,is_function) importFrom(rlang,is_missing) importFrom(rlang,is_quosure) -importFrom(rlang,is_string) importFrom(rlang,missing_arg) importFrom(rlang,new_function) importFrom(rlang,quo_is_missing) diff --git a/R/utils.R b/R/utils.R index fd01b325..5951c9a6 100644 --- a/R/utils.R +++ b/R/utils.R @@ -235,7 +235,9 @@ assert_sufficient_f_args <- function(f, ...) { #' computation only takes two of the standard arguments, group data and #' group key(s), plus any extra arguments. The `ref_time_value` argument is #' unnecessary since its value is being calculated within the computation. -#' @inheritParams rlang::args_dots_empty +#' @param ... Additional arguments to pass to the function or formula +#' specified via `x`. If `x` is a quosure, any arguments passed via `...` +#' will be ignored. #' @inheritParams rlang::args_error_context #' @examples #' f <- as_slide_computation(~ .x + 1) @@ -247,9 +249,8 @@ assert_sufficient_f_args <- function(f, ...) { #' h <- as_slide_computation(~ .x - .group_key) #' h(6, 3) #' -#' @importFrom rlang check_dots_empty0 is_function new_function f_env -#' is_environment missing_arg f_rhs is_string is_formula caller_arg -#' caller_env global_env +#' @importFrom rlang is_function new_function f_env is_environment missing_arg +#' f_rhs is_formula caller_arg caller_env #' #' @noRd as_slide_computation <- function(x, From a31759404de2d726581721f1f70e82a536207ef1 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 28 Jun 2023 17:01:01 -0400 Subject: [PATCH 15/32] make wrapper language clearer; add dots to ref_time_value --- R/utils.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/utils.R b/R/utils.R index 5951c9a6..1a979ad9 100644 --- a/R/utils.R +++ b/R/utils.R @@ -202,9 +202,9 @@ assert_sufficient_f_args <- function(f, ...) { #' #' If a **function** and `calc_ref_time_value` is `FALSE`, the function is #' returned as-is, with no modifications. If `calc_ref_time_value` is -#' `TRUE`, a wrapper function is returned. The wrapper calculates -#' `ref_time_value` based on the input data and passes it to the original -#' function. +#' `TRUE`, a function wrapping the original function is returned. The +#' wrapper calculates `.ref_time_value` based on the input data and passes +#' it to the original function. #' #' If a **formula**, e.g. `~ mean(.x$cases)`, it is converted to a function #' with up to three arguments: `.x` (single argument), or `.x` and `.y` @@ -218,10 +218,10 @@ assert_sufficient_f_args <- function(f, ...) { #' If a **quosure**, in the case that `f` was not provided to the parent #' `epi[x]_slide` call and the `...` is interpreted as an expression for #' tidy evaluation, it is evaluated within a wrapper function. The wrapper -#' sets up object access via a data mask. `ref_time_value` is calculated +#' sets up object access via a data mask. `.ref_time_value` is calculated #' depending on the `cal_ref_time_value` setting. #' -#' @param before how far `before` each `ref_time_value` the sliding window +#' @param before How far `before` each `ref_time_value` the sliding window #' should extend, as specified in the parent `epi[x]_slide` call. Must be a #' single, non-`NA`, non-negative,[integer-compatible] #' [vctrs::vec_cast] number of time steps. Used only when From d0acab48011c68e9d09acf59d925b8c8d907d1a9 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Thu, 29 Jun 2023 08:45:04 -0400 Subject: [PATCH 16/32] rename as_slide_computation func input to avoid name collisions --- R/utils.R | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/R/utils.R b/R/utils.R index 1a979ad9..7d3943e0 100644 --- a/R/utils.R +++ b/R/utils.R @@ -198,7 +198,7 @@ assert_sufficient_f_args <- function(f, ...) { #' #' @source https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L343-L427 #' -#' @param x A function, one-sided formula, or quosure. +#' @param .f A function, one-sided formula, or quosure. #' #' If a **function** and `calc_ref_time_value` is `FALSE`, the function is #' returned as-is, with no modifications. If `calc_ref_time_value` is @@ -253,15 +253,15 @@ assert_sufficient_f_args <- function(f, ...) { #' f_rhs is_formula caller_arg caller_env #' #' @noRd -as_slide_computation <- function(x, +as_slide_computation <- function(.f, before, calc_ref_time_value = FALSE, ..., - arg = caller_arg(x), + arg = caller_arg(.f), call = caller_env()) { # A quosure is a type of formula, so be careful with the order and contents # of the conditional logic here. - if (is_quosure(x)) { + if (is_quosure(.f)) { if (calc_ref_time_value) { f_wrapper = function(.x, .group_key, ...) { .ref_time_value = min(.x$time_value) + before @@ -275,7 +275,7 @@ as_slide_computation <- function(x, data_mask$.x = .x data_mask$.group_key = .group_key data_mask$.ref_time_value = .ref_time_value - rlang::eval_tidy(x, data_mask) + rlang::eval_tidy(.f, data_mask) } return(f_wrapper) } @@ -292,32 +292,32 @@ as_slide_computation <- function(x, data_mask$.x = .x data_mask$.group_key = .group_key data_mask$.ref_time_value = .ref_time_value - rlang::eval_tidy(x, data_mask) + rlang::eval_tidy(.f, data_mask) } return(f_wrapper) } - if (is_function(x) || is_formula(x)) { - if (is_function(x)) { + if (is_function(.f) || is_formula(.f)) { + if (is_function(.f)) { # Check that `f` takes enough args - assert_sufficient_f_args(x, ...) - fn <- x + assert_sufficient_f_args(.f, ...) + fn <- .f } - if (is_formula(x)) { - if (length(x) > 2) { + if (is_formula(.f)) { + if (length(.f) > 2) { Abort(sprintf("%s must be a one-sided formula", arg), class = "epiprocess__as_slide_computation__formula_is_twosided", - epiprocess__x = x, + epiprocess__f = .f, call = call) } - env <- f_env(x) + env <- f_env(.f) if (!is_environment(env)) { Abort("Formula must carry an environment.", class = "epiprocess__as_slide_computation__formula_has_no_env", - epiprocess__x = x, - epiprocess__x_env = env, + epiprocess__f = .f, + epiprocess__f_env = env, arg = arg, call = call) } @@ -326,7 +326,7 @@ as_slide_computation <- function(x, .x = quote(..1), .y = quote(..2), .z = quote(..3), . = quote(..1), .group_key = quote(..2), .ref_time_value = quote(..3) ) - fn <- new_function(args, f_rhs(x), env) + fn <- new_function(args, f_rhs(.f), env) fn <- structure(fn, class = c("epiprocess_slide_computation", "function")) } @@ -343,10 +343,10 @@ as_slide_computation <- function(x, return(fn) } - Abort(sprintf("Can't convert a %s to a slide computation", class(x)), + Abort(sprintf("Can't convert a %s to a slide computation", class(.f)), class = "epiprocess__as_slide_computation__cant_convert_catchall", - epiprocess__x = x, - epiprocess__x_class = class(x), + epiprocess__f = .f, + epiprocess__f_class = class(.f), arg = arg, call = call) } From 00e967d72ba7e50c58ac1256dc2cbc614610a257 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Thu, 29 Jun 2023 09:07:21 -0400 Subject: [PATCH 17/32] move ref_time_value calculation to a wrapper in `epi_slide` Drop `calc_ref_time_value` and `before` args to `as_slide_computation`; they were only used to calculate `.ref_time_value` for `epi_slide` computations. --- R/grouped_epi_archive.R | 2 +- R/slide.R | 12 ++++- R/utils.R | 115 ++++++++++++---------------------------- 3 files changed, 44 insertions(+), 85 deletions(-) diff --git a/R/grouped_epi_archive.R b/R/grouped_epi_archive.R index 2a18a419..71f25847 100644 --- a/R/grouped_epi_archive.R +++ b/R/grouped_epi_archive.R @@ -307,7 +307,7 @@ grouped_epi_archive = ... = missing_arg() } - f = as_slide_computation(f, calc_ref_time_value = FALSE, ...) + f = as_slide_computation(f, ...) x = purrr::map_dfr(ref_time_values, function(ref_time_value) { # Ungrouped as-of data; `epi_df` if `all_versions` is `FALSE`, # `epi_archive` if `all_versions` is `TRUE`: diff --git a/R/slide.R b/R/slide.R index 2cd1aed7..0325244d 100644 --- a/R/slide.R +++ b/R/slide.R @@ -366,10 +366,18 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, ... = missing_arg() } - f = as_slide_computation(f, calc_ref_time_value = TRUE, before = before, ...) + f = as_slide_computation(f, ...) + # Create a wrapper that calculates and passes `.ref_time_value` to the + # computation. + f_wrapper = function(.x, .group_key, ...) { + .ref_time_value = min(.x$time_value) + before + .x <- .x[.x$.real,] + .x$.real <- NULL + f(.x, .group_key, .ref_time_value, ...) + } x = x %>% group_modify(slide_one_grp, - f = f, ..., + f = f_wrapper, ..., starts = starts, stops = stops, time_values = ref_time_values, diff --git a/R/utils.R b/R/utils.R index 7d3943e0..0884c73b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -200,11 +200,8 @@ assert_sufficient_f_args <- function(f, ...) { #' #' @param .f A function, one-sided formula, or quosure. #' -#' If a **function** and `calc_ref_time_value` is `FALSE`, the function is -#' returned as-is, with no modifications. If `calc_ref_time_value` is -#' `TRUE`, a function wrapping the original function is returned. The -#' wrapper calculates `.ref_time_value` based on the input data and passes -#' it to the original function. +#' If a **function**, the function is returned as-is, with no +#' modifications. #' #' If a **formula**, e.g. `~ mean(.x$cases)`, it is converted to a function #' with up to three arguments: `.x` (single argument), or `.x` and `.y` @@ -218,23 +215,8 @@ assert_sufficient_f_args <- function(f, ...) { #' If a **quosure**, in the case that `f` was not provided to the parent #' `epi[x]_slide` call and the `...` is interpreted as an expression for #' tidy evaluation, it is evaluated within a wrapper function. The wrapper -#' sets up object access via a data mask. `.ref_time_value` is calculated -#' depending on the `cal_ref_time_value` setting. -#' -#' @param before How far `before` each `ref_time_value` the sliding window -#' should extend, as specified in the parent `epi[x]_slide` call. Must be a -#' single, non-`NA`, non-negative,[integer-compatible] -#' [vctrs::vec_cast] number of time steps. Used only when -#' `calc_ref_time_value` is `TRUE`. -#' @param calc_ref_time_value Boolean indicating whether the computation -#' function should include a step to calculate `ref_time_value` based on the -#' contents of the group data `.x`. This is used in `epi_slide`. When this -#' flag is `FALSE`, as is the default, the resulting computation takes the -#' three standard arguments, group data, group key(s), and reference time -#' value, plus any extra arguments. When this flag is `TRUE`, the resulting -#' computation only takes two of the standard arguments, group data and -#' group key(s), plus any extra arguments. The `ref_time_value` argument is -#' unnecessary since its value is being calculated within the computation. +#' sets up object access via a data mask. +#' #' @param ... Additional arguments to pass to the function or formula #' specified via `x`. If `x` is a quosure, any arguments passed via `...` #' will be ignored. @@ -254,33 +236,13 @@ assert_sufficient_f_args <- function(f, ...) { #' #' @noRd as_slide_computation <- function(.f, - before, - calc_ref_time_value = FALSE, ..., arg = caller_arg(.f), call = caller_env()) { # A quosure is a type of formula, so be careful with the order and contents # of the conditional logic here. if (is_quosure(.f)) { - if (calc_ref_time_value) { - f_wrapper = function(.x, .group_key, ...) { - .ref_time_value = min(.x$time_value) + before - .x <- .x[.x$.real,] - .x$.real <- NULL - - data_env = rlang::as_environment(.x) - data_mask = rlang::new_data_mask(bottom = data_env, top = data_env) - data_mask$.data <- rlang::as_data_pronoun(data_mask) - # Also install `.x` directly. - data_mask$.x = .x - data_mask$.group_key = .group_key - data_mask$.ref_time_value = .ref_time_value - rlang::eval_tidy(.f, data_mask) - } - return(f_wrapper) - } - - f_wrapper = function(.x, .group_key, .ref_time_value, ...) { + fn = function(.x, .group_key, .ref_time_value, ...) { # Convert to environment to standardize between tibble and R6 # based inputs. In both cases, we should get a simple # environment with the empty environment as its parent. @@ -294,52 +256,41 @@ as_slide_computation <- function(.f, data_mask$.ref_time_value = .ref_time_value rlang::eval_tidy(.f, data_mask) } - return(f_wrapper) - } - - if (is_function(.f) || is_formula(.f)) { - if (is_function(.f)) { - # Check that `f` takes enough args - assert_sufficient_f_args(.f, ...) - fn <- .f - } - if (is_formula(.f)) { - if (length(.f) > 2) { - Abort(sprintf("%s must be a one-sided formula", arg), - class = "epiprocess__as_slide_computation__formula_is_twosided", - epiprocess__f = .f, - call = call) - } + return(fn) + } - env <- f_env(.f) - if (!is_environment(env)) { - Abort("Formula must carry an environment.", - class = "epiprocess__as_slide_computation__formula_has_no_env", - epiprocess__f = .f, - epiprocess__f_env = env, - arg = arg, call = call) - } + if (is_function(.f)) { + # Check that `f` takes enough args + assert_sufficient_f_args(.f, ...) + return(.f) + } - args <- list( - ... = missing_arg(), - .x = quote(..1), .y = quote(..2), .z = quote(..3), - . = quote(..1), .group_key = quote(..2), .ref_time_value = quote(..3) - ) - fn <- new_function(args, f_rhs(.f), env) - fn <- structure(fn, class = c("epiprocess_slide_computation", "function")) + if (is_formula(.f)) { + if (length(.f) > 2) { + Abort(sprintf("%s must be a one-sided formula", arg), + class = "epiprocess__as_slide_computation__formula_is_twosided", + epiprocess__f = .f, + call = call) } - if (calc_ref_time_value) { - f_wrapper = function(.x, .group_key, ...) { - .ref_time_value = min(.x$time_value) + before - .x <- .x[.x$.real,] - .x$.real <- NULL - fn(.x, .group_key, .ref_time_value, ...) - } - return(f_wrapper) + env <- f_env(.f) + if (!is_environment(env)) { + Abort("Formula must carry an environment.", + class = "epiprocess__as_slide_computation__formula_has_no_env", + epiprocess__f = .f, + epiprocess__f_env = env, + arg = arg, call = call) } + args <- list( + ... = missing_arg(), + .x = quote(..1), .y = quote(..2), .z = quote(..3), + . = quote(..1), .group_key = quote(..2), .ref_time_value = quote(..3) + ) + fn <- new_function(args, f_rhs(.f), env) + fn <- structure(fn, class = c("epiprocess_slide_computation", "function")) + return(fn) } From 9d3c01cc22d52b9e6d83ae0ecdaec6e247c01fba Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 28 Jun 2023 16:13:59 -0400 Subject: [PATCH 18/32] add rlang authors as contributors --- DESCRIPTION | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2d62e90c..2ade22f9 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,7 +14,9 @@ Authors@R: c( person("Quang", "Nguyen", role = "ctb"), person("Evan", "Ray", role = "aut"), person("Dmitry", "Shemetov", role = "ctb"), - person("Ryan", "Tibshirani", , "ryantibs@cmu.edu", role = c("aut", "cre")) + person("Ryan", "Tibshirani", , "ryantibs@cmu.edu", role = c("aut", "cre")), + person("Lionel", "Henry", role = "ctb", comment = "Author of included rlang fragments"), + person("Hadley", "Wickham", role = "ctb", comment = "Author of included rlang fragments") ) Description: This package introduces a common data structure for epidemiological data reported by location and time, provides another data structure to From c400cd5e23f727e579ee6456c1bcaa82c1a4af2a Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 28 Jun 2023 16:14:30 -0400 Subject: [PATCH 19/32] add rlang license to source and describe our changes --- R/utils.R | 49 +++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 45 insertions(+), 4 deletions(-) diff --git a/R/utils.R b/R/utils.R index 0884c73b..aece6324 100644 --- a/R/utils.R +++ b/R/utils.R @@ -187,16 +187,57 @@ assert_sufficient_f_args <- function(f, ...) { #' quosure into a function; functions are returned as-is or with light #' modifications to calculate `ref_time_value`. #' -#' This code and documentation borrows heavily from [`rlang::as_function`] -#' (https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L343-L427). -#' #' This code extends `rlang::as_function` to create functions that take three #' arguments. The arguments can be accessed via the idiomatic `.`, `.x`, and #' `.y`, extended to include `.z`; positional references `..1` and `..2`, #' extended to include `..3`; and also by `epi[x]_slide`-specific names #' `.group_key` and `.ref_time_value`. #' -#' @source https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L343-L427 +#' @source #' This code and documentation are based on the [`as_function`] +#' (https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L343-L427) +#' function from Hadley Wickham's `rlang` package. +#' +#' Below is the orginal license for the `rlang` package. +#' +#' +#' # MIT License +#' +#' Copyright (c) 2020 rlang authors +#' +#' Permission is hereby granted, free of charge, to any person obtaining a copy +#' of this software and associated documentation files (the "Software"), to deal +#' in the Software without restriction, including without limitation the rights +#' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +#' copies of the Software, and to permit persons to whom the Software is +#' furnished to do so, subject to the following conditions: +#' +#' The above copyright notice and this permission notice shall be included in all +#' copies or substantial portions of the Software. +#' +#' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +#' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +#' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +#' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +#' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +#' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +#' SOFTWARE. +#' +#' +#' Portions of the original code used in this adaptation: +#' 1. Much of the documentation and examples +#' 2. The general flow of the function, including branching conditions +#' 3. Error conditions and wording +#' 4. The chunk converting a formula into a function, see +#' https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L411-L418 +#' +#' Changes made include: +#' 1. Updates to documentation due to new functionality +#' 2. The removal of function-as-string processing logic and helper arg +#' `env` +#' 3. The addition of an output function wrapper that defines a data mask +#' for evaluating quosures +#' 4. Calling an argument-checking function +#' 5. Replacing rlang error functions with internal error functions #' #' @param .f A function, one-sided formula, or quosure. #' From dbd5b181d5dd425968624d5e90123b3771c9d81b Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Wed, 28 Jun 2023 17:23:55 -0400 Subject: [PATCH 20/32] add copyright file and "person" in description --- DESCRIPTION | 4 +++- inst/COPYRIGHTS | 26 ++++++++++++++++++++++++++ 2 files changed, 29 insertions(+), 1 deletion(-) create mode 100644 inst/COPYRIGHTS diff --git a/DESCRIPTION b/DESCRIPTION index 2ade22f9..0f5faae5 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,13 +16,15 @@ Authors@R: c( person("Dmitry", "Shemetov", role = "ctb"), person("Ryan", "Tibshirani", , "ryantibs@cmu.edu", role = c("aut", "cre")), person("Lionel", "Henry", role = "ctb", comment = "Author of included rlang fragments"), - person("Hadley", "Wickham", role = "ctb", comment = "Author of included rlang fragments") + person("Hadley", "Wickham", role = "ctb", comment = "Author of included rlang fragments"), + person("Posit", role = "cph", comment = "Copyright holder of included rlang fragments") ) Description: This package introduces a common data structure for epidemiological data reported by location and time, provides another data structure to work with revisions to these data sets over time, and offers associated utilities to perform basic signal processing tasks. License: MIT + file LICENSE +Copyright: file COPYRIGHTS Imports: cli, data.table, diff --git a/inst/COPYRIGHTS b/inst/COPYRIGHTS new file mode 100644 index 00000000..2b0f6b83 --- /dev/null +++ b/inst/COPYRIGHTS @@ -0,0 +1,26 @@ +Copyright for most of the included code is held by the Delphi group. + +Posit is the copyright holder for `rlang` fragments included in the +`as_slide_computation` function in `utils.R` under the following license. + +# MIT License + +Copyright (c) 2020 rlang authors + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. From 19185f448037464bc9685848f3a5259ec301ca17 Mon Sep 17 00:00:00 2001 From: David Weber Date: Thu, 13 Jul 2023 16:19:12 -0700 Subject: [PATCH 21/32] ci: stop building pkgdown on forks this makes it so that pkgdown will only run on branches owned by cmu-delphi directly --- .github/workflows/pkgdown.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 12e352b3..26a7b1b5 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -15,6 +15,7 @@ name: pkgdown jobs: pkgdown: + if: github.repository_owner == 'cmu-delphi' runs-on: ubuntu-latest # Only restrict concurrency for non-PR jobs concurrency: From 54eacf3f543242d211e23e5bf1545ee392ffab90 Mon Sep 17 00:00:00 2001 From: nmdefries <42820733+nmdefries@users.noreply.github.com> Date: Mon, 24 Jul 2023 11:15:29 -0400 Subject: [PATCH 22/32] fix documentation and DESCRIPTION typos Co-authored-by: brookslogan --- DESCRIPTION | 2 +- R/utils.R | 4 ++-- inst/COPYRIGHTS | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0f5faae5..d9a8dea6 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,7 +24,7 @@ Description: This package introduces a common data structure for epidemiological work with revisions to these data sets over time, and offers associated utilities to perform basic signal processing tasks. License: MIT + file LICENSE -Copyright: file COPYRIGHTS +Copyright: file inst/COPYRIGHTS Imports: cli, data.table, diff --git a/R/utils.R b/R/utils.R index aece6324..026e10ff 100644 --- a/R/utils.R +++ b/R/utils.R @@ -193,11 +193,11 @@ assert_sufficient_f_args <- function(f, ...) { #' extended to include `..3`; and also by `epi[x]_slide`-specific names #' `.group_key` and `.ref_time_value`. #' -#' @source #' This code and documentation are based on the [`as_function`] +#' @source This code and documentation are based on [`as_function`] #' (https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L343-L427) #' function from Hadley Wickham's `rlang` package. #' -#' Below is the orginal license for the `rlang` package. +#' Below is the original license for the `rlang` package. #' #' #' # MIT License diff --git a/inst/COPYRIGHTS b/inst/COPYRIGHTS index 2b0f6b83..d7997d7e 100644 --- a/inst/COPYRIGHTS +++ b/inst/COPYRIGHTS @@ -1,7 +1,7 @@ Copyright for most of the included code is held by the Delphi group. Posit is the copyright holder for `rlang` fragments included in the -`as_slide_computation` function in `utils.R` under the following license. +`as_slide_computation` function and documentation in `utils.R` under the following license. # MIT License From 398de24b388db0ef2cc87558a0f3cc7022a7db54 Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Mon, 24 Jul 2023 12:41:30 -0400 Subject: [PATCH 23/32] unclear who main copyright holder is on our side, so omit for now --- inst/COPYRIGHTS | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/inst/COPYRIGHTS b/inst/COPYRIGHTS index d7997d7e..db532a7e 100644 --- a/inst/COPYRIGHTS +++ b/inst/COPYRIGHTS @@ -1,7 +1,5 @@ -Copyright for most of the included code is held by the Delphi group. - Posit is the copyright holder for `rlang` fragments included in the -`as_slide_computation` function and documentation in `utils.R` under the following license. +`as_slide_computation` function and documentation in `utils.R` under the following license: # MIT License From e5ed4d05c5720cea74acbed8d664becf40012afb Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Mon, 24 Jul 2023 12:45:00 -0400 Subject: [PATCH 24/32] redocument --- R/utils.R | 8 ++++---- man/epi_slide.Rd | 4 ++-- man/epix_slide.Rd | 4 ++-- man/reexports.Rd | 2 +- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/R/utils.R b/R/utils.R index 026e10ff..5c12e77d 100644 --- a/R/utils.R +++ b/R/utils.R @@ -193,14 +193,14 @@ assert_sufficient_f_args <- function(f, ...) { #' extended to include `..3`; and also by `epi[x]_slide`-specific names #' `.group_key` and `.ref_time_value`. #' -#' @source This code and documentation are based on [`as_function`] -#' (https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L343-L427) -#' function from Hadley Wickham's `rlang` package. +#' @source This code and documentation are based on +#' [`as_function`](https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L343-L427) +#' from Hadley Wickham's `rlang` package. #' #' Below is the original license for the `rlang` package. #' #' -#' # MIT License +#' MIT License #' #' Copyright (c) 2020 rlang authors #' diff --git a/man/epi_slide.Rd b/man/epi_slide.Rd index c0ff4e7b..33c3a7fb 100644 --- a/man/epi_slide.Rd +++ b/man/epi_slide.Rd @@ -76,9 +76,9 @@ contain the derivative values. Default is "slide_value"; note that setting \code{new_col_name} equal to an existing column name will overwrite this column.} \item{as_list_col}{Should the slide results be held in a list column, or be -\link[tidyr:chop]{unchopped}/\link[tidyr:nest]{unnested}? Default is \code{FALSE}, +\link[tidyr:chop]{unchopped}/\link[tidyr:unnest]{unnested}? Default is \code{FALSE}, in which case a list object returned by \code{f} would be unnested (using -\code{\link[tidyr:nest]{tidyr::unnest()}}), and, if the slide computations output data frames, +\code{\link[tidyr:unnest]{tidyr::unnest()}}), and, if the slide computations output data frames, the names of the resulting columns are given by prepending \code{new_col_name} to the names of the list elements.} diff --git a/man/epix_slide.Rd b/man/epix_slide.Rd index 2b254876..c0f07d88 100644 --- a/man/epix_slide.Rd +++ b/man/epix_slide.Rd @@ -80,9 +80,9 @@ contain the derivative values. Default is "slide_value"; note that setting \code{new_col_name} equal to an existing column name will overwrite this column.} \item{as_list_col}{Should the slide results be held in a list column, or be -\link[tidyr:chop]{unchopped}/\link[tidyr:nest]{unnested}? Default is \code{FALSE}, +\link[tidyr:chop]{unchopped}/\link[tidyr:unnest]{unnested}? Default is \code{FALSE}, in which case a list object returned by \code{f} would be unnested (using -\code{\link[tidyr:nest]{tidyr::unnest()}}), and, if the slide computations output data frames, +\code{\link[tidyr:unnest]{tidyr::unnest()}}), and, if the slide computations output data frames, the names of the resulting columns are given by prepending \code{new_col_name} to the names of the list elements.} diff --git a/man/reexports.Rd b/man/reexports.Rd index b633e86c..46e961d9 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -23,7 +23,7 @@ below to see their documentation. \describe{ \item{dplyr}{\code{\link[dplyr]{arrange}}, \code{\link[dplyr]{filter}}, \code{\link[dplyr]{group_by}}, \code{\link[dplyr:group_map]{group_modify}}, \code{\link[dplyr]{mutate}}, \code{\link[dplyr]{relocate}}, \code{\link[dplyr]{rename}}, \code{\link[dplyr]{slice}}, \code{\link[dplyr:group_by]{ungroup}}} - \item{tidyr}{\code{\link[tidyr:nest]{unnest}}} + \item{tidyr}{\code{\link[tidyr]{unnest}}} \item{tsibble}{\code{\link[tsibble:as-tsibble]{as_tsibble}}} }} From f441c44da4ff559334365c13776c9c7ee52e473e Mon Sep 17 00:00:00 2001 From: dsweber2 Date: Wed, 26 Jul 2023 14:34:31 -0700 Subject: [PATCH 25/32] ci: notate why we're checking the repo owner --- .github/workflows/pkgdown.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 26a7b1b5..e591f1d9 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -15,6 +15,7 @@ name: pkgdown jobs: pkgdown: + # only build docs on the main repository and not forks if: github.repository_owner == 'cmu-delphi' runs-on: ubuntu-latest # Only restrict concurrency for non-PR jobs From c93638772509286eef7faec398ee534d6a488e0c Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Thu, 27 Jul 2023 13:49:26 -0400 Subject: [PATCH 26/32] remove duplicate tests and suppress warnings when testing for errors --- tests/testthat/test-utils.R | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index bf073174..c1e89aec 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -168,7 +168,7 @@ test_that("assert_sufficient_f_args alerts if the provided f has defaults for th expect_no_error(assert_sufficient_f_args(f_xsgt, setting = "b")) expect_no_error(assert_sufficient_f_args(f_xsgt_dots, setting = "b")) expect_error(suppressWarnings(assert_sufficient_f_args(f_xs_dots, setting = "b")), - regexp = "window data to `f`'s x argument", + regexp = "pass the window data to `f`'s x argument", class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") # forwarding unnamed dots should not: @@ -176,12 +176,8 @@ test_that("assert_sufficient_f_args alerts if the provided f has defaults for th class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") expect_error(assert_sufficient_f_args(f_xsgt_dots, "b"), class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") - expect_error(assert_sufficient_f_args(f_xs_dots, "b"), - class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") - - # forwarding no dots should produce a different error message in some cases: - expect_error(assert_sufficient_f_args(f_xs_dots), - regexp = "window data and group key to `f`'s x and setting argument", + expect_error(suppressWarnings(assert_sufficient_f_args(f_xs_dots, "b")), + regexp = "pass the window data and group key to `f`'s x and setting argument", class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") }) From 655aa69f6d1fd04576da7a10a319c1d0648e7a2e Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Thu, 27 Jul 2023 14:14:39 -0400 Subject: [PATCH 27/32] make sure all named args in as_slide_computation are used in calling fns too, to avoid name conflicts with dots --- R/utils.R | 39 +++++++++++++++++++-------------------- man/epi_slide.Rd | 4 ++-- man/epix_slide.Rd | 4 ++-- man/reexports.Rd | 2 +- 4 files changed, 24 insertions(+), 25 deletions(-) diff --git a/R/utils.R b/R/utils.R index 0884c73b..babe3e0b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -198,7 +198,7 @@ assert_sufficient_f_args <- function(f, ...) { #' #' @source https://github.com/r-lib/rlang/blob/c55f6027928d3104ed449e591e8a225fcaf55e13/R/fn.R#L343-L427 #' -#' @param .f A function, one-sided formula, or quosure. +#' @param f A function, one-sided formula, or quosure. #' #' If a **function**, the function is returned as-is, with no #' modifications. @@ -220,7 +220,6 @@ assert_sufficient_f_args <- function(f, ...) { #' @param ... Additional arguments to pass to the function or formula #' specified via `x`. If `x` is a quosure, any arguments passed via `...` #' will be ignored. -#' @inheritParams rlang::args_error_context #' @examples #' f <- as_slide_computation(~ .x + 1) #' f(10) @@ -235,13 +234,13 @@ assert_sufficient_f_args <- function(f, ...) { #' f_rhs is_formula caller_arg caller_env #' #' @noRd -as_slide_computation <- function(.f, - ..., - arg = caller_arg(.f), - call = caller_env()) { +as_slide_computation <- function(f, ...) { + arg = caller_arg(f) + call = caller_env() + # A quosure is a type of formula, so be careful with the order and contents # of the conditional logic here. - if (is_quosure(.f)) { + if (is_quosure(f)) { fn = function(.x, .group_key, .ref_time_value, ...) { # Convert to environment to standardize between tibble and R6 # based inputs. In both cases, we should get a simple @@ -254,31 +253,31 @@ as_slide_computation <- function(.f, data_mask$.x = .x data_mask$.group_key = .group_key data_mask$.ref_time_value = .ref_time_value - rlang::eval_tidy(.f, data_mask) + rlang::eval_tidy(f, data_mask) } return(fn) } - if (is_function(.f)) { + if (is_function(f)) { # Check that `f` takes enough args - assert_sufficient_f_args(.f, ...) - return(.f) + assert_sufficient_f_args(f, ...) + return(f) } - if (is_formula(.f)) { - if (length(.f) > 2) { + if (is_formula(f)) { + if (length(f) > 2) { Abort(sprintf("%s must be a one-sided formula", arg), class = "epiprocess__as_slide_computation__formula_is_twosided", - epiprocess__f = .f, + epiprocess__f = f, call = call) } - env <- f_env(.f) + env <- f_env(f) if (!is_environment(env)) { Abort("Formula must carry an environment.", class = "epiprocess__as_slide_computation__formula_has_no_env", - epiprocess__f = .f, + epiprocess__f = f, epiprocess__f_env = env, arg = arg, call = call) } @@ -288,16 +287,16 @@ as_slide_computation <- function(.f, .x = quote(..1), .y = quote(..2), .z = quote(..3), . = quote(..1), .group_key = quote(..2), .ref_time_value = quote(..3) ) - fn <- new_function(args, f_rhs(.f), env) + fn <- new_function(args, f_rhs(f), env) fn <- structure(fn, class = c("epiprocess_slide_computation", "function")) return(fn) } - Abort(sprintf("Can't convert a %s to a slide computation", class(.f)), + Abort(sprintf("Can't convert a %s to a slide computation", class(f)), class = "epiprocess__as_slide_computation__cant_convert_catchall", - epiprocess__f = .f, - epiprocess__f_class = class(.f), + epiprocess__f = f, + epiprocess__f_class = class(f), arg = arg, call = call) } diff --git a/man/epi_slide.Rd b/man/epi_slide.Rd index c0ff4e7b..33c3a7fb 100644 --- a/man/epi_slide.Rd +++ b/man/epi_slide.Rd @@ -76,9 +76,9 @@ contain the derivative values. Default is "slide_value"; note that setting \code{new_col_name} equal to an existing column name will overwrite this column.} \item{as_list_col}{Should the slide results be held in a list column, or be -\link[tidyr:chop]{unchopped}/\link[tidyr:nest]{unnested}? Default is \code{FALSE}, +\link[tidyr:chop]{unchopped}/\link[tidyr:unnest]{unnested}? Default is \code{FALSE}, in which case a list object returned by \code{f} would be unnested (using -\code{\link[tidyr:nest]{tidyr::unnest()}}), and, if the slide computations output data frames, +\code{\link[tidyr:unnest]{tidyr::unnest()}}), and, if the slide computations output data frames, the names of the resulting columns are given by prepending \code{new_col_name} to the names of the list elements.} diff --git a/man/epix_slide.Rd b/man/epix_slide.Rd index 2b254876..c0f07d88 100644 --- a/man/epix_slide.Rd +++ b/man/epix_slide.Rd @@ -80,9 +80,9 @@ contain the derivative values. Default is "slide_value"; note that setting \code{new_col_name} equal to an existing column name will overwrite this column.} \item{as_list_col}{Should the slide results be held in a list column, or be -\link[tidyr:chop]{unchopped}/\link[tidyr:nest]{unnested}? Default is \code{FALSE}, +\link[tidyr:chop]{unchopped}/\link[tidyr:unnest]{unnested}? Default is \code{FALSE}, in which case a list object returned by \code{f} would be unnested (using -\code{\link[tidyr:nest]{tidyr::unnest()}}), and, if the slide computations output data frames, +\code{\link[tidyr:unnest]{tidyr::unnest()}}), and, if the slide computations output data frames, the names of the resulting columns are given by prepending \code{new_col_name} to the names of the list elements.} diff --git a/man/reexports.Rd b/man/reexports.Rd index b633e86c..46e961d9 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -23,7 +23,7 @@ below to see their documentation. \describe{ \item{dplyr}{\code{\link[dplyr]{arrange}}, \code{\link[dplyr]{filter}}, \code{\link[dplyr]{group_by}}, \code{\link[dplyr:group_map]{group_modify}}, \code{\link[dplyr]{mutate}}, \code{\link[dplyr]{relocate}}, \code{\link[dplyr]{rename}}, \code{\link[dplyr]{slice}}, \code{\link[dplyr:group_by]{ungroup}}} - \item{tidyr}{\code{\link[tidyr:nest]{unnest}}} + \item{tidyr}{\code{\link[tidyr]{unnest}}} \item{tsibble}{\code{\link[tsibble:as-tsibble]{as_tsibble}}} }} From 62d76aabb7ebd0da55413672868492ac2567baee Mon Sep 17 00:00:00 2001 From: "Logan C. Brooks" Date: Wed, 2 Aug 2023 16:34:46 -0700 Subject: [PATCH 28/32] Improve `as_slide_computation()` unsupported class error message --- R/utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index babe3e0b..cc06550b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -293,7 +293,7 @@ as_slide_computation <- function(f, ...) { return(fn) } - Abort(sprintf("Can't convert a %s to a slide computation", class(f)), + Abort(sprintf("Can't convert an object of class %s to a slide computation", paste(collapse=" ", deparse(class(f)))), class = "epiprocess__as_slide_computation__cant_convert_catchall", epiprocess__f = f, epiprocess__f_class = class(f), From 8c8bc52024a517e0955dcb9e0887cdb896decc60 Mon Sep 17 00:00:00 2001 From: "Logan C. Brooks" Date: Wed, 2 Aug 2023 16:37:44 -0700 Subject: [PATCH 29/32] docs(as_slide_computation): sync formula->comp special class rename --- R/utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index cc06550b..14ad14c1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -210,7 +210,7 @@ assert_sufficient_f_args <- function(f, ...) { #' place of `.y`, and `.ref_time_value` can be used in place of `.z`. This #' allows you to create very compact anonymous functions (lambdas) with up #' to three inputs. Functions created from formulas have a special class. -#' Use `rlang::is_lambda()` to test for it. +#' Use `inherits(fn, "epiprocess_slide_computation")` to test for it. #' #' If a **quosure**, in the case that `f` was not provided to the parent #' `epi[x]_slide` call and the `...` is interpreted as an expression for From 2791f01e79bd02c08be2c8da3e9e4472aa713766 Mon Sep 17 00:00:00 2001 From: "Logan C. Brooks" Date: Wed, 2 Aug 2023 17:31:49 -0700 Subject: [PATCH 30/32] refactor(as_slide_computation): quo conversion needs no `...` `... = missing_arg(); some_function(...)` will pass zero arguments to `some_function`, so we don't need to accept `...` in converted quosures. --- R/grouped_epi_archive.R | 2 +- R/slide.R | 2 +- R/utils.R | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/grouped_epi_archive.R b/R/grouped_epi_archive.R index 71f25847..d1ddf5bf 100644 --- a/R/grouped_epi_archive.R +++ b/R/grouped_epi_archive.R @@ -304,7 +304,7 @@ grouped_epi_archive = f = quos[[1]] new_col = sym(names(rlang::quos_auto_name(quos))) - ... = missing_arg() + ... = missing_arg() # magic value that passes zero args as dots in calls below } f = as_slide_computation(f, ...) diff --git a/R/slide.R b/R/slide.R index 0325244d..7467f219 100644 --- a/R/slide.R +++ b/R/slide.R @@ -363,7 +363,7 @@ epi_slide = function(x, f, ..., before, after, ref_time_values, f = quos[[1]] new_col = sym(names(rlang::quos_auto_name(quos))) - ... = missing_arg() + ... = missing_arg() # magic value that passes zero args as dots in calls below } f = as_slide_computation(f, ...) diff --git a/R/utils.R b/R/utils.R index 14ad14c1..f46c1c53 100644 --- a/R/utils.R +++ b/R/utils.R @@ -241,7 +241,7 @@ as_slide_computation <- function(f, ...) { # A quosure is a type of formula, so be careful with the order and contents # of the conditional logic here. if (is_quosure(f)) { - fn = function(.x, .group_key, .ref_time_value, ...) { + fn = function(.x, .group_key, .ref_time_value) { # Convert to environment to standardize between tibble and R6 # based inputs. In both cases, we should get a simple # environment with the empty environment as its parent. From 81fb4bca3f47574d3e84a697070b9eb94b976f93 Mon Sep 17 00:00:00 2001 From: "Logan C. Brooks" Date: Tue, 8 Aug 2023 11:08:24 -0700 Subject: [PATCH 31/32] feat(as_slide_computation): abort nonempty ... with formula instead of ignoring them. --- R/utils.R | 6 ++++++ tests/testthat/test-utils.R | 4 ++++ 2 files changed, 10 insertions(+) diff --git a/R/utils.R b/R/utils.R index f46c1c53..6aa0d674 100644 --- a/R/utils.R +++ b/R/utils.R @@ -272,6 +272,12 @@ as_slide_computation <- function(f, ...) { epiprocess__f = f, call = call) } + if (rlang::dots_n(...) > 0L) { + Abort("No arguments can be passed via `...` when `f` is a formula, or there are unrecognized/misspelled parameter names.", + class = "epiprocess__as_slide_computation__formula_with_dots", + epiprocess__f = f, + epiprocess__enquos_dots = enquos(...)) + } env <- f_env(f) if (!is_environment(env)) { diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index bf073174..aba1dcf2 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -207,6 +207,10 @@ test_that("as_slide_computation raises errors as expected", { expect_error(as_slide_computation(y ~ ..1), class="epiprocess__as_slide_computation__formula_is_twosided") + # Formulas can't be paired with ... + expect_error(as_slide_computation(~ ..1, method = "fn"), + class="epiprocess__as_slide_computation__formula_with_dots") + # `f_env` must be an environment formula_without_env <- stats::as.formula(~ ..1) rlang::f_env(formula_without_env) <- 5 From e43371f0cf1dd6b781ad4f63ba01bae20a848b30 Mon Sep 17 00:00:00 2001 From: "Logan C. Brooks" Date: Tue, 8 Aug 2023 11:30:07 -0700 Subject: [PATCH 32/32] `expect_warning` in some noisy warning+error tests A couple warnings were leaking out of `test()` from test cases that produced a warning + error but only used `expect_error()`. Use `expect_warning` in addition to test for specific expected warnings. --- tests/testthat/test-utils.R | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index aba1dcf2..52dcd6e5 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -176,13 +176,23 @@ test_that("assert_sufficient_f_args alerts if the provided f has defaults for th class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") expect_error(assert_sufficient_f_args(f_xsgt_dots, "b"), class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") - expect_error(assert_sufficient_f_args(f_xs_dots, "b"), - class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") + expect_error( + expect_warning( + assert_sufficient_f_args(f_xs_dots, "b"), + class = "epiprocess__assert_sufficient_f_args__mandatory_f_args_passed_to_f_dots" + ), + class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults" + ) # forwarding no dots should produce a different error message in some cases: - expect_error(assert_sufficient_f_args(f_xs_dots), - regexp = "window data and group key to `f`'s x and setting argument", - class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults") + expect_error( + expect_warning( + assert_sufficient_f_args(f_xs_dots), + class = "epiprocess__assert_sufficient_f_args__mandatory_f_args_passed_to_f_dots" + ), + regexp = "window data and group key to `f`'s x and setting argument", + class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults" + ) }) test_that("computation formula-derived functions take all argument types", {