Performance improvement of `gtsummary`

[averissimo]

Two main packages that need optimizing are:

• 📦 {cards}: https://github.com/insightsengineering/cards
• 📦 {gtsummary}: https://github.com/ddsjoberg/gtsummary

These are very interconnected, and it seems that 📦 {cards} package has the most urgent need to improve.

Improvement suggestions:

1. Improve tibble operations (low hanging fruit: see last section below)
   • Initialization of new 📦 {tibble} is not efficient when performed many times over
   • Mutates and other operations may be simplified and avoided
2. Long and complex functions
   • gtsummary::tbl_summmary() is 305 lines long
   • cards::.calculate_stats_as_ard() has 3 levels of loops
3. Consistent data structures
   • Internal functions create objects that need conversion (list to tibble)
   • This may be efficient if done with other calls
4. Optimize data needs in internal operations (reduce need to copy data)
5. Use of 📦 {vctrs} and/or 📦 {data.table} packages for internal operations
6. Refactor code to reduce high need of number of gc operations

# How to get a profile of the main running function:
iris |>
  gtsummary::tbl_summary(
    by = Species,
    type = gtsummary::all_continuous() ~ "continuous2",
    statistic = gtsummary::all_continuous() ~ c("{mean}", "{sd}")
  ) |> 
    profvis::profvis()

Call to gtsummary::tbl_summary() (~300ms) is divided in (scale is ms, but best to think of it as relative units of time):

ℹ️ Click on functions below to open the benchmarks
ℹ️2️⃣ benchmark-poc branch shows how to use low-level constructors to achieve the same result

cards::ard_summary(): 110ms

# ard_summary()
bench::mark(
  check = FALSE,
  min_iterations = 100,
  ard_summary_1_1 = cards::ard_summary(ADSL, by = c("ARM"), variables = c("AGE")),
  ard_summary_2_2 = cards::ard_summary(ADSL, by = c("ARM", "SEX"), variables = c("AGE", "WEIGHTBL"))
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> 1️⃣ <main> branch
#> # A tibble: 2 × 4
#>   expression        median  n_gc mem_alloc
#>   <bch:expr>      <bch:tm> <dbl> <bch:byt>
#> 1 ard_summary_1_1    115ms    59   911.4KB
#> 2 ard_summary_2_2    368ms   189     1.9MB

#> 2️⃣ <benchmark-poc> branch
#> # A tibble: 2 × 4
#>   expression        median  n_gc mem_alloc
#>   <bch:expr>      <bch:tm> <dbl> <bch:byt>
#> 1 ard_summary_1_1   35.5ms    19    1.75MB
#> 2 ard_summary_2_2   52.2ms    30    1.93MB

gtsummary:::brdg_summary(): 90ms

# gtsummary:::brdg_summary
cards <- cards::ard_stack(
    mtcars,
    cards::ard_summary(variables = c("mpg", "hp")),
    cards::ard_tabulate(variables = "cyl"),
    cards::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"))
#'
bench::mark(
  min_iterations = 100,
  brdg_summary = gtsummary::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})")
      )
  )
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> 1️⃣ <main> branch
#> # A tibble: 1 × 4
#>   expression     median  n_gc mem_alloc
#>   <bch:expr>   <bch:tm> <dbl> <bch:byt>
#> 1 brdg_summary    141ms    79     921KB

#> 2️⃣ <benchmark-poc> branch (same)
# not affected by changes

gtsummary::ard_missing(): 50ms

# gtsummary::ard_missing()
bench::mark(
  check = FALSE,
  min_iterations = 100,
  ard_missing_with_by = ard_missing(cards::ADSL, by = "ARM", variables = "AGE"),
  ard_missing_dplyr_group = cards::ADSL |>
    dplyr::group_by(ARM) |>
    ard_missing(
      variables = "AGE",
      statistic = ~"N_miss"
    )
  ) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> 1️⃣ <main> branch
#> # A tibble: 2 × 4
#>   expression                median  n_gc mem_alloc
#>   <bch:expr>              <bch:tm> <dbl> <bch:byt>
#> 1 ard_missing_with_by       40.3ms    20     537KB
#> 2 ard_missing_dplyr_group   38.4ms    21     581KB

#> 2️⃣ <benchmark-poc> branch
#> # A tibble: 2 × 4
#>   expression                median  n_gc mem_alloc
#>   <bch:expr>              <bch:tm> <dbl> <bch:byt>
#> 1 ard_missing_with_by       35.8ms    26  695.02KB
#> 2 ard_missing_dplyr_group   39.6ms    26    1.18MB

cards::ard_total_n(): 30ms

# cards::ard_total_n()
bench::mark(
  min_iterations = 100,
  ard_total_n(ADSL)
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> 1️⃣ <main> branch
#> # A tibble: 1 × 4
#>   expression          median  n_gc mem_alloc
#>   <bch:expr>        <bch:tm> <dbl> <bch:byt>
#> 1 ard_total_n(ADSL)   33.1ms    17     172KB

#> 2️⃣ <benchmark-poc> branch (not affected by changes)

cards::ard_tabulate(): 20ms

# cards::ard_tabulate()
bench::mark(
  check = FALSE,
  min_iterations = 100,
  ard_tabulate_by = cards::ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1"),
  ard_tabulate_dplyr_group = cards::ADSL |>
    dplyr::group_by(ARM) |>
    cards::ard_tabulate(
      variables = "AGEGR1",
      statistic = everything() ~ "n"
    )
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> 1️⃣ <main> branch
#> # A tibble: 2 × 4
#>   expression                 median  n_gc mem_alloc
#>   <bch:expr>               <bch:tm> <dbl> <bch:byt>
#> 1 ard_tabulate_by            38.5ms    22     297KB
#> 2 ard_tabulate_dplyr_group   30.8ms    16     217KB

#> 2️⃣ <benchmark-poc> branch (not affected by changes)

cards::bind_ard(): 10ms

# cards::bind_ard()
ard <- ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1")
bench::mark(
  min_iterations = 100,
  bind_ard = cards::bind_ard(ard, ard, .update = TRUE)
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> 1️⃣ <main> branch
#> # A tibble: 1 × 4
#>   expression   median  n_gc mem_alloc
#>   <bch:expr> <bch:tm> <dbl> <bch:byt>
#> 1 bind_ard       19ms    11    81.8KB

#> 2️⃣ <benchmark-poc> branch (not affected by changes)

gtsummary:::.check_stats_available(): 10ms

# gtsummary:::.check_stats_available()
cards <- cards::bind_ard(
  cards::ard_categorical(
    mtcars,
    by = "mpg",
    variables = c("cyl", "am")
  ),
  cards::ard_continuous(
    mtcars,
    by = "mpg",
    variables = "hp",
    statistic = list(hp ~ continuous_summary_fns(c("mean", "sd", "median", "p25", "p75")))
  )
)

bench::mark(
  min_iterations = 1000,
  ".check_stats_available" = .check_stats_available(
    cards = cards,
    statistic = list(
      cyl = "{n} / {N}",
      am = "{n} / {N}",
      hp = "{mean} ({sd})"
    )
  )
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> 1️⃣ <main> branch
#> # A tibble: 1 × 4
#>   expression               median  n_gc mem_alloc
#>   <bch:expr>             <bch:tm> <dbl> <bch:byt>
#> 1 .check_stats_available   2.71ms     9     159KB

#> 2️⃣ <benchmark-poc> branch (not affected by changes)

cards::replace_null_statistic(): 10ms

# cards::replace_null_statistic()
cards <- data.frame(x = rep_len(NA_character_, 10)) |>
  cards::ard_summary(
    variables = x,
    statistic = ~ cards::continuous_summary_fns(c("median", "p25", "p75"))
  )
bench::mark(
  min_iterations = 100,
  replace_null_statistic = cards::replace_null_statistic(cards, rows = !is.null(error))
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> 1️⃣ <main> branch
#> # A tibble: 1 × 4
#>   expression               median  n_gc mem_alloc
#>   <bch:expr>             <bch:tm> <dbl> <bch:byt>
#> 1 replace_null_statistic   4.58ms     2    7.94KB

#> 2️⃣ <benchmark-poc> branch  (not affected by changes)


### 3. Improve tibble operations

#### Using `tibble::new_tibble()` for datasets that can be built faster _(when being repeatedly called)_

```r
bench::mark(
  normal = tibble::tibble(a = 1, b = 2),
  new_tibble = tibble::new_tibble(list(a = 1, b = 2)),
  vctrs = vctrs::new_data_frame(list(a = 1, b = 2)),
  check = FALSE
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> # A tibble: 3 × 4
#>   expression   median  n_gc mem_alloc
#>   <bch:expr> <bch:tm> <dbl> <bch:byt>
#> 1 normal     319.25µs     3      496B
#> 2 new_tibble   8.72µs     1        0B
#> 3 vctrs         1.3µs     0        0B

Example below is of an operation (cards::.calculate_stats_as_ard()) that can run 36 times with simple cases (for example when calculating mean() and sd() for iris dataset for each continuous column and grouped per Species)

# Code from cards:::.lst_results_as_df()
existing <- \(x = list(result = 8, error = NULL, warning = NULL), fun = mean, fun_name = "MEAN", variable = "AGE") {
  df_ard <- cards:::map(x, list) |>
    dplyr::as_tibble() |>
    dplyr::mutate(
      stat_name = cards:::case_switch(
        rlang::is_empty(.env$x$result) && cards:::is_cards_fn(.env$fun) ~
          list(cards:::get_cards_fn_stat_names(.env$fun)),
        .default = fun_name
      )
    ) |>
      tidyr::unnest("stat_name")

  df_ard |>
    dplyr::mutate(variable = variable) |>
    dplyr::rename(stat = "result")
}

alternative <- \(x = list(result = 8, error = NULL, warning = NULL), fun = mean, fun_name = "MEAN", variable = "AGE") {
  vctrs::new_data_frame(
    list(
      stat = x$result,
      warning = x$warning,
      error = x$error,
      stat_name =
      if (rlang::is_empty(x$result) && cards:::is_cards_fn(fun))
        cards:::get_cards_fn_stat_names(fun)
      else
        fun_name,
      variable = variable
    )
  )
}

bench::mark(
  check = FALSE,
  existing = lapply(1:36, \(x) existing()),
  alternative = lapply(1:36, \(x) alternative())
) |> dplyr::select(expression, median, n_gc, mem_alloc)

#> # A tibble: 2 × 4
#>   expression    median  n_gc mem_alloc
#>   <bch:expr>  <bch:tm> <dbl> <bch:byt>
#> 1 existing       110ms     4   408.1KB
#> 2 alternative    120µs     5    35.1KB

x <- structure(
  list(
    result = list(
      N_obs = as.integer(84),
      N_miss = as.integer(0),
      N_nonmiss = as.integer(84),
      p_miss = 0,
      p_nonmiss = 1
    ),
    warning = NULL,
    error = NULL
  ),
  class = c("captured_condition", "list")
)
variable <- "AGE"
bench::mark(
  check = FALSE,
  "vctrs::new_data_frame" = vctrs::new_data_frame(
    vctrs::df_list(
    stat_name = names(x$result),
    stat = unname(x$result),
    warning = list(x$warning),
    error = list(x$error),
    variable = variable
    )
  ),
  "dplyr::tibble" = dplyr::tibble(
    stat_name = names(x$result),
    stat = unname(x$result),
    warning = list(x$warning),
    error = list(x$error),
    variable = variable
  )
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> # A tibble: 2 × 4
#>   expression              median  n_gc mem_alloc
#>   <bch:expr>            <bch:tm> <dbl> <bch:byt>
#> 1 vctrs::new_data_frame   25.1µs     2      216B
#> 2 dplyr::tibble          608.9µs     4      496B

3. Improve tibble operations

Using tibble::new_tibble() for datasets that can be built faster (when being repeatedly called)

bench::mark(
  normal = tibble::tibble(a = 1, b = 2),
  new_tibble = tibble::new_tibble(list(a = 1, b = 2)),
  vctrs = vctrs::new_data_frame(list(a = 1, b = 2)),
  check = FALSE
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> # A tibble: 3 × 4
#>   expression   median  n_gc mem_alloc
#>   <bch:expr> <bch:tm> <dbl> <bch:byt>
#> 1 normal     319.25µs     3      496B
#> 2 new_tibble   8.72µs     1        0B
#> 3 vctrs         1.3µs     0        0B

Example below is of an operation (cards::.calculate_stats_as_ard()) that can run 36 times with simple cases (for example when calculating mean() and sd() for iris dataset for each continuous column and grouped per Species)

# Code from cards:::.lst_results_as_df()
existing <- \(x = list(result = 8, error = NULL, warning = NULL), fun = mean, fun_name = "MEAN", variable = "AGE") {
  df_ard <- cards:::map(x, list) |>
    dplyr::as_tibble() |>
    dplyr::mutate(
      stat_name = cards:::case_switch(
        rlang::is_empty(.env$x$result) && cards:::is_cards_fn(.env$fun) ~
          list(cards:::get_cards_fn_stat_names(.env$fun)),
        .default = fun_name
      )
    ) |>
      tidyr::unnest("stat_name")

  df_ard |>
    dplyr::mutate(variable = variable) |>
    dplyr::rename(stat = "result")
}

alternative <- \(x = list(result = 8, error = NULL, warning = NULL), fun = mean, fun_name = "MEAN", variable = "AGE") {
  vctrs::new_data_frame(
    list(
      stat = x$result,
      warning = x$warning,
      error = x$error,
      stat_name =
      if (rlang::is_empty(x$result) && cards:::is_cards_fn(fun))
        cards:::get_cards_fn_stat_names(fun)
      else
        fun_name,
      variable = variable
    )
  )
}

bench::mark(
  check = FALSE,
  existing = lapply(1:36, \(x) existing()),
  alternative = lapply(1:36, \(x) alternative())
) |> dplyr::select(expression, median, n_gc, mem_alloc)

#> # A tibble: 2 × 4
#>   expression    median  n_gc mem_alloc
#>   <bch:expr>  <bch:tm> <dbl> <bch:byt>
#> 1 existing       110ms     4   408.1KB
#> 2 alternative    120µs     5    35.1KB

x <- structure(
  list(
    result = list(
      N_obs = as.integer(84),
      N_miss = as.integer(0),
      N_nonmiss = as.integer(84),
      p_miss = 0,
      p_nonmiss = 1
    ),
    warning = NULL,
    error = NULL
  ),
  class = c("captured_condition", "list")
)
variable <- "AGE"
bench::mark(
  check = FALSE,
  "vctrs::new_data_frame" = vctrs::new_data_frame(
    vctrs::df_list(
    stat_name = names(x$result),
    stat = unname(x$result),
    warning = list(x$warning),
    error = list(x$error),
    variable = variable
    )
  ),
  "dplyr::tibble" = dplyr::tibble(
    stat_name = names(x$result),
    stat = unname(x$result),
    warning = list(x$warning),
    error = list(x$error),
    variable = variable
  )
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> # A tibble: 2 × 4
#>   expression              median  n_gc mem_alloc
#>   <bch:expr>            <bch:tm> <dbl> <bch:byt>
#> 1 vctrs::new_data_frame   25.1µs     2      216B
#> 2 dplyr::tibble          608.9µs     4      496B

(low hanging fruit) Improve tibble operations

Using tibble::new_tibble() for datasets that can be built faster (when being repeatedly called)

bench::mark(
  normal = tibble::tibble(a = 1, b = 2),
  new_tibble = tibble::new_tibble(list(a = 1, b = 2)),
  vctrs = vctrs::new_data_frame(list(a = 1, b = 2)),
  check = FALSE
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> # A tibble: 3 × 4
#>   expression   median  n_gc mem_alloc
#>   <bch:expr> <bch:tm> <dbl> <bch:byt>
#> 1 normal     319.25µs     3      496B
#> 2 new_tibble   8.72µs     1        0B
#> 3 vctrs         1.3µs     0        0B

Example below is of an operation (cards::.calculate_stats_as_ard()) that can run 36 times with simple cases (for example when calculating mean() and sd() for iris dataset for each continuous column and grouped per Species)

# Code from cards:::.lst_results_as_df()
existing <- \(x = list(result = 8, error = NULL, warning = NULL), fun = mean, fun_name = "MEAN", variable = "AGE") {
  df_ard <- cards:::map(x, list) |>
    dplyr::as_tibble() |>
    dplyr::mutate(
      stat_name = cards:::case_switch(
        rlang::is_empty(.env$x$result) && cards:::is_cards_fn(.env$fun) ~
          list(cards:::get_cards_fn_stat_names(.env$fun)),
        .default = fun_name
      )
    ) |>
      tidyr::unnest("stat_name")

  df_ard |>
    dplyr::mutate(variable = variable) |>
    dplyr::rename(stat = "result")
}

alternative <- \(x = list(result = 8, error = NULL, warning = NULL), fun = mean, fun_name = "MEAN", variable = "AGE") {
  vctrs::new_data_frame(
    list(
      stat = x$result,
      warning = x$warning,
      error = x$error,
      stat_name =
      if (rlang::is_empty(x$result) && cards:::is_cards_fn(fun))
        cards:::get_cards_fn_stat_names(fun)
      else
        fun_name,
      variable = variable
    )
  )
}

bench::mark(
  check = FALSE,
  existing = lapply(1:36, \(x) existing()),
  alternative = lapply(1:36, \(x) alternative())
) |> dplyr::select(expression, median, n_gc, mem_alloc)

#> # A tibble: 2 × 4
#>   expression    median  n_gc mem_alloc
#>   <bch:expr>  <bch:tm> <dbl> <bch:byt>
#> 1 existing       110ms     4   408.1KB
#> 2 alternative    120µs     5    35.1KB

x <- structure(
  list(
    result = list(
      N_obs = as.integer(84),
      N_miss = as.integer(0),
      N_nonmiss = as.integer(84),
      p_miss = 0,
      p_nonmiss = 1
    ),
    warning = NULL,
    error = NULL
  ),
  class = c("captured_condition", "list")
)
variable <- "AGE"
bench::mark(
  check = FALSE,
  "vctrs::new_data_frame" = vctrs::new_data_frame(
    vctrs::df_list(
    stat_name = names(x$result),
    stat = unname(x$result),
    warning = list(x$warning),
    error = list(x$error),
    variable = variable
    )
  ),
  "dplyr::tibble" = dplyr::tibble(
    stat_name = names(x$result),
    stat = unname(x$result),
    warning = list(x$warning),
    error = list(x$error),
    variable = variable
  )
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> # A tibble: 2 × 4
#>   expression              median  n_gc mem_alloc
#>   <bch:expr>            <bch:tm> <dbl> <bch:byt>
#> 1 vctrs::new_data_frame   25.1µs     2      216B
#> 2 dplyr::tibble          608.9µs     4      496B

[averissimo]

Benchmark that compares rtables and gtsummary, in particular with gtsummary_bench_strata that increases the time proportional for each strata

library(tern)
library(dplyr)
library(tidyr)

library(cards)
library(gtsummary)

adsl <- random.cdisc.data::cadsl
advs <- random.cdisc.data::cadvs
adsub <- random.cdisc.data::cadsub

# Ensure character variables are converted to factors and empty strings and NAs are explicit missing levels.
adsl <- df_explicit_na(adsl)
advs <- df_explicit_na(advs)
adsub <- df_explicit_na(adsub)

# Change description in variable SEX.
adsl <- adsl %>%
  mutate(
    SEX = factor(case_when(
      SEX == "M" ~ "Male",
      SEX == "F" ~ "Female",
      SEX == "U" ~ "Unknown",
      SEX == "UNDIFFERENTIATED" ~ "Undifferentiated"
    )),
    AGEGR1 = factor(
      case_when(
        between(AGE, 18, 40) ~ "18-40",
        between(AGE, 41, 64) ~ "41-64",
        AGE > 64 ~ ">=65"
      ),
      levels = c("18-40", "41-64", ">=65")
    ),
    BMRKR1_CAT = factor(
      case_when(
        BMRKR1 < 3.5 ~ "LOW",
        BMRKR1 >= 3.5 & BMRKR1 < 10 ~ "MEDIUM",
        BMRKR1 >= 10 ~ "HIGH"
      ),
      levels = c("LOW", "MEDIUM", "HIGH")
    )
  ) %>%
  var_relabel(
    BMRKR1_CAT = "Biomarker 1 Categories"
  )
# The developer needs to do pre-processing to add necessary variables based on ADVS to analysis dataset.
# Obtain SBP, DBP and weight.
get_param_advs <- function(pname, plabel) {
  ds <- advs %>%
    filter(PARAM == plabel & AVISIT == "BASELINE") %>%
    select(USUBJID, AVAL)

  colnames(ds) <- c("USUBJID", pname)

  ds
}
# The developer needs to do pre-processing to add necessary variables based on ADSUB to analysis dataset.
# Obtain baseline BMI (BBMISI).
get_param_adsub <- function(pname, plabel) {
  ds <- adsub %>%
    filter(PARAM == plabel) %>%
    select(USUBJID, AVAL)

  colnames(ds) <- c("USUBJID", pname)

  ds
}
adsl <- adsl %>%
  left_join(get_param_advs("SBP", "Systolic Blood Pressure"), by = "USUBJID") %>%
  left_join(get_param_advs("DBP", "Diastolic Blood Pressure"), by = "USUBJID") %>%
  left_join(get_param_advs("WGT", "Weight"), by = "USUBJID") %>%
  left_join(get_param_adsub("BBMISI", "Baseline BMI"), by = "USUBJID")


library(rtables)
library(formatters)
library(tern)

library(cards)
library(gtsummary)

rtables_bench <- function() {
  basic_table(show_colcounts = TRUE) |>
    split_cols_by(var = "ACTARM") |>
    add_overall_col("All Patients") |>
    analyze_vars(
      vars = c("AGE", "AGEGR1", "SEX", "ETHNIC", "RACE", "BMRKR1"),
      var_labels = c(
        "Age (yr)",
        "Age Group",
        "Sex",
        "Ethnicity",
        "Race",
        "Continous Level Biomarker 1"
      )
    ) |>
    build_table(adsl)
}

gtsummary_bench <- function(data = adsl) {
  data |>
    select(all_of(c("AGE", "AGEGR1", "SEX", "ETHNIC", "RACE", "BMRKR1", "ACTARM"))) |>
    tbl_summary(
      by = ACTARM,
      label = list(
        AGE     = "Age (yr)",
        AGEGR1  = "Age Group",
        SEX     = "Sex",
        ETHNIC  = "Ethnicity",
        RACE    = "Race",
        BMRKR1  = "Continous Level Biomarker 1"
      ),
      statistic = list(
        all_continuous() ~ "{median} ({p25}, {p75})",
        all_categorical() ~ "{n} ({p}%)"

      ),
      missing = "always",
      missing_stat = "{N_obs}",
      missing_text = "N"
    ) |>
    add_overall(last = FALSE)
}

gtsummary_bench_strata_single <- function(data = advs) {
  data |>
    select(all_of(c("AGE", "TRT01A"))) |>
    tbl_summary(
      by = TRT01A,
      label = list(
        AGE = "Age (yr)"
      ),
      statistic = list(
        all_continuous() ~ "{median} ({p25}, {p75})",
        all_categorical() ~ "{n} ({p}%)"

      ),
      missing = "always",
      missing_stat = "{N_obs}",
      missing_text = "N"
    ) |>
    add_overall(last = FALSE)
}

gtsummary_bench_strata <- function(data = advs) {
  gtsummary::tbl_strata_nested_stack(
    data,
    strata = AVISIT,
    quiet = TRUE,
    .tbl_fun = ~ .x |>
      select(all_of(c("AGE", "TRT01A"))) |>
      tbl_summary(
        by = TRT01A,
        label = list(
          AGE = "Age (yr)"
        ),
        statistic = list(
          all_continuous() ~ "{median} ({p25}, {p75})",
          all_categorical() ~ "{n} ({p}%)"

        ),
        missing = "always",
        missing_stat = "{N_obs}",
        missing_text = "N"
      ) |>
      add_overall(last = FALSE)
  )
}

bench::mark(
  check = FALSE,
  min_iterations = 10,
  rtables_bench(),
  gtsummary = gtsummary_bench(),
  gtsummary_strata_single = gtsummary_bench_strata_single(),
  gtsummary_strata = gtsummary_bench_strata()

) |> dplyr::select(expression, median, n_gc, mem_alloc)

#> # A tibble: 4 × 4
#>   expression                median  n_gc mem_alloc
#>   <bch:expr>              <bch:tm> <dbl> <bch:byt>
#> 1 rtables_bench()         216.52ms     9    8.54MB
#> 2 gtsummary                  1.55s    46    7.18MB
#> 3 gtsummary_strata_single  699.6ms    19    14.8MB
#> 4 gtsummary_strata           5.42s   136   52.38MB

[averissimo]

Tagging @kpagacz

[Melkiades]

Thanks @averissimo!! always wanted to try profiling this. Great work. I would add the change with vctrs asap. I encounter slowness with strata daily so it is all very welcomed!!

[llrs-roche]

FYI: The speed of gtsummary has been discussed on r-pkg-devel too as it affects checks on other packages:

I saw that the code spent a significant part of its time
downstream from the call to gtsummary::tbl_summary() in the
.external_consistency() function

Sharing here so you are aware of the bottlenecks on the wild too.