Batch 1

R/incidence_rate.R

@@ -155,10 +155,10 @@ a_incidence_rate <- function(df,
   # Fill in with defaults
   formats_def <- formals()$.formats %>% eval()
   .formats <- c(.formats, formats_def)[!duplicated(names(c(.formats, formats_def)))]
-  labels_def <- sapply(x_stats, \(x) attributes(x)$label)
+  labels_def <- sapply(x_stats, function(x) attributes(x)$label)
   .labels <- c(.labels, labels_def)[!duplicated(names(c(.labels, labels_def)))]
   if (nzchar(labelstr) > 0) {
-    .labels <- sapply(.labels, \(x) gsub("%.labels", x, gsub("%s", labelstr, label_fmt)))
+    .labels <- sapply(.labels, function(x) gsub("%.labels", x, gsub("%s", labelstr, label_fmt)))
   }
 
   # Fill in with formatting defaults if needed

R/prop_diff.R

@@ -64,15 +64,16 @@ s_proportion_diff <- function(df,
                                 "ha", "newcombe", "newcombecc",
                                 "strat_newcombe", "strat_newcombecc"
                               ),
-                              weights_method = "cmh") {
+                              weights_method = "cmh",
+                              ...) {
   method <- match.arg(method)
   if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
     stop(paste(
       "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not",
       "permitted. Please choose a different method."
     ))
   }
-  y <- list(diff = "", diff_ci = "")
+  y <- list(diff = character(), diff_ci = character())
 
   if (!.in_ref_col) {
     rsp <- c(.ref_group[[.var]], df[[.var]])
@@ -151,6 +152,7 @@ s_proportion_diff <- function(df,
 #' @examples
 #' a_proportion_diff(
 #'   df = subset(dta, grp == "A"),
+#'   .stats = c("diff"),
 #'   .var = "rsp",
 #'   .ref_group = subset(dta, grp == "B"),
 #'   .in_ref_col = FALSE,
@@ -159,11 +161,75 @@ s_proportion_diff <- function(df,
 #' )
 #'
 #' @export
-a_proportion_diff <- make_afun(
-  s_proportion_diff,
-  .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"),
-  .indent_mods = c(diff = 0L, diff_ci = 1L)
-)
+a_proportion_diff <- function(df,
+                              ...,
+                              .stats = NULL,
+                              .stat_names = NULL,
+                              .formats = NULL,
+                              .labels = NULL,
+                              .indent_mods = NULL) {
+  dots_extra_args <- list(...)
+
+  # Check if there are 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
+
+  # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params)
+  extra_afun_params <- retrieve_extra_afun_params(
+    names(dots_extra_args$.additional_fun_parameters)
+  )
+  dots_extra_args$.additional_fun_parameters <- NULL # After extraction we do not need them anymore
+
+  # Main statistical functions application
+  x_stats <- .apply_stat_functions(
+    default_stat_fnc = s_proportion_diff,
+    custom_stat_fnc_list = custom_stat_functions,
+    args_list = c(
+      df = list(df),
+      extra_afun_params,
+      dots_extra_args
+    )
+  )
+
+  # Fill in with stats defaults if needed
+  .stats <- c(
+    get_stats("estimate_proportion_diff", stats_in = .stats),
+    names(custom_stat_functions)
+  )
+
+  x_stats <- x_stats[.stats]
+
+  # Fill in formats/indents/labels with custom input and defaults
+  .formats <- get_formats_from_stats(.stats, .formats)
+  .indent_mods <- get_indents_from_stats(.stats, .indent_mods)
+  if (is.null(.labels)) {
+    .labels <- sapply(x_stats, attr, "label")
+    .labels <- .labels[nzchar(.labels)]
+  }
+  .labels <- get_labels_from_stats(.stats, .labels)
+
+  # Auto format handling
+  .formats <- apply_auto_formatting(
+    .formats,
+    x_stats,
+    extra_afun_params$.df_row,
+    extra_afun_params$.var
+  )
+
+  # Get and check statistical names from defaults
+  .stat_names <- get_stat_names(x_stats, .stat_names) # note is x_stats
+  .stat_names <- paste0(.stat_names, "_", dots_extra_args$method)
+
+  in_rows(
+    .list = x_stats,
+    .formats = .formats,
+    .names = names(.labels),
+    .stat_names = .stat_names,
+    .labels = .labels %>% .unlist_keep_nulls(),
+    .indent_mods = .indent_mods %>% .unlist_keep_nulls()
+  )
+}
 
 #' @describeIn prop_diff Layout-creating function which can take statistics function arguments
 #'   and additional format arguments. This function is a wrapper for [rtables::analyze()].
@@ -198,6 +264,14 @@ a_proportion_diff <- make_afun(
 #' @order 2
 estimate_proportion_diff <- function(lyt,
                                      vars,
+                                     var_labels = vars,
+                                     na_str = default_na_str(),
+                                     nested = TRUE,
+                                     show_labels = "default",
+                                     table_names = vars,
+                                     section_div = NA_character_,
+                                     ...,
+                                     na_rm = TRUE,
                                      variables = list(strata = NULL),
                                      conf_level = 0.95,
                                      method = c(
@@ -206,38 +280,48 @@ estimate_proportion_diff <- function(lyt,
                                        "strat_newcombe", "strat_newcombecc"
                                      ),
                                      weights_method = "cmh",
-                                     na_str = default_na_str(),
-                                     nested = TRUE,
-                                     ...,
-                                     var_labels = vars,
-                                     show_labels = "hidden",
-                                     table_names = vars,
-                                     .stats = NULL,
-                                     .formats = NULL,
+                                     .stats = c("diff", "diff_ci"),
+                                     .stat_names = NULL,
+                                     .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"),
                                      .labels = NULL,
-                                     .indent_mods = NULL) {
+                                     .indent_mods = c(diff = 0L, diff_ci = 1L)) {
+  # Depending on main functions
   extra_args <- list(
-    variables = variables, conf_level = conf_level, method = method, weights_method = weights_method, ...
+    "na_rm" = na_rm,
+    "variables" = variables,
+    "conf_level" = conf_level,
+    "method" = method,
+    "weights_method" = weights_method,
+    ...
   )
 
-  afun <- make_afun(
-    a_proportion_diff,
-    .stats = .stats,
-    .formats = .formats,
-    .labels = .labels,
-    .indent_mods = .indent_mods
+  # Needed defaults
+  if (!is.null(.stats)) extra_args[[".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
+
+  # Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params)
+  extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE)
+  formals(a_proportion_diff) <- c(
+    formals(a_proportion_diff),
+    extra_args[[".additional_fun_parameters"]]
   )
 
+  # Main {rtables} structural call
   analyze(
-    lyt,
-    vars,
-    afun = afun,
+    lyt = lyt,
+    vars = vars,
     var_labels = var_labels,
+    afun = a_proportion_diff,
     na_str = na_str,
+    inclNAs = !na_rm,
     nested = nested,
     extra_args = extra_args,
     show_labels = show_labels,
-    table_names = table_names
+    table_names = table_names,
+    section_div = section_div
   )
 }
 

R/prop_diff_test.R

@@ -32,9 +32,10 @@
                                    .ref_group,
                                    .in_ref_col,
                                    variables = list(strata = NULL),
-                                   method = c("chisq", "schouten", "fisher", "cmh")) {
+                                   method = c("chisq", "schouten", "fisher", "cmh"),
+                                   ...) {
   method <- match.arg(method)
-  y <- list(pval = "")
+  y <- list(pval = character())
 
   if (!.in_ref_col) {
     assert_df_with_variables(df, list(rsp = .var))
@@ -103,11 +104,74 @@
 #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].
 #'
 #' @keywords internal
-a_test_proportion_diff <- make_afun(
-  s_test_proportion_diff,
-  .formats = c(pval = "x.xxxx | (<0.0001)"),
-  .indent_mods = c(pval = 1L)
-)
+a_test_proportion_diff <- function(df,
+                                   ...,
+                                   .stats = NULL,
+                                   .stat_names = NULL,
+                                   .formats = NULL,
+                                   .labels = NULL,
+                                   .indent_mods = NULL) {
+  dots_extra_args <- list(...)
+
+  # Check if there are 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
+
+  # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params)
+  extra_afun_params <- retrieve_extra_afun_params(
+    names(dots_extra_args$.additional_fun_parameters)
+  )
+  dots_extra_args$.additional_fun_parameters <- NULL # After extraction we do not need them anymore
+
+  # Main statistical functions application
+  x_stats <- .apply_stat_functions(
+    default_stat_fnc = s_test_proportion_diff,
+    custom_stat_fnc_list = custom_stat_functions,
+    args_list = c(
+      df = list(df),
+      extra_afun_params,
+      dots_extra_args
+    )
+  )
+
+  # Fill in with stats defaults if needed
+  .stats <- c(
+    get_stats("test_proportion_diff", stats_in = .stats),
+    names(custom_stat_functions)
+  )
+
+  x_stats <- x_stats[.stats]
+
+  # Fill in formats/indents/labels with custom input and defaults
+  .formats <- get_formats_from_stats(.stats, .formats)
+  .indent_mods <- get_indents_from_stats(.stats, .indent_mods)
+  if (is.null(.labels)) {
+    .labels <- sapply(x_stats, attr, "label")
+  }
+  .labels <- get_labels_from_stats(.stats, .labels)
+
+  # Auto format handling
+  .formats <- apply_auto_formatting(
+    .formats,
+    x_stats,
+    extra_afun_params$.df_row,
+    extra_afun_params$.var
+  )
+
+  # Get and check statistical names from defaults
+  .stat_names <- get_stat_names(x_stats, .stat_names) # note is x_stats
+  .stat_names <- paste0(.stat_names, "_", dots_extra_args$method)
+
+  in_rows(
+    .list = x_stats,
+    .formats = .formats,
+    .names = names(.labels),
+    .stat_names = .stat_names,
+    .labels = .labels %>% .unlist_keep_nulls(),
+    .indent_mods = .indent_mods %>% .unlist_keep_nulls()
+  )
+}
 
 #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments
 #'   and additional format arguments. This function is a wrapper for [rtables::analyze()].
@@ -138,37 +202,59 @@
 #' @order 2
 test_proportion_diff <- function(lyt,
                                  vars,
-                                 variables = list(strata = NULL),
-                                 method = c("chisq", "schouten", "fisher", "cmh"),
+                                 var_labels = vars,
                                  na_str = default_na_str(),
                                  nested = TRUE,
-                                 ...,
-                                 var_labels = vars,
                                  show_labels = "hidden",
                                  table_names = vars,
-                                 .stats = NULL,
-                                 .formats = NULL,
+                                 section_div = NA_character_,
+                                 ...,
+                                 na_rm = TRUE,
+                                 variables = list(strata = NULL),
+                                 # conf_level = 0.95,
+                                 method = c("chisq", "schouten", "fisher", "cmh"),
+                                 .stats = c("pval"),
+                                 # .stats = c("diff", "diff_ci"),
+                                 .stat_names = NULL,
+                                 .formats = c(pval = "x.xxxx | (<0.0001)"),
                                  .labels = NULL,
-                                 .indent_mods = NULL) {
-  extra_args <- list(variables = variables, method = method, ...)
+                                 .indent_mods = c(pval = 1L)) {
+  # Depending on main functions
+  extra_args <- list(
+    "na_rm" = na_rm,
+    "variables" = variables,
+    # "conf_level" = conf_level,
+    "method" = method,
+    ...
+  )
 
-  afun <- make_afun(
-    a_test_proportion_diff,
-    .stats = .stats,
-    .formats = .formats,
-    .labels = .labels,
-    .indent_mods = .indent_mods
+  # Needed defaults
+  if (!is.null(.stats)) extra_args[[".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
+
+  # Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params)
+  extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE)
+  formals(a_test_proportion_diff) <- c(
+    formals(a_test_proportion_diff),
+    extra_args[[".additional_fun_parameters"]]
   )
+
+  # Main {rtables} structural call
   analyze(
-    lyt,
-    vars,
-    afun = afun,
+    lyt = lyt,
+    vars = vars,
     var_labels = var_labels,
+    afun = a_test_proportion_diff,
     na_str = na_str,
+    inclNAs = !na_rm,
     nested = nested,
     extra_args = extra_args,
     show_labels = show_labels,
-    table_names = table_names
+    table_names = table_names,
+    section_div = section_div
   )
 }