Search code examples
rgtsummary

Can tbl_summary display both levels and sub-levels of a variable (i.e., for summary stats column)?

I am making a table with tbl_summary and I wonder if it is possible to have the breakdown of diamond_cat labels by clarity levels, while retaining the summary stats for both? I will attach an image of the table I envision as well:

library(gtsummary)
library(forcats)
data(diamonds)
table(diamonds$clarity)
# I1   SI2   SI1   VS2   VS1  VVS2 
# 741  9194 13065 12258  8171  5066 
# VVS1    IF 
# 3655  1790 

diamond_cat <- fct_collapse(diamonds$clarity,
                            "Internally flawless" = "IF",
                            "Very very slightly included" = c("VVS1", "VVS2"),
                            "Very slightly included" = c("VS1", "VS2"),
                            "Slightly included" = c("SI1", "SI2"),
                            "Included" = "I1")
# add new variable to data set
diamonds$diamond_cat <- diamond_cat

diamonds %>% select(diamond_cat) %>% tbl_summary()
#diamonds %>% select(clarity) %>% tbl_summary()

enter image description here

I am fairly new to R. Thank you in advance for your help.

Solution

  • Yes, it is possible. BUT, the tbl_summary() wasn't written with this functionality in mind, so the code to make it work is complex. Example below!

    library(gtsummary)

# save recodes because they will be used more than once
clarity_recodes <-
  list(
    "Internally flawless" = "IF",
    "Very very slightly included" = c("VVS1", "VVS2"),
    "Very slightly included" = c("VS1", "VS2"),
    "Slightly included" = c("SI1", "SI2"),
    "Included" = "I1"
  )

# build typical tbl_summary with the recoded clarity data
tbl1 <-
  ggplot2::diamonds %>%
  mutate(
    clarity_cat = forcats::fct_collapse(clarity, !!!clarity_recodes)
  ) %>%
  select(clarity_cat) %>%
  tbl_summary(label = clarity_cat ~ "Diamond Clarity")

# create a tibble of recoded summary stats
tbl2 <-
  ggplot2::diamonds %>%
  select(clarity) %>%
  tbl_summary() %>%
  modify_column_unhide(c(row_type)) %>%
  as_tibble(col_labels = FALSE) %>%
  dplyr::left_join(
    clarity_recodes %>% 
      tibble::enframe("label2", "label") %>% 
      tidyr::unnest(cols = c(label)),
    by = "label"
  ) %>%
  dplyr::with_groups(label2, ~dplyr::filter(.x, row_type == "level", dplyr::n() > 1)) %>%
  mutate(row_type = "double_indent") %>%
  tidyr::nest(data = -c(label2)) %>%
  dplyr::rename(label = label2)

# merge in the tibble with clarity details into the larger summary table
tbl_final <-
  tbl1 %>%
  modify_table_body(
    ~.x %>%
      dplyr::left_join(tbl2, by = c("label")) %>%
      dplyr::mutate(
        data =
          purrr::pmap(
            list(data, row_type, label, stat_0), 
            function(data, row_type, label, stat_0) {
              df <- tibble::tibble(
                row_type = row_type, 
                label = label,
                stat_0 = stat_0
              )
              if (!is.null(data)) return(dplyr::bind_rows(df, data))
              else return(df)
            }
          )
      ) %>%
      select(-row_type, -label, -stat_0) %>%
      tidyr::unnest(data)
  ) %>%
  modify_table_styling(
    columns = c(label, stat_0),
    rows = row_type == "double_indent",
    text_format = "indent2"
  ) %>%
  modify_table_styling(
    columns = stat_0,
    align  = "left"
  )

    enter image description here Created on 2021-08-21 by the reprex package (v2.0.1)