diff --git a/.Rbuildignore b/.Rbuildignore index ce0c08d108..92cf250ba0 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -171,6 +171,8 @@ tests/testthat/test-table_parts.R tests/testthat/_snaps/table_parts.md tests/testthat/test-text_transform.R +tests/testthat/_snaps/text_transform.md + tests/testthat/test-util_functions.R tests/testthat/test-utils_formatters.R tests/testthat/test-utils_plots.R diff --git a/NEWS.md b/NEWS.md index c4131bf3a2..8e1ab71697 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # gt (development version) +* Improved error messages for the `text_transform()` function if `locations` couldn't be resolved. (@olivroy, #1774) + * `tab_row_group()` gives a more precise error message when `rows` can't be resolved correctly (#1535). (@olivroy, #1770) * Fixed an issue where `md("")` would fail in Quarto. (@olivroy, #1769) diff --git a/R/dt_cols_merge.R b/R/dt_cols_merge.R index 822a02efb8..41a0f526c5 100644 --- a/R/dt_cols_merge.R +++ b/R/dt_cols_merge.R @@ -32,10 +32,6 @@ dt_col_merge_set <- function(data, col_merge) { dt__set(data, .dt_col_merge_key, col_merge) } -dt_col_merge_init <- function(data) { - dt_col_merge_set(data = data, col_merge = list()) -} - dt_col_merge_add <- function(data, col_merge) { added <- append(dt_col_merge_get(data = data), list(col_merge)) dt_col_merge_set(data = data, col_merge = added) diff --git a/R/location_methods.R b/R/location_methods.R index ac86ca486a..6ed8a5bc74 100644 --- a/R/location_methods.R +++ b/R/location_methods.R @@ -286,16 +286,19 @@ resolve_location.resolved <- function(loc, data) { #' @export resolve_location.cells_body <- function(loc, data) { + call <- call("cells_body") loc$colnames <- resolve_cols_c( expr = !!loc[["columns"]], - data = data + data = data, + call = call ) loc$rows <- resolve_rows_i( expr = !!loc[["rows"]], - data = data + data = data, + call = call ) class(loc) <- c("resolved", class(loc)) @@ -305,12 +308,14 @@ resolve_location.cells_body <- function(loc, data) { #' @export resolve_location.cells_column_labels <- function(loc, data) { + call <- call("cells_column_labels") if (!is.null(loc$columns)) { loc$colnames <- resolve_cols_c( expr = !!loc[["columns"]], - data = data + data = data, + call = call ) } @@ -326,7 +331,8 @@ resolve_location.cells_column_labels <- function(loc, data) { #' @export resolve_location.cells_column_spanners <- function(loc, data) { - resolved <- resolve_cells_column_spanners(data = data, object = loc) + call <- call("cells_column_spanners") + resolved <- resolve_cells_column_spanners(data = data, object = loc, call = call) loc$spanners <- resolved$spanners @@ -338,7 +344,8 @@ resolve_location.cells_column_spanners <- function(loc, data) { #' @export resolve_location.cells_stub <- function(loc, data) { - resolved <- resolve_cells_stub(data = data, object = loc) + call <- call("cells_stub") + resolved <- resolve_cells_stub(data = data, object = loc, call = call) loc$rows <- resolved$rows @@ -350,7 +357,8 @@ resolve_location.cells_stub <- function(loc, data) { #' @export resolve_location.cells_row_groups <- function(loc, data) { - resolved <- resolve_cells_row_groups(data = data, object = loc) + call <- call("cells_row_groups") + resolved <- resolve_cells_row_groups(data = data, object = loc, call = call) loc$groups <- resolved$groups diff --git a/R/text_transform.R b/R/text_transform.R index 519c411163..16a3276a65 100644 --- a/R/text_transform.R +++ b/R/text_transform.R @@ -32,13 +32,6 @@ #' remaining two values to supply are for the regex pattern (`pattern`) and the #' replacement for all matched text (`replacement`). #' -#' @param data *The gt table data object* -#' -#' `obj:` // **required** -#' -#' This is the **gt** table object that is commonly created through use of the -#' [gt()] function. -#' #' @param pattern *Regex pattern to match with* #' #' `scalar` // **required** @@ -108,7 +101,11 @@ text_replace <- function( # Perform input object validation stop_if_not_gt_tbl(data = data) - text_transform( + # Validate input + check_string(pattern, allow_empty = FALSE, allow_na = TRUE) + check_string(replacement, allow_empty = TRUE, allow_na = FALSE) + + text_transform_impl( data = data, locations = locations, fn = function(x) { @@ -130,13 +127,6 @@ text_replace <- function( #' (i.e., either `TRUE` or `FALSE`). To refer to the values undergoing #' transformation, you need to use the `x` variable. #' -#' @param .data *The gt table data object* -#' -#' `obj:` // **required** -#' -#' This is the **gt** table object that is commonly created through use of the -#' [gt()] function. -#' #' @param ... *Matching expressions* #' #' `` // **required** @@ -217,7 +207,7 @@ text_case_when <- function( # TODO: check that the modernized version of the `case_when()` # function is available in the user's version of dplyr - text_transform( + text_transform_impl( data = .data, locations = .locations, fn = function(x) { @@ -383,10 +373,9 @@ text_case_match <- function( # TODO: perform some basic checking of `...` and stop function # should issues arise - # TODO: check that the `case_match()` function is available in - # the user's version of dplyr + # We rely on dplyr 1.1 (where case_match() was introduced) - text_transform( + text_transform_impl( data = .data, locations = .locations, fn = function(x) { @@ -603,6 +592,17 @@ text_transform <- function( # Perform input object validation stop_if_not_gt_tbl(data = data) + rlang::check_required(fn) + + text_transform_impl( + data, + fn, + locations + ) +} + +# Helper function to create text_*() +text_transform_impl <- function(data, fn, locations, call = rlang::caller_env()) { # Resolve into a list of locations locations <- as_locations(locations = locations) @@ -610,7 +610,12 @@ text_transform <- function( # For all of the resolved locations, store the transforms # for later execution for (loc in locations) { - data <- dt_transforms_add(data = data, loc = loc, fn = fn) + withCallingHandlers( + # Personalize call if text_case_match() or other. + data <- dt_transforms_add(data = data, loc = loc, fn = fn), + error = function(e) { + cli::cli_abort("Failed to resolve location.", parent = e, call = call) + }) } data diff --git a/tests/testthat/_snaps/text_transform.md b/tests/testthat/_snaps/text_transform.md new file mode 100644 index 0000000000..479c6f3bbb --- /dev/null +++ b/tests/testthat/_snaps/text_transform.md @@ -0,0 +1,11 @@ +# text_case_match() works on the tab_spanner() + + Code + gt_tbl %>% text_case_match("boring " ~ "awesome ", .replace = "partial", + .locations = cells_column_spanners(2)) + Condition + Error in `text_case_match()`: + ! Failed to resolve location. + Caused by error in `cells_column_spanners()`: + ! Spanner 2 does not exist in the data. + diff --git a/tests/testthat/test-text_transform.R b/tests/testthat/test-text_transform.R index f290f7f108..0f2e31a879 100644 --- a/tests/testthat/test-text_transform.R +++ b/tests/testthat/test-text_transform.R @@ -318,6 +318,28 @@ test_that("text_transform() works on row labels in the stub", { ) }) +test_that("text_case_match() works on the tab_spanner()", { + gt_tbl <- exibble %>% gt() %>% tab_spanner("the boring spanner", columns = c(num, date)) + expect_snapshot(error = TRUE, { + gt_tbl %>% + text_case_match( + "boring " ~ "awesome ", + .replace = "partial", + .locations = cells_column_spanners(2) + ) + }) + expect_no_error(new_tb <- gt_tbl %>% + text_case_match( + "boring " ~ "awesome ", + .replace = "partial", + .locations = cells_column_spanners() + )) + expect_match_html( + new_tb, + "awesome spanner" + ) +}) + test_that("text_transform() works on row group labels", { # Create a gt table and modify the two different @@ -414,3 +436,37 @@ test_that("text_transform() works on row group labels", { selection_text("[class='gt_group_heading']") %>% expect_equal(c("SUPER POWERFUL", "POWERFUL")) }) + + +# text_*() other functions ----------------------------------------------------- + +test_that("text_case_when() + text_case_match() work", { + expect_no_error( + cw <- exibble %>% + gt() %>% + text_case_when(is.na(x) ~ "---") + ) + # md is not really respected even if we use md("---") + expect_no_error( + cm <- exibble %>% + gt() %>% + text_case_match(NA ~ "---") + ) + # they are not changing numeric NA + expect_equal( + render_as_html(cw), + render_as_html(cm) + ) +}) + +test_that("text_replace() works", { + expect_no_error( + tr <- exibble %>% + gt() %>% + text_replace("NA", "---") + ) + expect_match_html( + tr, + "---" + ) +})