perf: optimized core tabulation and summary functions; added benchmark suite

.github/scripts/benchmark.R

@@ -0,0 +1,50 @@
+suppressPackageStartupMessages({
+  library(bench)
+  library(dplyr)
+  library(pkgload)
+})
+
+# Load the local cards package
+pkgload::load_all(".")
+
+# We use the trial dataset from gtsummary to test
+library(gtsummary)
+data_big <- trial[rep(seq_len(nrow(trial)), 20), ]
+
+cat("Running benchmarks for ard_summary and ard_tabulate...\n")
+
+res_summary <- bench::mark(
+  ard_summary(
+    data_big,
+    variables = c(age, marker),
+    by = trt
+  ),
+  check = FALSE,
+  iterations = 10,
+  filter_gc = FALSE
+)
+
+res_tabulate <- bench::mark(
+  ard_tabulate(
+    data_big,
+    variables = c(grade, trt),
+    by = response
+  ),
+  check = FALSE,
+  iterations = 10,
+  filter_gc = FALSE
+)
+
+# Format the results into a markdown table
+cat("### Performance Benchmark Results\n\n", file = "bench_report.md")
+cat("These benchmarks run on 20x replicated `gtsummary::trial` dataset.\n\n", file = "bench_report.md", append = TRUE)
+
+cat("#### `ard_summary`\n", file = "bench_report.md", append = TRUE)
+knitr::kable(summary(res_summary)[, c("expression", "min", "median", "itr/sec", "mem_alloc", "gc/sec", "n_itr", "n_gc", "total_time")]) |>
+  cat(file = "bench_report.md", append = TRUE, sep = "\n")
+
+cat("\n#### `ard_tabulate`\n", file = "bench_report.md", append = TRUE)
+knitr::kable(summary(res_tabulate)[, c("expression", "min", "median", "itr/sec", "mem_alloc", "gc/sec", "n_itr", "n_gc", "total_time")]) |>
+  cat(file = "bench_report.md", append = TRUE, sep = "\n")
+
+cat("\nBenchmark report generated successfully.\n")

.github/workflows/benchmark.yaml

@@ -0,0 +1,40 @@
+name: Performance Benchmark
+on:
+  pull_request:
+    branches: [main, master]
+
+jobs:
+  benchmark:
+    if: startsWith(github.event.pull_request.title, 'perf')
+    runs-on: ubuntu-latest
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+    permissions:
+      pull-requests: write
+    steps:
+      - name: Checkout PR
+        uses: actions/checkout@v4
+
+      - name: Setup R
+        uses: r-lib/actions/setup-r@v2
+
+      - name: Install Dependencies & Cache
+        uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          dependencies: '"hard"'
+          extra-packages: |
+            any::bench
+            any::knitr
+            any::gtsummary
+            any::pkgload
+          cache: true
+          cache-version: 3
+
+      - name: Run Benchmarks
+        run: Rscript .github/scripts/benchmark.R
+
+      - name: Post Comment
+        uses: mshick/add-pr-comment@v3
+        with:
+          message-path: bench_report.md
+          message-id: 'add-benchmark-pr-comment'

R/ard_summary.R

@@ -262,33 +262,36 @@ ard_summary.data.frame <- function(data,
                                     by, strata, data,
                                     new_col_name = "...ard_all_stats...") {
   df_nested[[new_col_name]] <-
-    map(
+    lapply(
       df_nested[["...ard_nested_data..."]],
       function(nested_data) {
-        map(
-          variables,
-          function(variable) {
-            map2(
-              statistic[[variable]], names(statistic[[variable]]),
-              function(fun, fun_name) {
-                .lst_results_as_df(
-                  x = # calculate results, and place in tibble
-                    eval_capture_conditions(
-                      getOption(
-                        "cards.calculate_stats_as_ard.eval_fun",
-                        default = expr(do.call(fun, args = list(stats::na.omit(nested_data[[variable]]))))
-                      )
-                    ),
-                  variable = variable,
-                  fun_name = fun_name,
-                  fun = fun
-                )
-              }
-            ) |>
-              unname()
-          }
-        ) |>
-          dplyr::bind_rows()
+        res_list <- unlist(
+          lapply(
+            variables,
+            function(variable) {
+              lapply(
+                names(statistic[[variable]]),
+                function(fun_name) {
+                  fun <- statistic[[variable]][[fun_name]]
+                  .lst_results_as_df(
+                    x = # calculate results, and place in tibble
+                      eval_capture_conditions(
+                        getOption(
+                          "cards.calculate_stats_as_ard.eval_fun",
+                          default = expr(do.call(fun, args = list(stats::na.omit(nested_data[[variable]]))))
+                        )
+                      ),
+                    variable = variable,
+                    fun_name = fun_name,
+                    fun = fun
+                  )
+                }
+              )
+            }
+          ),
+          recursive = FALSE
+        )
+        dplyr::bind_rows(res_list)
       }
     )
 
@@ -324,33 +327,30 @@ ard_summary.data.frame <- function(data,
   # unnesting results if needed
   if (.is_named_list(x$result, allow_df = TRUE)) {
     if (is.data.frame(x$result)) x$result <- unclass(x$result)
-    df_ard <-
-      dplyr::tibble(
-        stat_name = names(x$result),
-        result = unname(x$result),
-        warning = list(x$warning),
-        error = list(x$error)
-      )
-  }
-  # if result is not a nested list, return a single row tibble
-  else {
-    df_ard <-
-      map(x, list) |>
-      dplyr::as_tibble() |>
-      dplyr::mutate(
-        stat_name =
-        # if the function is a "cards_fn" AND the result is missing, use the provided placeholder stat names
-          case_switch(
-            is_empty(.env$x$result) && is_cards_fn(.env$fun) ~ list(get_cards_fn_stat_names(.env$fun)),
-            .default = .env$fun_name
-          )
-      ) |>
-      tidyr::unnest("stat_name")
+    stat_name <- names(x$result)
+    res_list <- unname(x$result)
+  } else {
+    # if result is not a nested list, return a single row tibble
+    stat_name <- if (is_empty(x$result) && is_cards_fn(fun)) {
+      get_cards_fn_stat_names(fun)
+    } else {
+      fun_name
+    }
+    res_list <- list(x$result)
   }
 
-  df_ard |>
-    dplyr::mutate(variable = .env$variable) |>
-    dplyr::rename(stat = "result")
+  len <- length(stat_name)
+
+  out <- data.frame(
+    stat_name = stat_name,
+    stringsAsFactors = FALSE
+  )
+  out$stat <- res_list
+  out$warning <- rep_len(list(x$warning), len)
+  out$error <- rep_len(list(x$error), len)
+  out$variable <- rep_len(variable, len)
+
+  out
 }
 
 

R/ard_tabulate.R

@@ -325,23 +325,46 @@ ard_tabulate.data.frame <- function(data,
             tab_stats = tab_stats
           )
 
-        df_result_tabulation |>
-          .nesting_rename_ard_columns(variable = variable, by = by, strata = strata) |>
-          dplyr::mutate(
-            across(any_of(c("...ard_n...", "...ard_N...", "...ard_p...", "...ard_n_cum...", "...ard_p_cum...")), as.list),
-            across(c(matches("^group[0-9]+_level$"), any_of("variable_level")), as.list)
-          ) |>
-          tidyr::pivot_longer(
-            cols = any_of(c("...ard_n...", "...ard_N...", "...ard_p...", "...ard_n_cum...", "...ard_p_cum...")),
-            names_to = "stat_name",
-            values_to = "stat"
-          ) |>
-          dplyr::mutate(
-            stat_name =
-              gsub(pattern = "^...ard_", replacement = "", x = .data$stat_name) %>%
-                gsub(pattern = "...$", replacement = "", x = .)
-          ) |>
-          dplyr::filter(.data$stat_name %in% tab_stats[["tabulation"]])
+        df_res <- .nesting_rename_ard_columns(df_result_tabulation, variable = variable, by = by, strata = strata)
+
+        # Convert grouping columns to list
+        for (col in c(grep("^group[0-9]+_level$", names(df_res), value = TRUE), intersect(names(df_res), "variable_level"))) {
+          if (!is.list(df_res[[col]])) {
+            df_res[[col]] <- as.list(df_res[[col]])
+          }
+        }
+
+        all_pivot_cols <- c("...ard_n...", "...ard_N...", "...ard_p...", "...ard_n_cum...", "...ard_p_cum...")
+        cols_in_df <- all_pivot_cols[all_pivot_cols %in% names(df_res)]
+
+        stat_names_clean <- gsub("...$", "", gsub("^...ard_", "", cols_in_df))
+
+        keep_idx <- stat_names_clean %in% tab_stats[["tabulation"]]
+        cols_to_pivot <- cols_in_df[keep_idx]
+        stat_names_clean <- stat_names_clean[keep_idx]
+
+        if (length(cols_to_pivot) == 0) {
+          return(dplyr::tibble())
+        }
+
+        n_rows <- nrow(df_res)
+        n_cols <- length(cols_to_pivot)
+
+        # We must drop all potential pivot columns that weren't selected to match pivot_longer behavior
+        fixed_cols <- setdiff(names(df_res), cols_in_df)
+        df_out <- df_res[fixed_cols]
+        df_out <- df_out[rep(seq_len(n_rows), each = n_cols), , drop = FALSE]
+
+        df_out$stat_name <- rep(stat_names_clean, times = n_rows)
+
+        stat_list <- vector("list", n_rows * n_cols)
+        for (i in seq_along(cols_to_pivot)) {
+          indices <- seq(i, length(stat_list), by = n_cols)
+          stat_list[indices] <- as.list(df_res[[cols_to_pivot[i]]])
+        }
+        df_out$stat <- stat_list
+
+        dplyr::as_tibble(df_out)
       }
     ) |>
     dplyr::bind_rows()

R/ard_tabulate_value.R

@@ -84,15 +84,22 @@ ard_tabulate_value.data.frame <- function(data,
     fmt_fun = fmt_fun,
     stat_label = stat_label
   ) |>
-    dplyr::filter(
-      pmap(
-        list(.data$variable, .data$variable_level),
-        function(variable, variable_level) {
-          variable_level %in% .env$value[[variable]]
+    dplyr::filter({
+      keep <- logical(dplyr::n())
+      val <- .env$value
+      for (v in names(val)) {
+        idx <- which(.data$variable == v)
+        if (length(idx) > 0) {
+          v_levels <- .data$variable_level[idx]
+          if (all(lengths(v_levels) == 1L)) {
+            keep[idx] <- unlist(v_levels, recursive = FALSE, use.names = FALSE) %in% val[[v]]
+          } else {
+            keep[idx] <- vapply(v_levels, function(x) x %in% val[[v]], logical(1))
+          }
         }
-      ) |>
-        unlist()
-    ) |>
+      }
+      keep
+    }) |>
     dplyr::mutate(context = "tabulate_value")
 
   # append attributes ----------------------------------------------------------

R/ard_total_n.R

@@ -29,13 +29,20 @@ ard_total_n.data.frame <- function(data, ...) {
   check_data_frame(data)
 
   # calculate total N ----------------------------------------------------------
-  data |>
-    dplyr::mutate(..ard_total_n.. = TRUE) |>
-    ard_tabulate_value(
-      variables = "..ard_total_n..",
-      statistic = list(..ard_total_n.. = "N"),
-      value = list(..ard_total_n.. = TRUE)
+  ans <-
+    dplyr::tibble(
+      variable = "..ard_total_n..",
+      context = "total_n",
+      stat_name = "N",
+      stat_label = "N",
+      stat = list(nrow(data)),
+      fmt_fun = list(0L),
+      warning = list(NULL),
+      error = list(NULL)
     ) |>
-    dplyr::mutate(context = "total_n") |>
-    dplyr::select(-all_ard_variables("levels"))
+    as_card()
+
+  attr(ans, "args") <- list(variables = "..ard_total_n..", by = character(0), strata = character(0))
+
+  ans
 }