Performance improvement of `gtsummary`

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
1. Long and complex functions
- `gtsummary::tbl_summmary()` is 305 lines long
- `cards::.calculate_stats_as_ard()` has 3 levels of loops
1. Consistent data structures
- Internal functions create objects that need conversion (`list` to `tibble`)
- This may be efficient if done with other calls
1. Optimize data needs in internal operations _(reduce need to copy data)_
1. Use of 📦 `{vctrs}` and/or 📦 `{data.table}` packages for internal operations
1. Refactor code to reduce high need of number of `gc` operations

```r
# 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](https://github.com/averissimo/cards/pull/1/changes) branch shows how to use low-level constructors to achieve the same result

cards::ard_summary(): 110ms

```r
# 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️⃣ branch
#> # A tibble: 2 × 4
#> expression median n_gc mem_alloc
#>
#> 1 ard_summary_1_1 115ms 59 911.4KB
#> 2 ard_summary_2_2 368ms 189 1.9MB

#> 2️⃣ branch
#> # A tibble: 2 × 4
#> expression median n_gc mem_alloc
#>
#> 1 ard_summary_1_1 35.5ms 19 1.75MB
#> 2 ard_summary_2_2 52.2ms 30 1.93MB
```

gtsummary:::brdg_summary(): 90ms

```r
# 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️⃣ branch
#> # A tibble: 1 × 4
#> expression median n_gc mem_alloc
#>
#> 1 brdg_summary 141ms 79 921KB

#> 2️⃣ branch (same)
# not affected by changes
```

gtsummary::ard_missing(): 50ms

```r
# 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️⃣ branch
#> # A tibble: 2 × 4
#> expression median n_gc mem_alloc
#>
#> 1 ard_missing_with_by 40.3ms 20 537KB
#> 2 ard_missing_dplyr_group 38.4ms 21 581KB

#> 2️⃣ branch
#> # A tibble: 2 × 4
#> expression median n_gc mem_alloc
#>
#> 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

```r
# cards::ard_total_n()
bench::mark(
min_iterations = 100,
ard_total_n(ADSL)
) |> dplyr::select(expression, median, n_gc, mem_alloc)
#> 1️⃣ branch
#> # A tibble: 1 × 4
#> expression median n_gc mem_alloc
#>
#> 1 ard_total_n(ADSL) 33.1ms 17 172KB

#> 2️⃣ branch (not affected by changes)
```

cards::ard_tabulate(): 20ms

```r
# 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️⃣ branch
#> # A tibble: 2 × 4
#> expression median n_gc mem_alloc
#>
#> 1 ard_tabulate_by 38.5ms 22 297KB
#> 2 ard_tabulate_dplyr_group 30.8ms 16 217KB

#> 2️⃣ branch (not affected by changes)
```

cards::bind_ard(): 10ms

```r
# 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️⃣ branch
#> # A tibble: 1 × 4
#> expression median n_gc mem_alloc
#>
#> 1 bind_ard 19ms 11 81.8KB

#> 2️⃣ branch (not affected by changes)
```

gtsummary:::.check_stats_available(): 10ms

```r
# 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️⃣ branch
#> # A tibble: 1 × 4
#> expression median n_gc mem_alloc
#>
#> 1 .check_stats_available 2.71ms 9 159KB

#> 2️⃣ branch (not affected by changes)
```

cards::replace_null_statistic(): 10ms

```r
# 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️⃣ branch
#> # A tibble: 1 × 4
#> expression median n_gc mem_alloc
#>
#> 1 replace_null_statistic 4.58ms 2 7.94KB

#> 2️⃣ 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
#>
#> 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`)

```r
# 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
#>
#> 1 existing 110ms 4 408.1KB
#> 2 alternative 120µs 5 35.1KB
```

```r
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
#>
#> 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)_

```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
#>
#> 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`)

```r
# 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
#>
#> 1 existing 110ms 4 408.1KB
#> 2 alternative 120µs 5 35.1KB
```

```r
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
#>
#> 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)_

```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
#>
#> 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`)

```r
# 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
#>
#> 1 existing 110ms 4 408.1KB
#> 2 alternative 120µs 5 35.1KB
```

```r
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
#>
#> 1 vctrs::new_data_frame 25.1µs 2 216B
#> 2 dplyr::tibble 608.9µs 4 496B
```