diff --git a/R/modify_abbreviation.R b/R/modify_abbreviation.R index 518212625..edde312b6 100644 --- a/R/modify_abbreviation.R +++ b/R/modify_abbreviation.R @@ -34,7 +34,7 @@ modify_abbreviation <- function(x, abbreviation, text_interpret = c("md", "html" # add updates to `x$table_styling$abbreviation` ------------------------------ x <- x |> - .modify_abbreviation(abbreviation = abbreviation, text_interpret = paste0("gt::", text_interpret)) + .modify_abbreviation(abbreviation = abbreviation, text_interpret = text_interpret) # update call list and return table ------------------------------------------ x$call_list <- updated_call_list @@ -80,7 +80,7 @@ remove_abbreviation <- function(x, abbreviation) { dplyr::tibble( column = column, abbreviation = abbreviation, - text_interpret = text_interpret + text_interpret = paste0("gt::", text_interpret) ) ) x diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index 3ae9ac824..0baecd31d 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -1,10 +1,19 @@ #' Modify Table Styling #' +#' @description +#' This function is for developers. +#' If you are not a developer, it's recommended that you use the following +#' functions to make modifications to your table. [`modify_header()`], +#' [`modify_spanning_header()`], `[modify_column_hide()]`, [`modify_column_unhide()`], +#' [`modify_footnote_header()`], [`modify_footnote_body()`], [`modify_abbreviation()`], +#' [`modify_column_alignment()`], [`modify_fmt_fun()`], `[modify_column_indent()]`, +#' [`modify_column_merge()`]. +#' +#' #' This is a function meant for advanced users to gain #' more control over the characteristics of the resulting #' gtsummary table by directly modifying `.$table_styling`. -#' *This function is primarily used in the development of other gtsummary -#' functions, and very little checking of the passed arguments is performed.* +#' *This function has very little checking of the passed arguments.* #' #' Review the #' \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary definition} @@ -101,7 +110,7 @@ modify_table_styling <- function(x, text_format = NULL, undo_text_format = NULL, indent = NULL, - text_interpret = c("md", "html"), + text_interpret = "md", cols_merge_pattern = NULL) { set_cli_abort_call() updated_call_list <- c(x$call_list, list(modify_table_styling = match.call())) @@ -175,8 +184,6 @@ modify_table_styling <- function(x, ) } - text_interpret <- paste0("gt::", arg_match(text_interpret)) - if (!is_empty(text_format)) { text_format <- arg_match(text_format, values = c("bold", "italic"), multiple = TRUE) } @@ -202,7 +209,7 @@ modify_table_styling <- function(x, x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( - dplyr::tibble(column = columns, interpret_label = text_interpret, label = label), + dplyr::tibble(column = columns, interpret_label = paste0("gt::", text_interpret), label = label), by = "column" ) } @@ -212,7 +219,7 @@ modify_table_styling <- function(x, x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( - dplyr::tibble(column = columns, interpret_spanning_header = text_interpret, spanning_header = spanning_header), + dplyr::tibble(column = columns, interpret_spanning_header = paste0("gt::", text_interpret), spanning_header = spanning_header), by = "column" ) } @@ -241,28 +248,25 @@ modify_table_styling <- function(x, if (!is_empty(footnote)) { # header footnotes if (tryCatch(is.null(eval_tidy(rows)), error = \(x) FALSE)) { - x$table_styling$footnote_header <- x$table_styling$footnote_header |> - dplyr::bind_rows( - dplyr::tibble( - column = columns, - footnote = footnote, - text_interpret = text_interpret, - replace = TRUE, - remove = is.na(footnote) - ) + x <- + .modify_footnote_header( + x = x, + lst_footnotes = + rep_named(columns, as.list(footnote)), + text_interpret = text_interpret, + replace = TRUE, + remove = is.na(footnote) ) } else { - x$table_styling$footnote_body <- x$table_styling$footnote_body |> - dplyr::bind_rows( - dplyr::tibble( - column = columns, - rows = list(rows), - footnote = footnote, - text_interpret = text_interpret, - replace = TRUE, - remove = is.na(footnote) - ) + x <- + .modify_footnote_body( + x = x, + lst_footnotes = rep_named(columns, as.list(footnote)), + rows = !!rows, + text_interpret = text_interpret, + replace = TRUE, + remove = is.na(footnote) ) } } diff --git a/R/utils-as.R b/R/utils-as.R index 932a3a7a6..87a4b695e 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -135,14 +135,7 @@ remove = ifelse(is.na(.data$footnote), TRUE, .data$remove), ) |> # within a column, if a later entry contains `replace=TRUE` or `remove=TRUE`, then mark the row for removal - dplyr::filter( - .by = "column", - !ifelse( - dplyr::row_number() == dplyr::n(), - FALSE, - as.logical(rev(cummax(rev(max(.data$replace, .data$remove))))) - ) - ) |> + .filter_row_with_subsequent_replace_or_removal() |> #finally, remove the row if it's marked for removal or if the column is not printed in final table dplyr::filter(!remove, .data$column %in% x$table_styling$header$column[!x$table_styling$header$hide]) @@ -159,15 +152,8 @@ ) ) |> tidyr::unnest(cols = "row_numbers") |> - # within a column, if a later entry contains `replace=TRUE` or `remove=TRUE`, then mark the row for removal - dplyr::filter( - .by = c("column", "row_numbers"), - !ifelse( - dplyr::row_number() == dplyr::n(), - FALSE, - as.logical(rev(cummax(rev(max(.data$replace, .data$remove))))) - ) - ) |> + # within a column/row, if a later entry contains `replace=TRUE` or `remove=TRUE`, then mark the row for removal + .filter_row_with_subsequent_replace_or_removal() |> #finally, remove the row if it's marked for removal or if the column is not printed in final table dplyr::filter(!remove, .data$column %in% x$table_styling$header$column[!x$table_styling$header$hide]) |> dplyr::select(all_of(c("column", "row_numbers", "text_interpret", "footnote"))) |> @@ -228,6 +214,32 @@ x } + +# this function processes the footnotes and removes footnotes that have +# later been replaced or removed from the table +.filter_row_with_subsequent_replace_or_removal <- function(x) { + if (nrow(x) == 0L) return(x) + + # within a column/row, if a later entry contains `replace=TRUE` or `remove=TRUE`, then mark the row for removal + dplyr::filter( + .data = x, + .by = any_of(c("column", "row_numbers")), + !unlist( + pmap( + list(.data$replace, .data$remove, dplyr::row_number()), + function(row_replace, row_remove, row_number) { + # if this is the last row in the group, there will be now removal indications below + if (row_number == dplyr::n()) return(FALSE) + # if a subsequent call to replace or remove a footnote appear below, + # then the current row can be deleted. + any(.data$replace[seq(row_number + 1L, dplyr::n())]) || + any(.data$remove[seq(row_number + 1L, dplyr::n())]) + } + ) + ) + ) +} + # this function orders the footnotes by where they first appear in the table, # and assigns them an sequential ID .number_footnotes <- function(x, type, start_with = 0L) { diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd index 76d5c233a..8f69cdb4e 100644 --- a/man/modify_table_styling.Rd +++ b/man/modify_table_styling.Rd @@ -19,7 +19,7 @@ modify_table_styling( text_format = NULL, undo_text_format = NULL, indent = NULL, - text_interpret = c("md", "html"), + text_interpret = "md", cols_merge_pattern = NULL ) } @@ -78,13 +78,19 @@ use \code{"{conf.low}, {conf.high}"}. The first column listed in the pattern string must match the single column name passed in \verb{columns=}.} } \description{ +This function is for developers. +If you are not a developer, it's recommended that you use the following +functions to make modifications to your table. \code{\link[=modify_header]{modify_header()}}, +\code{\link[=modify_spanning_header]{modify_spanning_header()}}, \verb{[modify_column_hide()]}, \code{\link[=modify_column_unhide]{modify_column_unhide()}}, +\code{\link[=modify_footnote_header]{modify_footnote_header()}}, \code{\link[=modify_footnote_body]{modify_footnote_body()}}, \code{\link[=modify_abbreviation]{modify_abbreviation()}}, +\code{\link[=modify_column_alignment]{modify_column_alignment()}}, \code{\link[=modify_fmt_fun]{modify_fmt_fun()}}, \verb{[modify_column_indent()]}, +\code{\link[=modify_column_merge]{modify_column_merge()}}. + This is a function meant for advanced users to gain more control over the characteristics of the resulting gtsummary table by directly modifying \code{.$table_styling}. -\emph{This function is primarily used in the development of other gtsummary -functions, and very little checking of the passed arguments is performed.} -} -\details{ +\emph{This function has very little checking of the passed arguments.} + Review the \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary definition} vignette for information on \code{.$table_styling} objects. diff --git a/tests/testthat/_snaps/as_kable_extra.md b/tests/testthat/_snaps/as_kable_extra.md index 1460b1914..9a9210891 100644 --- a/tests/testthat/_snaps/as_kable_extra.md +++ b/tests/testthat/_snaps/as_kable_extra.md @@ -97,7 +97,7 @@ [13] "\n \n Patient Died \n 60 (59%) \n " [14] "\n\n1 Median (Q1, Q3); n (%)\n" -# as_kable_extra passes table footnotes & footnote abbreviations correctly +# as_kable_extra passes table footnotes & abbreviations correctly "<\/tbody>\n\n\n1<\/sup> n (%); Median (Q1, Q3)<\/td><\/tr>\n\n2<\/sup> test footnote<\/td><\/tr>\n<\/tfoot>\n<\/table>" diff --git a/tests/testthat/_snaps/modify_footnote_body.md b/tests/testthat/_snaps/modify_footnote_body.md new file mode 100644 index 000000000..2eb825e93 --- /dev/null +++ b/tests/testthat/_snaps/modify_footnote_body.md @@ -0,0 +1,9 @@ +# modify_footnote_body(rows) messaging + + Code + modify_footnote_body(base_tbl_summary, footnote = "this will not appear", + columns = label, rows = not_a_predicate) + Condition + Error in `modify_footnote_body()`: + ! The `rows` argument must be an expression that evaluates to a logical vector in `x$table_body`. + diff --git a/tests/testthat/test-as_flex_table.R b/tests/testthat/test-as_flex_table.R index 982d75266..6fe690262 100644 --- a/tests/testthat/test-as_flex_table.R +++ b/tests/testthat/test-as_flex_table.R @@ -222,9 +222,9 @@ test_that("as_flex_table passes table column alignment correctly", { ) }) -test_that("as_flex_table passes table footnotes & footnote abbreviations correctly", { +test_that("as_flex_table passes table footnotes & abbreviations correctly", { tbl_fn <- my_tbl_summary |> - modify_table_styling(columns = label, footnote = "test footnote", rows = variable == "age") + modify_footnote_body(columns = label, footnote = "test footnote", rows = variable == "age") ft_tbl_fn <- tbl_fn |> as_flex_table() # footnote @@ -275,7 +275,7 @@ test_that("as_flex_table passes multiple table footnotes correctly", { # testing one footnote passed to multiple columns and rows, addresses issue #2062 out <- my_tbl_summary |> remove_footnote_header(stat_0) |> - modify_table_styling( + modify_footnote_body( columns = c(label, stat_0), rows = (variable %in% "trt") & (row_type == "level"), footnote = "my footnote" @@ -310,17 +310,17 @@ test_that("as_flex_table passes multiple table footnotes correctly", { by = trt, include = grade ) |> - modify_table_styling( + modify_footnote_body( columns = stat_1, rows = (variable %in% "grade") & (row_type == "level"), footnote = "my footnote" ) |> - modify_table_styling( + modify_footnote_body( columns = label, rows = label == "grade", footnote = "my footnote" ) |> - modify_table_styling( + modify_footnote_body( columns = label, rows = label == "I", footnote = "my footnote" diff --git a/tests/testthat/test-as_gt.R b/tests/testthat/test-as_gt.R index 6c1a7e7e1..91b12f6d7 100644 --- a/tests/testthat/test-as_gt.R +++ b/tests/testthat/test-as_gt.R @@ -213,9 +213,9 @@ test_that("as_gt passes table text interpreters correctly", { expect_true(attr(gt_tbl$`_spanners`$spanner_label[[1]], "html")) }) -test_that("as_gt passes table footnotes & footnote abbreviations correctly", { +test_that("as_gt passes table footnotes & abbreviations correctly", { tbl_fn <- my_tbl_summary |> - modify_table_styling(columns = label, footnote = "test footnote", rows = variable == "age") + modify_footnote_body(footnote = "test footnote", columns = label,rows = variable == "age") gt_tbl_fn <- tbl_fn |> as_gt() # footnote @@ -265,8 +265,8 @@ test_that("as_gt passes table footnotes & footnote abbreviations correctly", { # footnotes in the body of the table expect_equal( tbl_summary(trial, include = "age") |> - modify_table_styling(columns = label, rows = TRUE, footnote = "my footnote") |> - modify_table_styling(columns = stat_0, rows = row_type == "label", footnote = "my footnote") |> + modify_footnote_body(columns = label, rows = TRUE, footnote = "my footnote") |> + modify_footnote_body(columns = stat_0, rows = row_type == "label", footnote = "my footnote") |> as_gt() |> getElement("_footnotes") |> dplyr::filter(footnotes == "my footnote") |> diff --git a/tests/testthat/test-as_hux_table.R b/tests/testthat/test-as_hux_table.R index 1581f1b17..8e94e9da5 100644 --- a/tests/testthat/test-as_hux_table.R +++ b/tests/testthat/test-as_hux_table.R @@ -110,9 +110,9 @@ test_that("as_hux_table passes table column alignment correctly", { ) }) -test_that("as_hux_table passes table footnotes & footnote abbreviations correctly", { +test_that("as_hux_table passes table footnotes & abbreviations correctly", { tbl_fn <- my_tbl_summary |> - modify_table_styling(columns = label, footnote = "test footnote", rows = variable == "age") + modify_footnote_body(columns = label, footnote = "test footnote", rows = variable == "age") ht_fn <- tbl_fn |> as_hux_table() # footnote diff --git a/tests/testthat/test-as_kable_extra.R b/tests/testthat/test-as_kable_extra.R index 86d461156..21a15365b 100644 --- a/tests/testthat/test-as_kable_extra.R +++ b/tests/testthat/test-as_kable_extra.R @@ -167,9 +167,9 @@ test_that("as_kable_extra passes table column alignment correctly", { ) }) -test_that("as_kable_extra passes table footnotes & footnote abbreviations correctly", { +test_that("as_kable_extra passes table footnotes & abbreviations correctly", { tbl_fn <- my_tbl_summary |> - modify_table_styling(columns = label, footnote = "test footnote", rows = variable == "age") + modify_footnote_body(columns = label, footnote = "test footnote", rows = variable == "age") kbl_fn <- tbl_fn |> as_kable_extra() # footnote diff --git a/tests/testthat/test-modify_footnote.R b/tests/testthat/test-modify_footnote.R index ffefac5e8..77f6cf7d1 100644 --- a/tests/testthat/test-modify_footnote.R +++ b/tests/testthat/test-modify_footnote.R @@ -175,18 +175,20 @@ test_that("modify_footnote() works with tbl_svysummary()", { }) test_that("modify_footnote() works with tbl_continuous()", { - expect_equal(tbl_continuous(data = trial, variable = age, by = trt, include = grade)|> - add_overall() |> - modify_footnote(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> - getElement("table_styling") |> - getElement("footnote_header") |> - dplyr::slice_tail(by = "column", n = 1) |> - dplyr::filter(startsWith(column, "stat_")) |> - dplyr::pull("footnote"), - c("Drug A | N = 200 | n = 98 | p = 49%", - "Drug B | N = 200 | n = 102 | p = 51%", - "Overall | N = 200 | n = 200 | p = 100%"), - ignore_attr = TRUE) + expect_equal( + tbl_continuous(data = trial, variable = age, by = trt, include = grade) |> + add_overall() |> + modify_footnote(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> + getElement("table_styling") |> + getElement("footnote_header") |> + dplyr::slice_tail(by = "column", n = 1) |> + dplyr::filter(startsWith(column, "stat_")) |> + dplyr::pull("footnote"), + c("Drug A | N = 200 | n = 98 | p = 49%", + "Drug B | N = 200 | n = 102 | p = 51%", + "Overall | N = 200 | n = 200 | p = 100%"), + ignore_attr = TRUE + ) }) diff --git a/tests/testthat/test-modify_footnote_body.R b/tests/testthat/test-modify_footnote_body.R new file mode 100644 index 000000000..1f18e9465 --- /dev/null +++ b/tests/testthat/test-modify_footnote_body.R @@ -0,0 +1,68 @@ +skip_on_cran() + +base_tbl_summary <- + tbl_summary(trial, include = marker) |> + remove_footnote_header(columns = everything()) + +test_that("modify_footnote_body(footnote)", { + # test we can easily replace an existing header + expect_silent( + tbl <- base_tbl_summary |> + modify_footnote_body( + footnote = "this will not appear", + columns = label, + rows = row_type == "label" + ) |> + modify_footnote_body( + footnote = "this _will_ appear; N = {N}", + columns = label, + rows = row_type == "label" + ) + ) + expect_equal( + tbl$table_styling$footnote_body, + dplyr::tribble( + ~column, ~rows, ~footnote, ~text_interpret, ~replace, ~remove, + "label", ~row_type == "label", "this will not appear", "gt::md", TRUE, FALSE, + "label", ~row_type == "label", "this _will_ appear; N = 200", "gt::md", TRUE, FALSE + ), + ignore_attr = TRUE + ) +}) + +test_that("modify_footnote_body(rows) messaging", { + expect_snapshot( + error = TRUE, + base_tbl_summary |> + modify_footnote_body( + footnote = "this will not appear", + columns = label, + rows = not_a_predicate + ) + ) +}) + +test_that("remove_footnote_body(footnote)", { + # test we can remove footnotes from the cells + expect_silent( + tbl <- base_tbl_summary |> + modify_footnote_body( + footnote = "this will not appear", + columns = label, + rows = row_type == "label" + ) |> + remove_footnote_body( + columns = label, + rows = row_type == "label" + ) + ) + expect_equal( + tbl$table_styling$footnote_body, + dplyr::tribble( + ~column, ~rows, ~footnote, ~text_interpret, ~replace, ~remove, + "label", ~row_type == "label", "this will not appear", "gt::md", TRUE, FALSE, + "label", ~row_type == "label", NA, "gt::md", TRUE, TRUE + ), + ignore_attr = TRUE + ) +}) diff --git a/tests/testthat/test-modify_footnote_header.R b/tests/testthat/test-modify_footnote_header.R index 31eef27f0..2d0e2acfa 100644 --- a/tests/testthat/test-modify_footnote_header.R +++ b/tests/testthat/test-modify_footnote_header.R @@ -2,13 +2,61 @@ skip_on_cran() base_tbl_summary <- tbl_summary(trial, include = marker) test_that("modify_footnote_header(footnote)", { + # test we can easily replace an existing header footnote + expect_equal(base_tbl_summary$table_styling$footnote_header$footnote, "Median (Q1, Q3)") expect_silent( tbl <- base_tbl_summary |> modify_footnote_header( - footnote = "testing", + footnote = "testing N={N}; n={n}; p={p}", columns = all_stat_cols() ) ) + expect_equal( + tbl$table_styling$footnote_header, + dplyr::tribble( + ~column, ~footnote, ~text_interpret, ~replace, ~remove, + "stat_0", "Median (Q1, Q3)", "gt::md", TRUE, FALSE, + "stat_0", "testing N=200; n=200; p=1", "gt::md", TRUE, FALSE + ) + ) + # test that two footnotes can be placed in the same header + expect_silent( + tbl <- base_tbl_summary |> + modify_footnote_header( + footnote = "testing N={N}; n={n}; p={p}", + columns = all_stat_cols(), + replace = FALSE + ) + ) + expect_equal( + tbl$table_styling$footnote_header, + dplyr::tribble( + ~column, ~footnote, ~text_interpret, ~replace, ~remove, + "stat_0", "Median (Q1, Q3)", "gt::md", TRUE, FALSE, + "stat_0", "testing N=200; n=200; p=1", "gt::md", FALSE, FALSE + ) + ) +}) +test_that("remove_footnote_header(footnote)", { + # test we can remove footnotes from the headers + expect_silent( + tbl <- base_tbl_summary |> + modify_footnote_header( + footnote = "testing", + columns = all_stat_cols(), + replace = FALSE + ) |> + remove_footnote_header(columns = all_stat_cols()) + ) + expect_equal( + tbl$table_styling$footnote_header, + dplyr::tribble( + ~column, ~footnote, ~text_interpret, ~replace, ~remove, + "stat_0", "Median (Q1, Q3)", "gt::md", TRUE, FALSE, + "stat_0", "testing", "gt::md", FALSE, FALSE, + "stat_0", NA, "gt::md", TRUE, TRUE + ) + ) })