R/tbl_strata_nested_stack.R

In gtsummary: Presentation-Ready Data Summary and Analytic Result Tables

#' Stratified Nested Stacking
#'
#' @description
#' This function stratifies your data frame, builds gtsummary tables, and
#' stacks the resulting tables in a nested style. The underlying functionality
#' is similar to `tbl_strata()`, except the resulting tables are nested or indented
#' within each group.
#'
#' **NOTE**: The header from the first table is used for the final table. Oftentimes,
#'           this header will include incorrect Ns and _must be updated._
#'
#' @inheritParams tbl_stack
#' @inheritParams tbl_strata
#' @param data (`data.frame`)\cr
#'   a data frame
#' @param row_header (`string`)\cr
#'   string indicating the row headers that appear in the table.
#'   The argument uses `glue::glue()` syntax to insert values into the
#'   row headers. Elements available to insert are `strata`, `n`, `N` and `p`.
#'   The `strata` element is the variable level of the strata variables.
#'   Default is `'{strata}'`.
#'
#' @returns a stacked 'gtsummary' table
#' @export
#'
#' @examples
#' # Example 1 ----------------------------------
#' tbl_strata_nested_stack(
#'   trial,
#'   strata = trt,
#'   .tbl_fun = ~ .x |>
#'     tbl_summary(include = c(age, grade), missing = "no") |>
#'     modify_header(all_stat_cols() ~ "**Summary Statistics**")
#' )
#'
#' # Example 2 ----------------------------------
#' tbl_strata_nested_stack(
#'   trial,
#'   strata = trt,
#'   .tbl_fun = ~ .x |>
#'     tbl_summary(include = c(age, grade), missing = "no") |>
#'     modify_header(all_stat_cols() ~ "**Summary Statistics**"),
#'   row_header = "{strata}, n={n}"
#' ) |>
#'   # bold the row headers; print `x$table_body` to see hidden columns
#'   modify_bold(columns = "label", rows = tbl_indent_id1 > 0)
tbl_strata_nested_stack <- function(data, strata, .tbl_fun, ..., row_header = "{strata}", quiet = FALSE) {
  set_cli_abort_call()

  # check inputs ---------------------------------------------------------------
  check_not_missing(data)
  check_not_missing(strata)
  check_not_missing(.tbl_fun)
  check_data_frame(data)
  cards::process_selectors(data, strata = {{ strata }})
  func_inputs <- as.list(environment())

  if (is_empty(strata) || any(strata %in% c("stat", "stat_name", "n", "N", "p", "strata"))) {
    cli::cli_abort(
      "At least one column must be selected in the {.arg strata} argument,
       and columns cannot be named {.val {c('stat', 'stat_name', 'n', 'N', 'p', 'strata')}}.",
      call = get_cli_abort_call()
    )
  }
  check_string(row_header)
  .tbl_fun <- rlang::as_function(.tbl_fun, call = get_cli_abort_call())

  # nest data and create tables within each level ------------------------------
  df_tbls <-
    cards::nest_for_ard(data, strata = strata) |>
    dplyr::mutate(
      tbl =
        map(
          .data$data,
          ~cards::eval_capture_conditions(expr(.tbl_fun(.x))) |>
            # print errors, if they occurred
            cards::captured_condition_as_error(
              message = c("The following {type} occurred while building a table:", x = "{condition}")
            )
        )
    )

  tbls <- df_tbls$tbl

  # process the headers --------------------------------------------------------
  lst_headers <-
    map(
      seq_along(strata),
      \(i) {
        data |>
        cards::ard_tabulate(variables = all_of(strata[i]), strata = any_of(strata[seq_len(i - 1L)])) |>
          # remove any unobserved levels/combination of levels
          dplyr::filter(
            .by = c(cards::all_ard_groups(), cards::all_ard_variables()),
            !any(.data$stat == 0)
          ) |>
          dplyr::select(cards::all_ard_groups(), cards::all_ard_variables(), "stat_name", "stat") |>
          dplyr::arrange(dplyr::pick(c(cards::all_ard_groups(), cards::all_ard_variables()))) |>
          tidyr::pivot_wider(
            id_cols = c(cards::all_ard_groups(), cards::all_ard_variables()),
            values_from = "stat",
            names_from = "stat_name",
            values_fn = unlist
          ) |>
          dplyr::mutate(
            strata = .data$variable_level |> unlist(),
            "{strata[i]}_strata" := glue::glue(row_header)
          ) %>%
          structure(., class = c("card", class(.))) |>
          cards::rename_ard_columns() |>
          dplyr::select(any_of(strata), all_of(glue::glue("{strata[i]}_strata")))
      }
    ) |>
    set_names(strata)

  # join the per-level header tables; keep the raw strata columns for now so `tbls`
  # can be aligned to the same ordering below
  df_headers_full <- lst_headers |>
    reduce(.f = \(.x, .y) dplyr::left_join(.x, .y, by = intersect(names(.x), names(.y))))

  # `cards::nest_for_ard()` (which fixes the order of `tbls`) and the header pipeline
  # above can order *character* strata differently (base C-locale vs. locale-aware
  # collation). Re-order `tbls` to match the header order by matching on the strata
  # level *values* rather than relying on positional alignment, which attaches counts
  # to the wrong strata for non-factor variables (#2443).
  tbls <- tbls[
    vctrs::vec_match(
      dplyr::mutate(df_headers_full[strata], across(everything(), as.character)),
      df_tbls[paste0("group", seq_along(strata), "_level")] |>
        set_names(strata) |>
        dplyr::mutate(across(everything(), ~ as.character(unlist(.x))))
    )
  ]

  df_headers <- df_headers_full |>
    dplyr::select(-all_of(strata)) |>
    dplyr::rename_with(.fn = ~str_remove(.x, "_strata$"))

  tbl_ids <-
    df_headers |>
    dplyr::mutate(
      across(
        everything(),
        .fns = ~ paste(dplyr::cur_column(), cli::cli_format(.x), sep = "=")
      ),
      .....strata..... = paste(!!!syms(names(df_headers)), sep = ",")
    ) |>
    dplyr::pull(".....strata.....")

  # NA-out repeated header values so that the later `pivot_longer() |> drop_na()`
  # keeps only the first occurrence of each value at each level. The
  # first-occurrence masks must be computed against the *original* strata values,
  # otherwise NAs introduced for an outer level would corrupt the grouping used
  # for inner levels and drop valid headers in later groups (#2418).
  first_occurrence <-
    map(
      seq_along(strata[-1]),
      \(i) {
        df_headers |>
          dplyr::mutate(
            .by = all_of(strata[seq_len(i)]),
            ...keep... = dplyr::row_number() == 1L
          ) |>
          dplyr::pull("...keep...")
      }
    )
  for (i in seq_along(strata[-1])) {
    df_headers[[strata[i]]] <-
      ifelse(first_occurrence[[i]], df_headers[[strata[i]]], NA)
  }

  first_non_hidden_col <- .first_unhidden_column(tbls[[1]])
  lst_df_headers <-
    map(
      seq_len(nrow(df_headers)),
      ~df_headers[.x, ] |>
        set_names(seq_along(strata)) |>
        tidyr::pivot_longer(
          cols = everything(),
          names_to = "tbl_indent_id1",
          values_to = first_non_hidden_col
        ) |>
        tidyr::drop_na() |>
        dplyr::mutate(tbl_indent_id1 = as.integer(.data$tbl_indent_id1))
    )

  # before combining the headers with tbls, doing some checks ------------------
  .checks_for_nesting_stack(tbls)

  # adding the headers, indenting, and stacking --------------------------------
  # add headers with their associated `tbl_indent_id1`
  for (i in seq_len(nrow(df_headers))) {
    # add nesting header rows
    tbls[[i]]$table_body <-
      dplyr::bind_rows(
        lst_df_headers[[i]],
        tbls[[i]]$table_body |> dplyr::mutate(tbl_indent_id1 = 0L)
      )

    # indent the first non-hidden column of the innermost table
    if (first_non_hidden_col %in% tbls[[i]]$table_styling$indent$column) {
      tbls[[i]]$table_styling$indent$n_spaces[tbls[[i]]$table_styling$indent$column == first_non_hidden_col] <-
        tbls[[i]]$table_styling$indent$n_spaces[tbls[[i]]$table_styling$indent$column == first_non_hidden_col] + length(strata) * 4L
    } else {
      tbls[[i]] <-
        tbls[[i]] |>
        modify_indent(
          columns = all_of(first_non_hidden_col),
          rows = !!expr(.data$tbl_indent_id1 == 0),
          indent = length(strata) * 4L
        )
    }
  }

  # stack the tbls
  tbl <- tbl_stack(tbls = tbls, quiet = quiet, tbl_ids = tbl_ids)

  # cycle over the depth and indenting nesting headers
  for (d in seq_along(strata)) {
    tbl <- tbl |>
      modify_indent(
        columns = all_of(first_non_hidden_col),
        rows = !!expr(.data$tbl_indent_id1 == !!d),
        indent = (d - 1L) * 4L
      )
  }

  # return table ---------------------------------------------------------------
  tbl$call_list <- list(tbl_row_split = match.call())
  tbl$inputs = list(tbl_row_split = func_inputs)
  tbl |>
    structure(class = c("tbl_strata_nested_stack", "tbl_stack", "gtsummary"))
}


.checks_for_nesting_stack <- function(tbls) {
  walk(
    seq_along(tbls),
    \(i) {
      if (.first_unhidden_column(tbls[[i]]) != .first_unhidden_column(tbls[[1]])) {
        cli::cli_abort(
          c("The first column shown in each table must be the same.",
            "i" = "The first table prints the {.val {identity(.first_unhidden_column(tbls[[1]]))}}
                   in the first position, and table {.val {i}} has {.val {identity(.first_unhidden_column(tbls[[i]]))}}"),
          call = get_cli_abort_call()
        )
      }
      if (!is.character(tbls[[i]]$table_body[[.first_unhidden_column(tbls[[i]])]])) {
        cli::cli_abort(
          "The first column printed must be {.cls character},
           which is not the case for table {.val {i}} and column {.val {identity(.first_unhidden_column(tbls[[i]]))}}",
          call = get_cli_abort_call()
        )
      }
      if ("tbl_indent_id1" %in% names(tbls[[i]]$table_body)) {
        cli::cli_abort(
          "The {.fun tbl_strata_nested_stack} function can only be run once on a table.
           One of the tables already contains a column named {.val tbl_indent_id1}
           indicating the function was previously executed.",
          call = get_cli_abort_call()
        )
      }
    }
  )
}