R/grouped_tbl_pivot_wider.R

Defines functions style_grouped_tbl multinom_add_global_p_pivot_wider grouped_tbl_pivot_wider

Documented in grouped_tbl_pivot_wider multinom_add_global_p_pivot_wider style_grouped_tbl

#' Helpers for grouped tables generated with `gtsummary`
#'
#' A series of helpers for grouped tables generated by `tbl_regression()` in
#' case of multinomial models, multi-components models or other grouped results.
#' `grouped_tbl_pivot_wider()` allows to display results in a a wide format,
#' with one set of columns per group. `multinom_add_global_p_pivot_wider()` is
#' a specific case for multinomial models, when displaying global p-values in a
#' wide format: it calls [gtsummary::add_global_p()], followed by
#' `grouped_tbl_pivot_wider()`, and then keep only the last column with p-values
#' (see examples). Finally, as grouped regression tables doesn't have exactly
#' the same structure as ungrouped tables, functions as
#' [gtsummary::bold_labels()] do not always work properly. If the grouped table
#' is kept in a long format, `style_grouped_tbl()` could be use to improve the
#' output by styling variable labels, levels and/or group names.
#' **TO BE NOTED:** to style group names, `style_grouped_tbl()` convert the
#' table into a `gt` object with [gtsummary::as_gt()]. This function should
#' therefore be used last. If the table is intended to be exported to another
#' format, do not use `style_grouped_tbl()`.
#' @export
#' @param x A grouped regression table generated with
#' [gtsummary::tbl_regression()].
#' @returns A `gtsummary` or a `gt` table.
#' @keywords models
#' @examplesIf rlang::is_installed(c("gtsummary", "cardx", "nnet", "parameters"))
#' mod <- nnet::multinom(
#'   grade ~ stage + marker + age,
#'   data = gtsummary::trial,
#'   trace = FALSE
#' )
#' tbl <- mod |> gtsummary::tbl_regression(exponentiate = TRUE)
#' tbl
#' tbl |> grouped_tbl_pivot_wider()
#'
#' \donttest{
#' tbl |> multinom_add_global_p_pivot_wider() |> gtsummary::bold_labels()
#' tbl |> style_grouped_tbl()
#' }
grouped_tbl_pivot_wider <- function(x) {
  rlang::check_installed("gtsummary")
  if (!inherits(x, "tbl_regression"))
    cli::cli_abort(
      "{.arg x} must be a table generated with {.fn gtsummary::tbl_regression}."
    )
  if (!"groupname_col" %in% colnames(x$table_body))
    cli::cli_abort(
      "{.arg x} is not a grouped table."
    )

  df <- dplyr::tibble(outcome_level = unique(x$table_body$groupname_col))
  df$tbl <-
    purrr::map(
      df$outcome_level,
      function(lvl) {
        gtsummary::modify_table_body(
          x,
          ~ dplyr::filter(.x, .data$groupname_col %in% lvl) |>
            dplyr::ungroup() |>
            dplyr::select(-dplyr::any_of("groupname_col"))
        )
      }
    )

  gtsummary::tbl_merge(
    df$tbl,
    tab_spanner = paste0("**", df$outcome_level, "**")
  )
}

#' @rdname grouped_tbl_pivot_wider
#' @param ... Additional arguments passed to [gtsummary::add_global_p()].
#' @param p_value_header Header for the p-value column.
#' @export
multinom_add_global_p_pivot_wider <- function(
  x,
  ...,
  p_value_header = "**Likelihood-ratio test**"
) {
  rlang::check_installed("gtsummary")
  res <- x |>
    gtsummary::add_global_p(...) |>
    grouped_tbl_pivot_wider()
  last_p <- res$table_body |>
    dplyr::select(dplyr::starts_with("p.value")) |>
    colnames() |>
    utils::tail(n = 1L)
  res |>
    gtsummary::modify_column_hide(dplyr::starts_with("p.value")) |>
    gtsummary::modify_column_unhide(dplyr::all_of(last_p)) |>
    gtsummary::modify_spanning_header(dplyr::all_of(last_p) ~ p_value_header)
}

#' @rdname grouped_tbl_pivot_wider
#' @param bold_groups Bold group group names?
#' @param uppercase_groups Convert group names to upper case?
#' @param bold_labels Bold variable labels?
#' @param italicize_labels Italicize variable labels?
#' @param indent_labels Number of spaces to indent variable labels.
#' @param bold_levels Bold levels?
#' @param italicize_levels Italicize levels?
#' @param indent_levels Number of spaces to indent levels.
#' @export
style_grouped_tbl <- function(
  x,
  bold_groups = TRUE,
  uppercase_groups = TRUE,
  bold_labels = FALSE,
  italicize_labels = TRUE,
  indent_labels = 4L,
  bold_levels = FALSE,
  italicize_levels = FALSE,
  indent_levels = 8L
) {
  rlang::check_installed("gtsummary")
  if (!inherits(x, "tbl_regression"))
    cli::cli_abort(
      "{.arg x} must be a table generated with {.fn gtsummary::tbl_regression}."
    )
  if (!"groupname_col" %in% colnames(x$table_body))
    cli::cli_abort(
      "{.arg x} is not a grouped table."
    )
  if (bold_labels)
    x <- x |>
      gtsummary::modify_bold(
        columns = dplyr::all_of("label"),
        rows = .data$row_type == "label"
      )
  if (italicize_labels)
    x <- x |>
      gtsummary::modify_italic(
        columns = dplyr::all_of("label"),
        rows = .data$row_type == "label"
      )
  x <- x |>
    gtsummary::modify_column_indent(
      columns = dplyr::all_of("label"),
      rows = .data$row_type == "label",
      indent = indent_labels
    )
  if (bold_levels)
    x <- x |>
      gtsummary::modify_bold(
        columns = dplyr::all_of("label"),
        rows = .data$row_type == "level"
      )
  if (italicize_levels)
    x <- x |>
      gtsummary::modify_italic(
        columns = dplyr::all_of("label"),
        rows = .data$row_type == "level"
      )
  x <- x |>
    gtsummary::modify_column_indent(
      columns = dplyr::all_of("label"),
      rows = .data$row_type == "level",
      indent = indent_levels
    )

  if (bold_groups || uppercase_groups)
    x <- x |> gtsummary::as_gt()

  if (bold_groups)
    x <- x |> gt::tab_options(row_group.font.weight = "bold")

  if (uppercase_groups)
    x <- x |> gt::tab_options(row_group.text_transform = "uppercase")

  x
}

Try the guideR package in your browser

Any scripts or data that you put into this service are public.

guideR documentation built on June 8, 2025, noon