Retire make_afun() - Batch 2

NEWS.md

@@ -1,7 +1,7 @@
 # tern 0.9.7.9007
 
 ### Enhancements
-* Refactored `count_abnormal()`, `count_abnormal_by_baseline()`, `count_abnormal_by_marked()`, `count_abnormal_by_worst_grade()`, and `count_abnormal_lab_worsen_by_baseline()` to work without `make_afun()`.
+* Refactored `count_abnormal()`, `count_abnormal_by_baseline()`, `count_abnormal_by_marked()`, `count_abnormal_by_worst_grade()`, `count_abnormal_lab_worsen_by_baseline()`, `summarize_ancova()`, and `summarize_glm_count()` to work without `make_afun()`.
 * Added `geom_sd` and `geom_mean_sd` to `s_summary()` default available statistics.
 
 ### Bug Fixes

R/summarize_ancova.R

@@ -111,12 +111,13 @@ h_ancova <- function(.var,
 s_ancova <- function(df,
                      .var,
                      .df_row,
-                     variables,
                      .ref_group,
                      .in_ref_col,
+                     variables,
                      conf_level,
                      interaction_y = FALSE,
-                     interaction_item = NULL) {
+                     interaction_item = NULL,
+                     ...) {
   emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item)
 
   sum_fit <- summary(
@@ -207,18 +208,59 @@ s_ancova <- function(df,
 #' * `a_ancova()` returns the corresponding list with formatted [rtables::CellValue()].
 #'
 #' @keywords internal
-a_ancova <- make_afun(
-  s_ancova,
-  .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
-  .formats = c(
-    "n" = "xx",
-    "lsmean" = "xx.xx",
-    "lsmean_diff" = "xx.xx",
-    "lsmean_diff_ci" = "(xx.xx, xx.xx)",
-    "pval" = "x.xxxx | (<0.0001)"
-  ),
-  .null_ref_cells = FALSE
-)
+a_ancova <- function(df,
+                     ...,
+                     .stats = NULL,
+                     .stat_names = NULL,
+                     .formats = NULL,
+                     .labels = NULL,
+                     .indent_mods = NULL) {
+  # Check for additional parameters to the statistics function
+  dots_extra_args <- list(...)
+  extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters))
+  dots_extra_args$.additional_fun_parameters <- NULL
+
+  # Check for user-defined functions
+  default_and_custom_stats_list <- .split_std_from_custom_stats(.stats)
+  .stats <- default_and_custom_stats_list$default_stats
+  custom_stat_functions <- default_and_custom_stats_list$custom_stats
+
+  # Apply statistics function
+  x_stats <- .apply_stat_functions(
+    default_stat_fnc = s_ancova,
+    custom_stat_fnc_list = custom_stat_functions,
+    args_list = c(
+      df = list(df),
+      extra_afun_params,
+      dots_extra_args
+    )
+  )
+
+  # Fill in formatting defaults
+  .stats <- c(get_stats("summarize_ancova", stats_in = .stats), names(custom_stat_functions))
+  x_stats <- x_stats[.stats]
+  .formats <- get_formats_from_stats(.stats, .formats)
+  .labels <- get_labels_from_stats(
+    .stats, .labels,
+    tern_defaults = c(lapply(x_stats[names(x_stats) != "n"], attr, "label"), tern_default_labels)
+  )
+  .indent_mods <- get_indents_from_stats(.stats, .indent_mods)
+
+  # Auto format handling
+  .formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var)
+
+  # Get and check statistical names
+  .stat_names <- get_stat_names(x_stats, .stat_names)
+
+  in_rows(
+    .list = x_stats,
+    .formats = .formats,
+    .names = .labels %>% .unlist_keep_nulls(),
+    .stat_names = .stat_names,
+    .labels = .labels %>% .unlist_keep_nulls(),
+    .indent_mods = .indent_mods %>% .unlist_keep_nulls()
+  )
+}
 
 #' @describeIn summarize_ancova Layout-creating function which can take statistics function arguments
 #'   and additional format arguments. This function is a wrapper for [rtables::analyze()].
@@ -261,34 +303,39 @@ summarize_ancova <- function(lyt,
                              ...,
                              show_labels = "visible",
                              table_names = vars,
-                             .stats = NULL,
+                             .stats = c("n", "lsmean", "lsmean_diff", "lsmean_diff_ci", "pval"),
+                             .stat_names = NULL,
                              .formats = NULL,
                              .labels = NULL,
-                             .indent_mods = NULL) {
-  extra_args <- list(
-    variables = variables, conf_level = conf_level, interaction_y = interaction_y,
-    interaction_item = interaction_item, ...
-  )
+                             .indent_mods = list("lsmean_diff_ci" = 1L, "pval" = 1L)) {
+  # Process standard extra arguments
+  extra_args <- list(".stats" = .stats)
+  if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names
+  if (!is.null(.formats)) extra_args[[".formats"]] <- .formats
+  if (!is.null(.labels)) extra_args[[".labels"]] <- .labels
+  if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods
 
-  afun <- make_afun(
-    a_ancova,
-    interaction_y = interaction_y,
-    interaction_item = interaction_item,
-    .stats = .stats,
-    .formats = .formats,
-    .labels = .labels,
-    .indent_mods = .indent_mods
+  # Process additional arguments to the statistic function
+  extra_args <- c(
+    extra_args,
+    variables = list(variables), conf_level = list(conf_level), interaction_y = list(interaction_y),
+    interaction_item = list(interaction_item),
+    ...
   )
 
+  # Append additional info from layout to the analysis function
+  extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE)
+  formals(a_ancova) <- c(formals(a_ancova), extra_args[[".additional_fun_parameters"]])
+
   analyze(
-    lyt,
-    vars,
-    var_labels = var_labels,
-    show_labels = show_labels,
-    table_names = table_names,
-    afun = afun,
+    lyt = lyt,
+    vars = vars,
+    afun = a_ancova,
     na_str = na_str,
     nested = nested,
-    extra_args = extra_args
+    extra_args = extra_args,
+    var_labels = var_labels,
+    show_labels = show_labels,
+    table_names = table_names
   )
 }

R/summarize_glm_count.R

@@ -117,48 +117,42 @@ summarize_glm_count <- function(lyt,
                                 ...,
                                 show_labels = "visible",
                                 table_names = vars,
-                                .stats = get_stats("summarize_glm_count"),
+                                .stats = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+                                .stat_names = NULL,
                                 .formats = NULL,
                                 .labels = NULL,
-                                .indent_mods = c(
-                                  "n" = 0L,
-                                  "rate" = 0L,
-                                  "rate_ci" = 1L,
-                                  "rate_ratio" = 0L,
-                                  "rate_ratio_ci" = 1L,
-                                  "pval" = 1L
-                                )) {
+                                .indent_mods = list("rate_ci" = 1L, "rate_ratio_ci" = 1L, "pval" = 1L)) {
   checkmate::assert_choice(rate_mean_method, c("emmeans", "ppmeans"))
 
-  extra_args <- list(
-    variables = variables, distribution = distribution, conf_level = conf_level,
-    rate_mean_method = rate_mean_method, weights = weights, scale = scale, ...
+  # Process standard extra arguments
+  extra_args <- list(".stats" = .stats)
+  if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names
+  if (!is.null(.formats)) extra_args[[".formats"]] <- .formats
+  if (!is.null(.labels)) extra_args[[".labels"]] <- .labels
+  if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods
+
+  # Process additional arguments to the statistic function
+  extra_args <- c(
+    extra_args,
+    variables = list(variables), distribution = list(distribution), conf_level = list(conf_level),
+    rate_mean_method = list(rate_mean_method), weights = list(weights), scale = list(scale),
+    ...
   )
 
-  # Selecting parameters following the statistics
-  .formats <- get_formats_from_stats(.stats, formats_in = .formats)
-  .labels <- get_labels_from_stats(.stats, labels_in = .labels)
-  .indent_mods <- get_indents_from_stats(.stats, indents_in = .indent_mods)
-
-  afun <- make_afun(
-    s_glm_count,
-    .stats = .stats,
-    .formats = .formats,
-    .labels = .labels,
-    .indent_mods = .indent_mods,
-    .null_ref_cells = FALSE
-  )
+  # Append additional info from layout to the analysis function
+  extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE)
+  formals(a_glm_count) <- c(formals(a_glm_count), extra_args[[".additional_fun_parameters"]])
 
   analyze(
-    lyt,
-    vars,
-    var_labels = var_labels,
-    show_labels = show_labels,
-    table_names = table_names,
-    afun = afun,
+    lyt = lyt,
+    vars = vars,
+    afun = a_glm_count,
     na_str = na_str,
     nested = nested,
-    extra_args = extra_args
+    extra_args = extra_args,
+    var_labels = var_labels,
+    show_labels = show_labels,
+    table_names = table_names
   )
 }
 
@@ -178,14 +172,15 @@ summarize_glm_count <- function(lyt,
 s_glm_count <- function(df,
                         .var,
                         .df_row,
-                        variables,
                         .ref_group,
                         .in_ref_col,
+                        variables,
                         distribution,
                         conf_level,
                         rate_mean_method,
                         weights,
-                        scale = 1) {
+                        scale = 1,
+                        ...) {
   arm <- variables$arm
 
   y <- df[[.var]]
@@ -272,7 +267,67 @@ s_glm_count <- function(df,
     )
   }
 }
+
+#' @describeIn summarize_glm_count Formatted analysis function which is used as `afun` in `summarize_glm_count()`.
+#'
+#' @return
+#' * `a_glm_count()` returns the corresponding list with formatted [rtables::CellValue()].
+#'
+#' @keywords internal
+a_glm_count <- function(df,
+                        ...,
+                        .stats = NULL,
+                        .stat_names = NULL,
+                        .formats = NULL,
+                        .labels = NULL,
+                        .indent_mods = NULL) {
+  # Check for additional parameters to the statistics function
+  dots_extra_args <- list(...)
+  extra_afun_params <- retrieve_extra_afun_params(names(dots_extra_args$.additional_fun_parameters))
+  dots_extra_args$.additional_fun_parameters <- NULL
+
+  # Check for user-defined functions
+  default_and_custom_stats_list <- .split_std_from_custom_stats(.stats)
+  .stats <- default_and_custom_stats_list$default_stats
+  custom_stat_functions <- default_and_custom_stats_list$custom_stats
+
+  # Apply statistics function
+  x_stats <- .apply_stat_functions(
+    default_stat_fnc = s_glm_count,
+    custom_stat_fnc_list = custom_stat_functions,
+    args_list = c(
+      df = list(df),
+      extra_afun_params,
+      dots_extra_args
+    )
+  )
+
+  # Fill in formatting defaults
+  .stats <- c(get_stats("summarize_glm_count", stats_in = .stats), names(custom_stat_functions))
+  .formats <- get_formats_from_stats(.stats, .formats)
+  .labels <- get_labels_from_stats(.stats, .labels)
+  .indent_mods <- get_indents_from_stats(.stats, .indent_mods)
+
+  x_stats <- x_stats[.stats]
+
+  # Auto format handling
+  .formats <- apply_auto_formatting(.formats, x_stats, extra_afun_params$.df_row, extra_afun_params$.var)
+
+  # Get and check statistical names
+  .stat_names <- get_stat_names(x_stats, .stat_names)
+
+  in_rows(
+    .list = x_stats,
+    .formats = .formats,
+    .names = .labels %>% .unlist_keep_nulls(),
+    .stat_names = .stat_names,
+    .labels = .labels %>% .unlist_keep_nulls(),
+    .indent_mods = .indent_mods %>% .unlist_keep_nulls()
+  )
+}
+
 # h_glm_count ------------------------------------------------------------------
+
 #' Helper functions for Poisson models
 #'
 #' @description `r lifecycle::badge("experimental")`

R/utils_default_stats_formats_labels.R

@@ -601,7 +601,10 @@ tern_default_formats <- c(
   rate = "xx.xxxx",
   rate_ci = "(xx.xxxx, xx.xxxx)",
   rate_ratio = "xx.xxxx",
-  rate_ratio_ci = "(xx.xxxx, xx.xxxx)"
+  rate_ratio_ci = "(xx.xxxx, xx.xxxx)",
+  lsmean = "xx.xx",
+  lsmean_diff = "xx.xx",
+  lsmean_diff_ci = "(xx.xx, xx.xx)"
 )
 
 # tern_default_labels ----------------------------------------------------------