diff --git a/R/add_overall.R b/R/add_overall.R index 3d9845dd1..c2a8541b6 100644 --- a/R/add_overall.R +++ b/R/add_overall.R @@ -205,6 +205,12 @@ add_overall_merge <- function(x, tbl_overall, last, col_label, calling_fun) { tbl_overall$table_styling$footnote_header %>% dplyr::filter(.data$column %in% "stat_0") ) + x$table_styling$footnote_body <- + dplyr::bind_rows( + x$table_styling$footnote_body, + tbl_overall$table_styling$footnote_body %>% + dplyr::filter(.data$column %in% "stat_0") + ) # Add header to overall column x <- modify_header(x, stat_0 = col_label) diff --git a/R/modify_footnote.R b/R/modify_footnote.R index 22c7faff7..1d4bd1e38 100644 --- a/R/modify_footnote.R +++ b/R/modify_footnote.R @@ -8,6 +8,11 @@ #' @param rows (predicate `expression`)\cr #' Predicate expression to select rows in `x$table_body`. #' Review [rows argument details][rows_argument]. +#' @param replace (scalar `logical`)\cr +#' Logical indicating whether to replace any existing footnotes in the specified +#' location with the specified footnote, or whether the specified should +#' be added to the existing footnote(s) in the header/cell. Default +#' is to replace existing footnotes. #' #' @return Updated gtsummary object #' @name modify_footnote2 @@ -18,13 +23,14 @@ NULL #' @export #' @rdname modify_footnote2 -modify_footnote_header <- function(x, footnote, columns, text_interpret = c("md", "html")) { +modify_footnote_header <- function(x, footnote, columns, replace = TRUE, text_interpret = c("md", "html")) { set_cli_abort_call() updated_call_list <- c(x$call_list, list(modify_footnote_header = match.call())) # check inputs --------------------------------------------------------------- check_class(x, "gtsummary") check_string(footnote) + check_scalar_logical(replace) text_interpret <- arg_match(text_interpret, error_call = get_cli_abort_call()) # process columns ------------------------------------------------------------ @@ -42,6 +48,7 @@ modify_footnote_header <- function(x, footnote, columns, text_interpret = c("md" x, lst_footnotes = lst_footnotes, text_interpret = text_interpret, + replace = replace, remove = FALSE ) @@ -52,13 +59,14 @@ modify_footnote_header <- function(x, footnote, columns, text_interpret = c("md" #' @export #' @rdname modify_footnote2 -modify_footnote_body <- function(x, footnote, columns, rows, text_interpret = c("md", "html")) { +modify_footnote_body <- function(x, footnote, columns, rows, replace = TRUE, text_interpret = c("md", "html")) { set_cli_abort_call() updated_call_list <- c(x$call_list, list(modify_footnote_body = match.call())) # check inputs --------------------------------------------------------------- check_class(x, "gtsummary") check_string(footnote) + check_scalar_logical(replace) text_interpret <- arg_match(text_interpret, error_call = get_cli_abort_call()) .check_rows_input(x, {{ rows }}) @@ -78,6 +86,7 @@ modify_footnote_body <- function(x, footnote, columns, rows, text_interpret = c( lst_footnotes = lst_footnotes, rows = {{ rows }}, text_interpret = text_interpret, + replace = replace, remove = FALSE ) @@ -166,7 +175,8 @@ remove_footnote_body <- function(x, columns, rows) { } # modify_footnote_*() for internal use (no checking of inputs) ----------------- -.modify_footnote_header <- function(x, lst_footnotes, text_interpret = "md", remove = FALSE) { +.modify_footnote_header <- function(x, lst_footnotes, text_interpret = "md", + replace = TRUE, remove = FALSE) { # add updates to `x$table_styling$footnote_header` --------------------------- x$table_styling$footnote_header <- x$table_styling$footnote_header |> dplyr::bind_rows( @@ -174,6 +184,7 @@ remove_footnote_body <- function(x, columns, rows) { column = names(lst_footnotes), footnote = unlist(lst_footnotes) |> unname(), text_interpret = paste0("gt::", text_interpret), + replace = replace, remove = remove ) ) @@ -182,7 +193,8 @@ remove_footnote_body <- function(x, columns, rows) { x } -.modify_footnote_body <- function(x, lst_footnotes, rows, text_interpret = "md", remove = FALSE) { +.modify_footnote_body <- function(x, lst_footnotes, rows, text_interpret = "md", + replace = TRUE, remove = FALSE) { # add updates to `x$table_styling$footnote_body` ----------------------------- x$table_styling$footnote_body <- x$table_styling$footnote_body |> dplyr::bind_rows( @@ -191,6 +203,7 @@ remove_footnote_body <- function(x, columns, rows) { rows = list(enquo(rows)), footnote = unlist(lst_footnotes) |> unname(), text_interpret = paste0("gt::", text_interpret), + replace = replace, remove = remove ) ) diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index 3861cfc23..3ae9ac824 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -247,6 +247,7 @@ modify_table_styling <- function(x, column = columns, footnote = footnote, text_interpret = text_interpret, + replace = TRUE, remove = is.na(footnote) ) ) @@ -259,6 +260,7 @@ modify_table_styling <- function(x, rows = list(rows), footnote = footnote, text_interpret = text_interpret, + replace = TRUE, remove = is.na(footnote) ) ) diff --git a/R/utils-as.R b/R/utils-as.R index 4ef856387..932a3a7a6 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -130,16 +130,48 @@ # footnote_header ------------------------------------------------------------ x$table_styling$footnote_header <- x$table_styling$footnote_header |> - dplyr::slice_tail(n = 1L, by = "column") |> + dplyr::mutate( + # this is a hold-over from old syntax where NA removed footnotes. + 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( - !.data$remove, - !is.na(.data$footnote), - .data$column %in% x$table_styling$header$column[!x$table_styling$header$hide] - ) + .by = "column", + !ifelse( + dplyr::row_number() == dplyr::n(), + FALSE, + as.logical(rev(cummax(rev(max(.data$replace, .data$remove))))) + ) + ) |> + #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]) # footnote_body -------------------------------------------------------------- x$table_styling$footnote_body <- - .table_styling_expr_to_row_number_footnote(x, "footnote_body") + x$table_styling$footnote_body |> + dplyr::mutate( + remove = ifelse(is.na(.data$footnote), TRUE, .data$remove), # this is a hold-over from pre-v2.0.0 syntax where NA removed footnotes. + # convert rows predicate expression to row numbers + row_numbers = + map( + .data$rows, + \(rows) .rows_expr_to_row_numbers(x$table_body, rows) + ) + ) |> + 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))))) + ) + ) |> + #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"))) |> + dplyr::mutate(row_numbers = as.integer(.data$row_numbers)) # when there are no body footnotes, this ensures expected type/class # abbreviation --------------------------------------------------------------- abbreviation_cols <- @@ -196,43 +228,6 @@ x } -.table_styling_expr_to_row_number_footnote <- function(x, footnote_type) { - df_clean <- - x$table_styling[[footnote_type]] %>% - dplyr::filter(.data$column %in% .cols_to_show(x)) - if (nrow(df_clean) == 0) { - return(dplyr::tibble( - column = character(0), tab_location = character(0), row_numbers = logical(0), - text_interpret = character(0), footnote = character(0) - )) - } - - df_clean <- - df_clean %>% - dplyr::rowwise() %>% - dplyr::mutate( - row_numbers = - switch(nrow(.) == 0, - integer(0) - ) %||% - .rows_expr_to_row_numbers(x$table_body, .data$rows) %>% list(), - tab_location = ifelse(identical(.data$row_numbers, NA), "header", "body") - ) %>% - dplyr::select(-"rows") %>% - tidyr::unnest(cols = "row_numbers") %>% - dplyr::group_by(.data$column, .data$tab_location, .data$row_numbers) %>% - dplyr::filter(dplyr::row_number() == dplyr::n()) %>% - # keeping the most recent addition - dplyr::filter( - !.data$remove, - !is.na(.data$footnote), - .data$column %in% x$table_styling$header$column[!x$table_styling$header$hide] - ) - - df_clean %>% - dplyr::select(all_of(c("column", "tab_location", "row_numbers", "text_interpret", "footnote"))) -} - # 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) { @@ -259,45 +254,6 @@ dplyr::mutate(footnote_id = dplyr::row_number() + .env$start_with) |> tidyr::unnest(cols = "data") |> dplyr::select(any_of(c("footnote_id", "footnote", "column", "column_id", "row_numbers"))) - - - - - - # # stacking the header and body footnotes into the structure from the older structure - # # will need to update this after we implement footnotes for spanning headers - # x$table_styling$footnote <- - # dplyr::bind_rows( - # x$table_styling$footnote_header |> dplyr::mutate(tab_location = "header"), - # x$table_styling$footnote_body |> dplyr::mutate(tab_location = "body") - # ) - # - # if (nrow(x$table_styling$footnote) == 0) { - # return(dplyr::tibble( - # footnote_id = integer(), footnote = character(), column = character(), - # tab_location = character(), row_numbers = integer() - # )) - # } - # dplyr::bind_rows( - # x$table_styling$footnote, - # x$table_styling$footnote_abbrev - # ) %>% - # dplyr::inner_join( - # x$table_styling$header %>% - # select("column") %>% - # mutate(column_id = dplyr::row_number()), - # by = "column" - # ) %>% - # dplyr::arrange(dplyr::desc(.data$tab_location), .data$column_id, .data$row_numbers) %>% - # dplyr::group_by(.data$footnote) %>% - # tidyr::nest() %>% - # dplyr::ungroup() %>% - # dplyr::mutate(footnote_id = dplyr::row_number()) %>% - # tidyr::unnest(cols = "data") %>% - # dplyr::select( - # "footnote_id", "footnote", "column", - # "tab_location", "row_numbers" - # ) } diff --git a/R/utils-gtsummary_core.R b/R/utils-gtsummary_core.R index 0ae662273..f7b850f04 100644 --- a/R/utils-gtsummary_core.R +++ b/R/utils-gtsummary_core.R @@ -30,13 +30,15 @@ ) x$table_styling$footnote_header <- dplyr::tibble( - column = character(), footnote = character(), - text_interpret = character(), remove = logical() + column = character(), + footnote = character(), text_interpret = character(), + replace = logical(), remove = logical() ) x$table_styling$footnote_body <- dplyr::tibble( column = character(), rows = list(), - footnote = character(), text_interpret = character(), remove = logical() + footnote = character(), text_interpret = character(), + replace = logical(), remove = logical() ) x$table_styling$abbreviation <- dplyr::tibble( diff --git a/man/modify_footnote2.Rd b/man/modify_footnote2.Rd index 6e59d7e7c..4ca39532d 100644 --- a/man/modify_footnote2.Rd +++ b/man/modify_footnote2.Rd @@ -8,13 +8,20 @@ \alias{remove_footnote_body} \title{Modify Footnotes} \usage{ -modify_footnote_header(x, footnote, columns, text_interpret = c("md", "html")) +modify_footnote_header( + x, + footnote, + columns, + replace = TRUE, + text_interpret = c("md", "html") +) modify_footnote_body( x, footnote, columns, rows, + replace = TRUE, text_interpret = c("md", "html") ) @@ -32,6 +39,12 @@ a string} \item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to add footnote} +\item{replace}{(scalar \code{logical})\cr +Logical indicating whether to replace any existing footnotes in the specified +location with the specified footnote, or whether the specified should +be added to the existing footnote(s) in the header/cell. Default +is to replace existing footnotes.} + \item{text_interpret}{(\code{string})\cr String indicates whether text will be interpreted with \code{\link[gt:md]{gt::md()}} or \code{\link[gt:html]{gt::html()}}. Must be \code{"md"} (default) or \code{"html"}. diff --git a/tests/testthat/_snaps/separate_p_footnotes.md b/tests/testthat/_snaps/separate_p_footnotes.md index 01f9b214e..b3c9ba694 100644 --- a/tests/testthat/_snaps/separate_p_footnotes.md +++ b/tests/testthat/_snaps/separate_p_footnotes.md @@ -5,9 +5,9 @@ variable, by, ...) broom::tidy(t.test(data[[variable]] ~ data[[by]]))))), "table_styling"), "footnote_body"), dplyr::row_number() %in% c(dplyr::n(), dplyr::n() - 1L)), rows = map_chr(rows, ~ expr_deparse(quo_squash(.x))))) Output - column rows footnote text_interpret remove - 1 p.value .data$variable %in% "age" & .data$row_type %in% "label" Welch Two Sample t-test gt::md FALSE - 2 p.value .data$variable %in% "grade" & .data$row_type %in% "label" Pearson's Chi-squared test gt::md FALSE + column rows footnote text_interpret replace remove + 1 p.value .data$variable %in% "age" & .data$row_type %in% "label" Welch Two Sample t-test gt::md TRUE FALSE + 2 p.value .data$variable %in% "grade" & .data$row_type %in% "label" Pearson's Chi-squared test gt::md TRUE FALSE --- @@ -15,12 +15,12 @@ as.data.frame(dplyr::mutate(dplyr::filter(getElement(getElement(separate_p_footnotes(add_difference(tbl)), "table_styling"), "footnote_body"), dplyr::row_number() %in% seq(dplyr::n(), dplyr::n() - 4L)), rows = map_chr(rows, ~ expr_deparse(quo_squash(.x))))) Output - column rows footnote text_interpret remove - 1 estimate .data$variable %in% "age" & .data$row_type %in% "label" Welch Two Sample t-test gt::md FALSE - 2 conf.low .data$variable %in% "age" & .data$row_type %in% "label" Welch Two Sample t-test gt::md FALSE - 3 p.value .data$variable %in% "age" & .data$row_type %in% "label" Welch Two Sample t-test gt::md FALSE - 4 estimate .data$variable %in% "grade" & .data$row_type %in% "label" Standardized Mean Difference gt::md FALSE - 5 conf.low .data$variable %in% "grade" & .data$row_type %in% "label" Standardized Mean Difference gt::md FALSE + column rows footnote text_interpret replace remove + 1 estimate .data$variable %in% "age" & .data$row_type %in% "label" Welch Two Sample t-test gt::md TRUE FALSE + 2 conf.low .data$variable %in% "age" & .data$row_type %in% "label" Welch Two Sample t-test gt::md TRUE FALSE + 3 p.value .data$variable %in% "age" & .data$row_type %in% "label" Welch Two Sample t-test gt::md TRUE FALSE + 4 estimate .data$variable %in% "grade" & .data$row_type %in% "label" Standardized Mean Difference gt::md TRUE FALSE + 5 conf.low .data$variable %in% "grade" & .data$row_type %in% "label" Standardized Mean Difference gt::md TRUE FALSE # separate_p_footnotes() messaging diff --git a/tests/testthat/test-modify_footnote_header.R b/tests/testthat/test-modify_footnote_header.R new file mode 100644 index 000000000..31eef27f0 --- /dev/null +++ b/tests/testthat/test-modify_footnote_header.R @@ -0,0 +1,14 @@ +skip_on_cran() + +base_tbl_summary <- tbl_summary(trial, include = marker) +test_that("modify_footnote_header(footnote)", { + expect_silent( + tbl <- base_tbl_summary |> + modify_footnote_header( + footnote = "testing", + columns = all_stat_cols() + ) + ) + + +})