tbl_cmh.R

#' @import dplyr %>%
#' @import purrr %||%
tbl_cmh <- function(data, case, exposure, strata, 
                    label = NULL, 
                    estimate_fun = gtsummary::style_ratio, 
                    overall_or = TRUE,
                    overall_label = "Crude") {
  # converting selectors to character names ------------------------------------
  case <- dplyr::select(data, {{ case }}) %>% names()
  exposure <- dplyr::select(data, {{ exposure }}) %>% names()
  strata <- dplyr::select(data, {{ strata }}) %>% names()
  label <- 
    broom.helpers::.formula_list_to_named_list(
      label, 
      data = select(data, dplyr::all_of(strata))
    )
  
  # subsetting dataset and deleting missing obs --------------------------------
  data <- 
    data %>%
    dplyr::select(dplyr::all_of(c(case, exposure, strata))) %>%
    tidyr::drop_na() 
  
  # calcuating counts within stratum -------------------------------------------
  tbl <-
    strata %>%
    purrr::imap(
      function(strata_variable, n) {
        margin_assignment <- switch(n == 1 & overall_or == TRUE, "row") # only include crude for first row
        df_strata <-
          data %>%
          dplyr::select(dplyr::all_of(c(case, strata_variable, exposure))) %>%
          tidyr::nest(data = -dplyr::all_of(case)) %>%
          dplyr::mutate(
            tbl = purrr::map(data, ~gtsummary::tbl_cross(.x, label = label, 
                                                         margin = margin_assignment,
                                                         margin_text = overall_label))
          )
        gtsummary::tbl_merge(df_strata$tbl, tab_spanner = as.character(df_strata$case))
      }
    ) %>%
    # stacking all tables across all stratum
    gtsummary::tbl_stack() %>%
    # moving the overall column to the top
    gtsummary::modify_table_body(
      dplyr::arrange,
      dplyr::desc(.data$variable == "..total..")
    ) %>%
    # remove automatic bolding
    gtsummary::modify_table_header("label", bold = NA_character_)
  
  # calculating ORs within stratum ---------------------------------------------
  df_or <-
    strata %>%
    purrr::map_dfr(
      ~data %>%
        dplyr::select(dplyr::all_of(c(.x, exposure, case))) %>%
        tidyr::nest(data = -dplyr::all_of(.x)) %>%
        dplyr::mutate(
          variable = .x,
          label = as.character(!!rlang::sym(.x)),
          row_type = "level",
          or = purrr::map_chr(
            data,
            ~with(.x, effectsize::oddsratio(!!rlang::sym(exposure), !!rlang::sym(case))) %>%
              as.data.frame() %>%
              dplyr::mutate_at(dplyr::vars(.data$Odds_ratio, .data$CI_low, .data$CI_high), estimate_fun) %>%
              dplyr::mutate(or = stringr::str_glue("{Odds_ratio} ({CI_low}, {CI_high})")) %>%
              dplyr::pull(or)
          )
        ) %>%
        dplyr::select(.data$variable, .data$row_type, .data$label, .data$or)
    ) 
  if (overall_or == TRUE) {
    df_crude_or <-
      tibble::tibble(variable = "..total..") %>%
      dplyr::mutate(
        label = overall_label,
        row_type = "label",
        or = with(data, effectsize::oddsratio(!!rlang::sym(exposure), !!rlang::sym(case))) %>%
          as.data.frame() %>%
          dplyr::mutate_at(dplyr::vars(.data$Odds_ratio, .data$CI_low, .data$CI_high), estimate_fun) %>%
          dplyr::mutate(or = stringr::str_glue("{Odds_ratio} ({CI_low}, {CI_high})")) %>%
          dplyr::pull(or)
      )
    
    df_or <- dplyr::bind_rows(df_crude_or, df_or)
  }
  
  # adding ORs to gtsummary table
  tbl <-
    tbl %>%
    gtsummary::modify_table_body(
      dplyr::left_join,
      df_or,
      by = c("variable", "row_type", "label")
    ) %>%
    gtsummary::modify_table_header("or", hide = FALSE, label = "**Odds Ratio**")
  
  # adding CMH ORs to tbl ------------------------------------------------------
  df_cmh_or <-
    strata %>%
    purrr::map_dfr(
      ~stats::mantelhaen.test(data[[case]], data[[exposure]], data[[.x]]) %>%
        broom::tidy() %>%
        dplyr::mutate_at(dplyr::vars(estimate, conf.low, conf.high), ~estimate_fun(1 / .)) %>%
        dplyr::mutate(
          variable = .x,
          row_type = "label",
          cmh_or = glue::glue("{estimate} ({conf.high}, {conf.low})")
        ) %>%
        dplyr::select(.data$variable, .data$row_type, .data$cmh_or, .data$p.value)
    )
  
  tbl <-
    tbl %>%
    gtsummary::modify_table_body(
      dplyr::left_join,
      df_cmh_or,
      by = c("variable", "row_type")
    ) %>%
    gtsummary::modify_table_header(
      "cmh_or",
      hide = FALSE,
      label = "**CMH Odds Ratio**"
    ) %>%
    gtsummary::modify_table_header(
      "p.value",
      hide = FALSE,
      fmt_fun = gtsummary::style_pvalue,
      label = "**p-value**"
    ) 
  
  # bolding all the column headers ---------------------------------------------
  tbl$table_header <-
    tbl$table_header %>%
    dplyr::mutate(
      label = dplyr::if_else(
        hide == FALSE & !startsWith(label, "**") & !endsWith(label, "**"),
        paste0("**", label, "**"),
        label
      ),
      spanning_header = dplyr::if_else(
        hide == FALSE & !startsWith(spanning_header, "**") & !endsWith(spanning_header, "**"),
        paste0("**", spanning_header, "**"),
        spanning_header
      )
    )
  
  # returning final table ------------------------------------------------------
  class(tbl) <- c("tbl_cmh", "gtsummary")
  tbl
}

library(gtsummary)
library(dplyr)

trial %>%
  # creating a dataset with case-control and exposure status
  select(exposure = response, case = death, grade, stage) %>%
  mutate(exposure = factor(exposure, labels = c("Not Exposed", "Exposed")),
         case = factor(case, labels = c("Control", "Case"))) %>%
  # calculating the CMH OR and tabling the results
  tbl_cmh(case = case, 
          exposure = exposure, 
          strata = c(grade, stage), 
          label = grade ~ "Tumor Grade",
          overall_or = TRUE, 
          overall_label = "Overall") %>%
  # the table is a gtsummary object, so you can use add any general gtsummary function 
  bold_labels() %>%
  bold_p()

With the new update of gtsummary, the tbl_cmh() function no longer works; there are things to fix.