tbl_summary 能否同时显示变量的级别和子级别（即，用于汇总统计列）？

Question

我正在使用 tbl_summary 制作表格，我想知道是否可以按净度级别细分 diamond_cat 标签，同时保留两者的摘要统计信息？我也会附上一张我设想的桌子的图片：

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()
    

我是 R 的新手。提前感谢您的帮助。

Answer 1

是的，这是可能的。但是，tbl_summary() 在编写时并未考虑到此功能，因此使其工作的代码很复杂。下面的例子！

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"
  )

^{由reprex package (v2.0.1) 于 2021-08-21 创建}