R/brdg_summary.R

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

#' Summary table bridge
#'
#' @description
#' Bridge function for converting `tbl_summary()` (and similar) cards to basic gtsummary objects.
#' All bridge functions begin with prefix `brdg_*()`.
#'
#' This file also contains helper functions for constructing the bridge,
#' referred to as the piers (supports for a bridge) and begin with `pier_*()`.
#'
#' - `brdg_summary()`: The bridge function ingests an ARD data frame and returns
#'   a gtsummary table that includes `.$table_body` and a basic `.$table_styling`.
#'   The `.$table_styling$header` data frame includes the header statistics.
#'   Based on context, this function adds a column to the ARD data frame named
#'   `"gts_column"`. This column is used during the reshaping in the `pier_*()`
#'   functions defining column names.
#'
#' - `pier_*()`: these functions accept a cards tibble and returns a tibble
#'   that is a piece of the `.$table_body`. Typically these will be stacked
#'   to construct the final table body data frame. The ARD object passed here
#'   will have two primary parts: the calculated summary statistics and the
#'   attributes ARD. The attributes ARD is used for labeling. The ARD data frame
#'   passed to this function must include a `"gts_column"` column, which is
#'   added in `brdg_summary()`.
#'
#' @param cards (`card`)\cr
#'   An ARD object of class `"card"` typically created with `cards::ard_*()` functions.
#' @param variables (`character`)\cr
#'   character list of variables
#' @param by (`string`)\cr
#'   string indicating the stratifying column
#' @param type (named `list`)\cr
#'   named list of summary types
#' @param statistic (named `list`)\cr
#'   named list of summary statistic names
#' @param missing (named `list`)\cr
#'   named list with one element per variable, each assigned one of
#'   `c("ifany", "no", "always")`, indicating whether to include a row of
#'   missing/`NA` counts for that variable.
#' @param missing_text (`string`)\cr
#'   string indicating text shown on missing row. Default is `"Unknown"`.
#' @param missing_stat (`string`)\cr
#'   statistic to show on missing row. Default is `"{N_miss}"`. Possible values
#'   are `N_miss`, `N_obs`, `N_nonmiss`, `p_miss`, `p_nonmiss`.
#'
#' @return a gtsummary object
#' @name brdg_summary
#'
#' @examples
#' library(cards)
#'
#' # first build ARD data frame
#' cards <-
#'   ard_stack(
#'     mtcars,
#'     ard_summary(variables = c("mpg", "hp")),
#'     ard_tabulate(variables = "cyl"),
#'     ard_tabulate_value(variables = "am"),
#'     .missing = TRUE,
#'     .attributes = TRUE
#'   ) |>
#'   # this column is used by the `pier_*()` functions
#'   dplyr::mutate(gts_column = ifelse(context == "attributes", NA, "stat_0"))
#'
#' brdg_summary(
#'   cards = cards,
#'   variables = c("cyl", "am", "mpg", "hp"),
#'   type =
#'     list(
#'       cyl = "categorical",
#'       am = "dichotomous",
#'       mpg = "continuous",
#'       hp = "continuous2"
#'     ),
#'   statistic =
#'     list(
#'       cyl = "{n} / {N}",
#'       am = "{n} / {N}",
#'       mpg = "{mean} ({sd})",
#'       hp = c("{median} ({p25}, {p75})", "{mean} ({sd})")
#'     )
#' ) |>
#'   as_tibble()
#'
#' pier_summary_dichotomous(
#'   cards = cards,
#'   variables = "am",
#'   statistic = list(am = "{n} ({p})")
#' )
#'
#' pier_summary_categorical(
#'   cards = cards,
#'   variables = "cyl",
#'   statistic = list(cyl = "{n} ({p})")
#' )
#'
#' pier_summary_continuous2(
#'   cards = cards,
#'   variables = "hp",
#'   statistic = list(hp = c("{median}", "{mean}"))
#' )
#'
#' pier_summary_continuous(
#'   cards = cards,
#'   variables = "mpg",
#'   statistic = list(mpg = "{median}")
#' )
NULL

#' @rdname brdg_summary
#' @export
brdg_summary <- function(cards,
                         variables,
                         type,
                         statistic,
                         by = NULL,
                         missing = "no",
                         missing_stat = "{N_miss}",
                         missing_text = "Unknown") {
  set_cli_abort_call()

  # build the table body pieces with bridge functions and stack them -----------
  tbl_vars <- dplyr::tibble(
    variable = variables,
    var_type = type[.data$variable] |> unlist() |> unname()
  )

  tbl_stacked <- vctrs::vec_rbind(
    pier_summary_continuous(
      cards = cards,
      variables = .get_variables_by_type(type, type = "continuous"),
      statistic = statistic
    ),
    pier_summary_continuous2(
      cards = cards,
      variables = .get_variables_by_type(type, type = "continuous2"),
      statistic = statistic
    ),
    pier_summary_categorical(
      cards = cards,
      variables = .get_variables_by_type(type, type = "categorical"),
      statistic = statistic
    ),
    pier_summary_dichotomous(
      cards = cards,
      variables = .get_variables_by_type(type, type = "dichotomous"),
      statistic = statistic
    ),
    pier_summary_missing_row(
      cards = cards,
      variables = variables,
      missing = missing,
      missing_stat = missing_stat,
      missing_text = missing_text
    )
  )

  tbl_stacked$var_type <- tbl_vars$var_type[match(tbl_stacked$variable, tbl_vars$variable)]

  missing_vars <- setdiff(tbl_vars$variable, tbl_stacked$variable)
  if (length(missing_vars) > 0) {
    missing_df <- data.frame(
      variable = missing_vars,
      var_type = tbl_vars$var_type[match(missing_vars, tbl_vars$variable)],
      stringsAsFactors = FALSE
    )
    tbl_stacked <- vctrs::vec_rbind(tbl_stacked, missing_df)
  }

  idx <- order(match(tbl_stacked$variable, tbl_vars$variable))
  tbl_stacked <- tbl_stacked[idx, , drop = FALSE]

  cols <- c("variable", "var_type", setdiff(names(tbl_stacked), c("variable", "var_type")))
  table_body <- dplyr::as_tibble(tbl_stacked[, cols, drop = FALSE])

  # construct default table_styling --------------------------------------------
  x <- .create_gtsummary_object(table_body)

  # add info to x$table_styling$header for dynamic headers ---------------------
  x <- .add_table_styling_stats(x, cards = cards, by = by)

  # adding styling -------------------------------------------------------------
  x <- x |>
    # add header to label column and add default indentation
    modify_table_styling(
      columns = "label",
      label = glue("**{translate_string('Characteristic')}**"),
      rows = .data$row_type %in% c("level", "missing"),
      indent = 4L
    ) |>
    # adding the statistic footnote
    modify_table_styling(
      columns = all_stat_cols(),
      footnote =
        .construct_summary_footnote(cards, variables, statistic, type)
    )

  x |>
    structure(class = "gtsummary") |>
    modify_column_unhide(columns = all_stat_cols())
}

#' @rdname brdg_summary
#' @export
pier_summary_dichotomous <- function(cards,
                                     variables,
                                     statistic) {
  set_cli_abort_call()
  if (is_empty(variables)) {
    return(dplyr::tibble())
  }

  pier_summary_continuous(
    cards = cards,
    variables = variables,
    statistic = statistic
  )
}

#' @rdname brdg_summary
#' @export
pier_summary_categorical <- function(cards,
                                     variables,
                                     statistic) {
  set_cli_abort_call()
  if (is_empty(variables)) {
    return(dplyr::tibble())
  }
  # subsetting cards object on categorical summaries ----------------------------
  cards_no_attr <-
    cards |>
    dplyr::filter(.data$variable %in% .env$variables, !.data$context %in% "attributes") |>
    cards::apply_fmt_fun()

  # construct formatted statistics ---------------------------------------------
  # pivot the ARD to wide to vectorize the string interpolation. Rows with a
  # populated `variable_level` are the per-level stats (one table row each); rows
  # with a NULL `variable_level` are variable-scope stats that glue appends to
  # every level, with the level-scope stat winning on any name collision.
  stat_cols <- unique(cards_no_attr$stat_name)
  is_level <- !map_lgl(cards_no_attr$variable_level, is.null)

  level_rows <- cards_no_attr[is_level, , drop = FALSE]
  level_rows$label <- map_chr(level_rows$variable_level, as.character)
  level_wide <-
    tidyr::pivot_wider(
      level_rows,
      id_cols = c("variable", "gts_column", cards::all_ard_groups(), "label"),
      names_from = "stat_name",
      values_from = "stat_fmt",
      values_fn = list
    ) |>
    .unlist_wide_stat_cols()

  # append variable-scope stats (`gts_column` determines the by-group, so
  # (variable, gts_column) keys the join); level-scope stats win on collision
  var_rows <- cards_no_attr[!is_level, , drop = FALSE]
  if (nrow(var_rows) > 0L) {
    var_wide <-
      tidyr::pivot_wider(
        var_rows,
        id_cols = c("variable", "gts_column"),
        names_from = "stat_name",
        values_from = "stat_fmt",
        values_fn = list
      ) |>
      .unlist_wide_stat_cols()
    dup_cols <- intersect(setdiff(names(var_wide), c("variable", "gts_column")), names(level_wide))
    var_wide <- var_wide[, setdiff(names(var_wide), dup_cols), drop = FALSE]
    joined <- dplyr::left_join(level_wide, var_wide, by = c("variable", "gts_column"))
  } else {
    joined <- level_wide
  }

  # evaluate statistics per variable vectorially (one table row per level)
  df_glued <-
    lapply(
      variables,
      function(var) {
        df_var <- joined[joined$variable == var, , drop = FALSE]
        if (nrow(df_var) == 0L) {
          return(NULL)
        }
        keep_cols <- setdiff(names(df_var), stat_cols)
        out <- df_var[, keep_cols, drop = FALSE]
        out$stat <- as.character(glue::glue_data(df_var, statistic[[var]]))
        out
      }
    ) |>
    (function(lst) rlang::inject(vctrs::vec_rbind(!!!lst)))()

  # this ensures the correct order when there are 10+ groups
  df_glued <-
    dplyr::left_join(
      cards_no_attr |> dplyr::distinct(!!sym("gts_column")),
      df_glued,
      by = "gts_column"
    )

  # reshape results for final table --------------------------------------------
  df_result_levels <-
    df_glued |>
    # merge in variable label
    dplyr::left_join(
      cards |>
        dplyr::filter(
          .data$variable %in% .env$variables,
          .data$context %in% "attributes",
          .data$stat_name %in% "label"
        ) |>
        dplyr::select("variable", var_label = "stat"),
      by = "variable"
    ) |>
    dplyr::mutate(
      .by = "variable",
      row_type = "level",
      var_label = unlist(.data$var_label),
      .after = 0L
    ) |>
    tidyr::pivot_wider(
      id_cols = c("row_type", "var_label", "variable", "label"),
      names_from = "gts_column",
      values_from = "stat"
    )

  # add header rows to results -------------------------------------------------
  df_results <-
    map(
      variables,
      ~ dplyr::bind_rows(
        df_result_levels |>
          dplyr::select("variable", "var_label", "row_type") |>
          dplyr::filter(.data$variable %in% .x) |>
          dplyr::filter(dplyr::row_number() %in% 1L) |>
          dplyr::mutate(
            label = .data$var_label,
            row_type = "label"
          ),
        df_result_levels |>
          dplyr::filter(.data$variable %in% .x)
      )
    ) |>
    dplyr::bind_rows()

  df_results
}

#' @rdname brdg_summary
#' @export
pier_summary_continuous2 <- function(cards,
                                     variables,
                                     statistic) {
  set_cli_abort_call()
  if (is_empty(variables)) {
    return(dplyr::tibble())
  }
  # subsetting cards object on continuous2 summaries ----------------------------
  cards_no_attr <-
    cards |>
    dplyr::filter(.data$variable %in% .env$variables, !.data$context %in% "attributes") |>
    cards::apply_fmt_fun()

  # construct formatted statistics ---------------------------------------------
  # pivot the ARD to wide to vectorize the string interpolation. Two wide frames
  # are needed: formatted values (for the stat) and stat labels (continuous2
  # glues each row's label from the stat labels).
  stat_cols <- unique(cards_no_attr$stat_name)
  fmt_wide <-
    tidyr::pivot_wider(
      cards_no_attr,
      id_cols = c("variable", "gts_column", cards::all_ard_groups()),
      names_from = "stat_name",
      values_from = "stat_fmt",
      values_fn = list
    ) |>
    .unlist_wide_stat_cols()
  label_wide <-
    tidyr::pivot_wider(
      cards_no_attr,
      id_cols = c("variable", "gts_column", cards::all_ard_groups()),
      names_from = "stat_name",
      values_from = "stat_label",
      values_fn = list
    ) |>
    .unlist_wide_stat_cols()

  # evaluate statistics per variable vectorially; one output row per statistic
  # element (continuous2 statistics are vectors)
  df_glued <-
    lapply(
      variables,
      function(var) {
        df_fmt <- fmt_wide[fmt_wide$variable == var, , drop = FALSE]
        df_lbl <- label_wide[label_wide$variable == var, , drop = FALSE]
        if (nrow(df_fmt) == 0L) {
          return(NULL)
        }
        keep_cols <- setdiff(names(df_fmt), stat_cols)
        lapply(
          statistic[[var]],
          function(str_to_glue) {
            out <- df_fmt[, keep_cols, drop = FALSE]
            out$stat <- as.character(glue::glue_data(df_fmt, str_to_glue))
            out$label <- as.character(glue::glue_data(df_lbl, str_to_glue))
            out
          }
        ) |>
          (function(lst) rlang::inject(vctrs::vec_rbind(!!!lst)))()
      }
    ) |>
    (function(lst) rlang::inject(vctrs::vec_rbind(!!!lst)))()

  # this ensures the correct order when there are 10+ groups
  df_glued <-
    dplyr::left_join(
      cards_no_attr |> dplyr::distinct(!!sym("gts_column")),
      df_glued,
      by = "gts_column"
    )

  # reshape results for final table --------------------------------------------
  df_result_levels <-
    df_glued |>
    # merge in variable label
    dplyr::left_join(
      cards |>
        dplyr::filter(
          .data$variable %in% .env$variables,
          .data$context %in% "attributes",
          .data$stat_name %in% "label"
        ) |>
        dplyr::select("variable", var_label = "stat"),
      by = "variable"
    ) |>
    dplyr::mutate(
      .by = "variable",
      row_type = "level",
      var_label = unlist(.data$var_label),
      .after = 0L
    ) |>
    tidyr::pivot_wider(
      id_cols = c("row_type", "var_label", "variable", "label"),
      names_from = "gts_column",
      values_from = "stat"
    )

  # add header rows to results -------------------------------------------------
  df_results <-
    map(
      variables,
      ~ dplyr::bind_rows(
        df_result_levels |>
          dplyr::select("variable", "var_label", "row_type") |>
          dplyr::filter(.data$variable %in% .x) |>
          dplyr::filter(dplyr::row_number() %in% 1L) |>
          dplyr::mutate(
            label = .data$var_label,
            row_type = "label"
          ),
        df_result_levels |>
          dplyr::filter(.data$variable %in% .x)
      )
    ) |>
    dplyr::bind_rows()

  df_results
}

#' @rdname brdg_summary
#' @export
pier_summary_continuous <- function(cards,
                                    variables,
                                    statistic) {
  set_cli_abort_call()
  if (is_empty(variables)) {
    return(dplyr::tibble())
  }
  # subsetting cards object on statistical summaries ---------------------------
  cards_no_attr <-
    cards |>
    dplyr::filter(.data$variable %in% .env$variables, !.data$context %in% "attributes") |>
    cards::apply_fmt_fun()

  # construct formatted statistics ---------------------------------------------
  # pivot the ARD to wide format to vectorize the string interpolation
  df_wide <- tidyr::pivot_wider(
    cards_no_attr,
    id_cols = c("variable", "gts_column", cards::all_ard_groups()),
    names_from = "stat_name",
    values_from = "stat_fmt",
    values_fn = list
  )

  # unlist any list columns to allow direct glue data evaluation
  df_wide <- .unlist_wide_stat_cols(df_wide)

  split_df <- split(df_wide, df_wide$variable)
  stat_cols <- unique(cards_no_attr$stat_name)

  # evaluate statistics per variable vectorially
  df_glued <- lapply(variables, function(var) {
    df_var <- split_df[[var]]
    if (is.null(df_var) || nrow(df_var) == 0) {
      return(NULL)
    }

    glued <- glue::glue_data(df_var, statistic[[var]])

    # Keep the original identifying columns and append the formatted string
    keep_cols <- setdiff(names(df_var), stat_cols)
    out <- df_var[, keep_cols, drop = FALSE]
    out$stat <- as.character(glued)
    out
  }) |>
    (function(lst) rlang::inject(vctrs::vec_rbind(!!!lst)))()

  # this ensures the correct order when there are 10+ groups
  df_glued <-
    dplyr::left_join(
      cards_no_attr |> dplyr::distinct(!!sym("gts_column")),
      df_glued,
      by = "gts_column"
    )

  # reshape results for final table --------------------------------------------
  df_results <-
    df_glued |>
    # merge in variable label
    dplyr::left_join(
      cards |>
        dplyr::filter(
          .data$variable %in% .env$variables,
          .data$context %in% "attributes",
          .data$stat_name %in% "label"
        ) |>
        dplyr::select("variable", var_label = "stat"),
      by = "variable"
    ) |>
    dplyr::mutate(
      .by = "variable",
      row_type = "label",
      var_label = unlist(.data$var_label),
      label = .data$var_label,
      .after = 0L
    ) |>
    tidyr::pivot_wider(
      id_cols = c("row_type", "var_label", "variable", "label"),
      names_from = "gts_column",
      values_from = "stat"
    )

  df_results
}

# unlist the list-columns produced by `pivot_wider(values_fn = list)` so the wide
# stat columns can be passed directly to `glue::glue_data()`. Length-1 cells
# become scalars (NULL -> NA); longer cells stay lists (NULL -> NA element-wise).
# Shared by the vectorized `pier_summary_*()` builders.
.unlist_wide_stat_cols <- function(df_wide) {
  for (col in names(df_wide)) {
    if (is.list(df_wide[[col]])) {
      df_wide[[col]] <- lapply(df_wide[[col]], function(x) {
        if (length(x) == 1) {
          val <- x[[1]]
          if (is.null(val)) NA else val
        } else {
          lapply(x, function(v) if (is.null(v)) NA else v)
        }
      })
      if (all(lengths(df_wide[[col]]) == 1) && !any(vapply(df_wide[[col]], is.list, logical(1)))) {
        df_wide[[col]] <- unlist(df_wide[[col]], use.names = FALSE)
      }
    }
  }
  df_wide
}

#' @rdname brdg_summary
#' @export
pier_summary_missing_row <- function(cards,
                                     variables,
                                     missing = "no",
                                     missing_stat = "{N_miss}",
                                     missing_text = "Unknown") {
  set_cli_abort_call()

  # 2026-06-29: `missing=` may be a per-variable named list (one of
  # "ifany"/"no"/"always" per variable) or a single scalar string. A scalar is
  # supported shorthand (for now) and is expanded to apply to all variables.
  if (!is.list(missing)) {
    missing <- rep_named(variables, list(missing))
  }

  # return empty tibble if no variables or no missing row requested for any var
  variables <- intersect(variables, names(missing))
  if (is_empty(variables)) {
    return(dplyr::tibble())
  }

  # drop variables whose missing setting is "no"
  variables <- variables[map_chr(missing[variables], identity) != "no"]
  if (is_empty(variables)) {
    return(dplyr::tibble())
  }

  # for "ifany" variables, keep only those that actually have missing values
  ifany_vars <- variables[map_chr(missing[variables], identity) == "ifany"]
  if (!is_empty(ifany_vars)) {
    ifany_with_miss <-
      cards |>
      dplyr::filter(.data$stat_name == "N_miss", .data$variable %in% .env$ifany_vars) |>
      dplyr::filter(.data$stat > 0) |>
      dplyr::pull("variable") |>
      unique()
    # drop "ifany" variables that have no missing values (preserve order)
    drop_ifany <- setdiff(ifany_vars, ifany_with_miss)
    variables <- setdiff(variables, drop_ifany)
  }

  if (is_empty(variables)) {
    return(dplyr::tibble())
  }

  # slightly modifying the `x` object for missing value calculations -----------
  # make all the summary stats the same for all vars
  statistic <- rep_named(variables, list(missing_stat))

  # reshape the missing stats
  pier_summary_continuous(
    cards = cards,
    variables = variables,
    statistic = statistic
  ) |>
    # update the row_type and label
    dplyr::mutate(
      row_type = "missing",
      label = missing_text
    )
}

.add_table_styling_stats <- function(x, cards, by) {
  if (is_empty(by)) {
    x$table_styling$header$modify_stat_level <- translate_string("Overall")

    # add overall N to x$table_styling$header
    lst_total_n <- cards::get_ard_statistics(cards, .data$variable %in% "..ard_total_n..")
    if ("N" %in% names(lst_total_n)) {
      x$table_styling$header <-
        x$table_styling$header |>
        dplyr::mutate(
          modify_stat_N = lst_total_n[["N"]],
          modify_stat_n = .data$modify_stat_N,
          modify_stat_p = 1
        )
    }

    # if this is a survey object, then add unweighted stats as well
    if ("N_unweighted" %in% names(lst_total_n)) {
      x$table_styling$header <-
        x$table_styling$header |>
        dplyr::mutate(
          modify_stat_N_unweighted = lst_total_n[["N_unweighted"]],
          modify_stat_n_unweighted = .data$modify_stat_N_unweighted,
          modify_stat_p_unweighted = 1
        )
    }
  }
  # add by variable stats
  else {
    df_by_stats <- cards |>
      dplyr::filter(
        .data$variable %in% .env$by,
        .data$stat_name %in% c("N", "n", "p", "N_unweighted", "n_unweighted", "p_unweighted")
      )

    # if no tabulation of the 'by' variable provided, just return the 'by' levels
    if (nrow(df_by_stats) == 0L) {
      df_by_stats_wide <-
        cards |>
        dplyr::select(column = "gts_column", modify_stat_level = "group1_level") |>
        dplyr::distinct() |>
        dplyr::filter(!is.na(.data$column) & !map_lgl(.data$modify_stat_level, is.null)) |>
        dplyr::mutate(across(everything(), ~ unlist(.) |> as.character()))
    }
    # otherwise prepare the tabulation stats
    else {
      df_by_stats_wide <-
        df_by_stats |>
        dplyr::filter(.data$stat_name %in% c("N", "n", "p", "N_unweighted", "n_unweighted", "p_unweighted")) |>
        dplyr::select(cards::all_ard_variables(), "stat_name", "stat") |>
        dplyr::inner_join(
          cards |>
            dplyr::select(cards::all_ard_groups(), "gts_column") |>
            dplyr::filter(!is.na(.data$gts_column) & !is.na(.data$group1)) |>
            dplyr::distinct() |>
            dplyr::rename(variable = "group1", variable_level = "group1_level"),
          by = c("variable", "variable_level")
        ) %>%
        dplyr::bind_rows(
          dplyr::select(., "variable_level", "gts_column", stat = "variable_level") |>
            dplyr::mutate(stat_name = "level") |>
            dplyr::distinct()
        ) |>
        tidyr::pivot_wider(
          id_cols = "gts_column",
          names_from = "stat_name",
          values_from = "stat"
        ) |>
        dplyr::mutate(
          dplyr::across(-"gts_column", unlist),
          dplyr::across("level", as.character)
        ) |>
        dplyr::rename_with(
          function(x) paste0("modify_stat_", x),
          .cols = -"gts_column"
        ) |>
        dplyr::rename(column = "gts_column")
    }

    # add the stats here to the header data frame
    x$table_styling$header <-
      x$table_styling$header |>
      dplyr::left_join(
        df_by_stats_wide,
        by = "column"
      ) |>
      tidyr::fill(any_of(c("modify_stat_N", "modify_stat_N_unweighted")), .direction = "updown")
  }

  # re-ording the columns
  x$table_styling$header <-
    x$table_styling$header |>
    dplyr::relocate(
      any_of(c(
        "modify_stat_level",
        "modify_stat_N", "modify_stat_n", "modify_stat_p",
        "modify_stat_N_unweighted", "modify_stat_n_unweighted", "modify_stat_p_unweighted"
      )),
      .before = last_col()
    )

  # return final object
  x
}