Batch 1

NAMESPACE

@@ -45,6 +45,7 @@ export(analyze_vars_in_cols)
 export(append_varlabels)
 export(arrange_grobs)
 export(as.rtable)
+export(as_factor_keep_attributes)
 export(combine_counts)
 export(combine_groups)
 export(combine_levels)

NEWS.md

@@ -4,6 +4,8 @@
 * Refactored `count_abnormal()`, `count_abnormal_by_baseline()`, `count_abnormal_by_marked()`, `count_abnormal_by_worst_grade()`, `count_abnormal_lab_worsen_by_baseline()`, `coxph_pairwise()`, `estimate_multinomial_rsp()`, `estimate_proportion()`, `estimate_odds_ratio()`, `summarize_ancova()`, `summarize_glm_count()`, and `surv_timepoint()` to work without `make_afun()`.
 * Added `geom_sd` and `geom_mean_sd` to `s_summary()` default available statistics.
 * Refactored `h_tab_one_biomarker()`, `tabulate_rsp_subgroups()`, `tabulate_survival_subgroups()`, `tabulate_rsp_biomarkers()`, and `tabulate_survival_biomarkers()` to align with new analysis function style.
+* `as_factor_keep_attributes()` is now an exported function.
+* Refactored `count_cumulative()`, `count_missed_doses()`, `estimate_proportion_diff()`, and `test_proportion_diff()` to work without `make_afun()`.
 
 ### Bug Fixes
 * Fixed bug in `a_count_patients_with_flags()` preventing select custom label and indentation specification formats from being applied.
@@ -18,6 +20,8 @@
 * Began deprecation of the unused `label_all` parameter to `tabulate_rsp_subgroups()`, with redirection to the same parameter in `extract_rsp_subgroups()`.
 * Began deprecation of the no longer used helper functions `h_tab_one_biomarker()`, `h_tab_rsp_one_biomarker()`, and `h_tab_surv_one_biomarker()`.
 * Moved helper functions `h_tab_rsp_one_biomarker()` and `h_tab_surv_one_biomarker()` into `h_biomarkers_subgroups.R`.
+* Reorganized the utility documentation related to factors (`utils_factor.R`) into a single file.
+* Removed `s_count_nonmissing()` as it is a non-repeated small and internal function.
 
 # tern 0.9.7
 

R/count_cumulative.R

@@ -48,26 +48,26 @@ NULL
 #' x <- c(sample(1:10, 10), NA)
 #' .N_col <- length(x)
 #'
-#' h_count_cumulative(x, 5, .N_col = .N_col)
-#' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)
-#' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col)
-#' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col)
+#' h_count_cumulative(x, 5, denom = .N_col)
+#' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na_rm = FALSE, denom = .N_col)
+#' h_count_cumulative(x, 0, lower_tail = FALSE, denom = .N_col)
+#' h_count_cumulative(x, 100, lower_tail = FALSE, denom = .N_col)
 #'
 #' @export
 h_count_cumulative <- function(x,
                                threshold,
                                lower_tail = TRUE,
                                include_eq = TRUE,
-                               na.rm = TRUE, # nolint
-                               .N_col) { # nolint
+                               na_rm = TRUE,
+                               denom) {
   checkmate::assert_numeric(x)
   checkmate::assert_numeric(threshold)
-  checkmate::assert_numeric(.N_col)
+  checkmate::assert_numeric(denom)
   checkmate::assert_flag(lower_tail)
   checkmate::assert_flag(include_eq)
-  checkmate::assert_flag(na.rm)
+  checkmate::assert_flag(na_rm)
 
-  is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x))
+  is_keep <- if (na_rm) !is.na(x) else rep(TRUE, length(x))
   count <- if (lower_tail && include_eq) {
     length(x[is_keep & x <= threshold])
   } else if (lower_tail && !include_eq) {
@@ -80,7 +80,7 @@ h_count_cumulative <- function(x,
 
   result <- c(
     count = count,
-    fraction = if (count == 0 && .N_col == 0) 0 else count / .N_col
+    fraction = if (count == 0 && denom == 0) 0 else count / denom
   )
   result
 }
@@ -114,9 +114,10 @@ s_count_cumulative <- function(x,
                                thresholds,
                                lower_tail = TRUE,
                                include_eq = TRUE,
+                               denom = c("N_col", "n", "N_row"),
                                .N_col, # nolint
                                .N_row, # nolint
-                               denom = c("N_col", "n", "N_row"),
+                               na_rm = TRUE,
                                ...) {
   checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE)
 
@@ -128,7 +129,7 @@ s_count_cumulative <- function(x,
     )
 
   count_fraction_list <- Map(function(thres) {
-    result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = denom, ...)
+    result <- h_count_cumulative(x, thres, lower_tail, include_eq, na_rm = na_rm, denom = denom)
     label <- d_count_cumulative(thres, lower_tail, include_eq)
     formatters::with_label(result, label)
   }, thresholds)
@@ -144,10 +145,80 @@ s_count_cumulative <- function(x,
 #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()].
 #'
 #' @keywords internal
-a_count_cumulative <- make_afun(
-  s_count_cumulative,
-  .formats = c(count_fraction = format_count_fraction)
-)
+a_count_cumulative <- function(x,
+                               ...,
+                               .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$all_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_count_cumulative,
+    custom_stat_fnc_list = custom_stat_functions,
+    args_list = c(
+      x = list(x),
+      extra_afun_params,
+      dots_extra_args
+    )
+  )
+
+  # Fill in with stats defaults if needed
+  .stats <- get_stats("count_cumulative",
+    stats_in = .stats,
+    custom_stats_in = names(custom_stat_functions)
+  )
+
+  x_stats <- x_stats[.stats]
+  levels_per_stats <- lapply(x_stats, names)
+
+  # Fill in formats/indents/labels with custom input and defaults
+  .formats <- get_formats_from_stats(.stats, .formats, levels_per_stats)
+  .indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats)
+  if (is.null(.labels)) {
+    .labels <- sapply(.unlist_keep_nulls(x_stats), attr, "label")
+    .labels <- .labels[nzchar(.labels) & !sapply(.labels, is.null) & !is.na(.labels)]
+  }
+  .labels <- get_labels_from_stats(.stats, .labels, levels_per_stats)
+
+  # Unlist stats
+  x_stats <- x_stats %>%
+    .unlist_keep_nulls() %>%
+    setNames(names(.formats))
+
+  # 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
+
+  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 count_cumulative Layout-creating function which can take statistics function arguments
 #'   and additional format arguments. This function is a wrapper for [rtables::analyze()].
@@ -172,33 +243,50 @@ a_count_cumulative <- make_afun(
 count_cumulative <- function(lyt,
                              vars,
                              thresholds,
-                             lower_tail = TRUE,
-                             include_eq = TRUE,
                              var_labels = vars,
                              show_labels = "visible",
                              na_str = default_na_str(),
                              nested = TRUE,
-                             ...,
                              table_names = vars,
+                             ...,
+                             na_rm = TRUE,
+                             lower_tail = TRUE,
+                             include_eq = TRUE,
                              .stats = NULL,
+                             .stat_names = NULL,
                              .formats = NULL,
                              .labels = NULL,
                              .indent_mods = NULL) {
-  extra_args <- list(thresholds = thresholds, lower_tail = lower_tail, include_eq = include_eq, ...)
+  # Depending on main functions
+  extra_args <- list(
+    "na_rm" = na_rm,
+    "thresholds" = thresholds,
+    "lower_tail" = lower_tail,
+    "include_eq" = include_eq,
+    ...
+  )
 
-  afun <- make_afun(
-    a_count_cumulative,
-    .stats = .stats,
-    .formats = .formats,
-    .labels = .labels,
-    .indent_mods = .indent_mods,
-    .ungroup_stats = "count_fraction"
+  # 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_count_cumulative) <- c(
+    formals(a_count_cumulative),
+    extra_args[[".additional_fun_parameters"]]
   )
+
+  # Main {rtables} structural call
   analyze(
     lyt,
     vars,
-    afun = afun,
+    afun = a_count_cumulative,
     na_str = na_str,
+    inclNAs = !na_rm,
     table_names = table_names,
     var_labels = var_labels,
     show_labels = show_labels,