Add utility functions for labels and formats (#1122)

Fixes #1121

NAMESPACE

@@ -219,6 +219,7 @@ export(has_fractions_difference)
 export(imputation_rule)
 export(keep_content_rows)
 export(keep_rows)
+export(labels_use_control)
 export(level_order)
 export(logistic_regression_cols)
 export(logistic_summary_by_flag)

NEWS.md

@@ -4,6 +4,9 @@
 * Added `ref_group_position` function to place the reference group facet last, first or at a certain position.
 * Added `keep_level_order` split function to retain original order of levels in a split.
 * Added `level_order` split function to reorder manually the levels.
+* Added internal utility function `apply_auto_formatting` to check for `"auto"` formats and replace them with 
+  implementation of `format_auto` in analyze functions.
+* Added utility function `labels_use_control` to modify labels with control specifications.
 
 ### Enhancements
 * Added `ref_group_coxph` parameter to `g_km` to specify the reference group used for pairwise Cox-PH calculations when `annot_coxph = TRUE`.

R/analyze_variables.R

@@ -454,7 +454,6 @@ s_summary.logical <- function(x,
 #' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla")
 #' a_summary(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .var = "bla", compare = TRUE)
 #'
-
 #' @export
 a_summary <- function(x,
                       .N_col, # nolint
@@ -472,6 +471,7 @@ a_summary <- function(x,
                       na_level = lifecycle::deprecated(),
                       na_str = NA_character_,
                       ...) {
+  extra_args <- list(...)
   if (lifecycle::is_present(na_level)) {
     lifecycle::deprecate_warn("0.9.1", "a_summary(na_level)", "a_summary(na_str)")
     na_str <- na_level
@@ -504,30 +504,18 @@ a_summary <- function(x,
   met_grp <- paste0(c("analyze_vars", type), collapse = "_")
   .stats <- get_stats(met_grp, stats_in = .stats, add_pval = compare)
   .formats <- get_formats_from_stats(.stats, .formats)
-  .labels <- get_labels_from_stats(.stats, .labels)
-
-  indent_mods_custom <- .indent_mods
-  .indent_mods <- stats::setNames(rep(0L, length(.stats)), .stats)
-  if (!is.null(indent_mods_custom)) {
-    if (is.null(names(indent_mods_custom)) && length(indent_mods_custom) == 1) {
-      .indent_mods[names(.indent_mods)] <- indent_mods_custom
-    } else {
-      .indent_mods[names(indent_mods_custom)] <- indent_mods_custom
-    }
-  }
-
-  x_stats <- x_stats[.stats]
+  .indent_mods <- get_indents_from_stats(.stats, .indent_mods)
 
+  lbls <- get_labels_from_stats(.stats, .labels)
   # Check for custom labels from control_analyze_vars
-  if (is.numeric(x)) {
-    default_labels <- get_labels_from_stats(.stats)
-    for (i in intersect(.stats, c("mean_ci", "mean_pval", "median_ci", "quantiles"))) {
-      if (!i %in% names(.labels) || .labels[[i]] == default_labels[[i]]) {
-        .labels[[i]] <- attr(x_stats[[i]], "label")
-      }
-    }
+  .labels <- if ("control" %in% names(extra_args)) {
+    lbls %>% labels_use_control(extra_args[["control"]], .labels)
+  } else {
+    lbls
   }
 
+  x_stats <- x_stats[.stats]
+
   if (is.factor(x) || is.character(x)) {
     # Ungroup statistics with values for each level of x
     x_ungrp <- ungroup_stats(x_stats, .formats, .labels, .indent_mods)
@@ -537,15 +525,8 @@ a_summary <- function(x,
     .indent_mods <- x_ungrp[[".indent_mods"]]
   }
 
-  # auto formats handling
-  fmt_is_auto <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1))
-  if (any(fmt_is_auto)) {
-    res_l_auto <- x_stats[fmt_is_auto]
-    tmp_dt_var <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets
-    .formats[fmt_is_auto] <- lapply(seq_along(res_l_auto), function(rla) {
-      format_auto(tmp_dt_var, names(res_l_auto)[rla])
-    })
-  }
+  # Auto format handling
+  .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)
 
   in_rows(
     .list = x_stats,

R/analyze_vars_in_cols.R

@@ -163,6 +163,7 @@ analyze_vars_in_cols <- function(lyt,
                                  nested = TRUE,
                                  .formats = NULL,
                                  .aligns = NULL) {
+  extra_args <- list(...)
   if (lifecycle::is_present(na_level)) {
     lifecycle::deprecate_warn("0.9.1", "analyze_vars_in_cols(na_level)", "analyze_vars_in_cols(na_str)")
     na_str <- na_level
@@ -180,6 +181,7 @@ analyze_vars_in_cols <- function(lyt,
   .stats <- get_stats(met_grps, stats_in = .stats)
   formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats)
   labels_v <- get_labels_from_stats(stats = .stats, labels_in = .labels)
+  if ("control" %in% names(extra_args)) labels_v <- labels_v %>% labels_use_control(extra_args[["control"]], .labels)
 
   # Check for vars in the case that one or more are used
   if (length(vars) == 1) {
@@ -293,7 +295,7 @@ analyze_vars_in_cols <- function(lyt,
       var = unique(vars),
       cfun = cfun_list,
       na_str = na_str,
-      extra_args = list(...)
+      extra_args = extra_args
     )
   } else {
     # Function list for analyze_colvars
@@ -377,7 +379,7 @@ analyze_vars_in_cols <- function(lyt,
     analyze_colvars(lyt,
       afun = afun_list,
       nested = nested,
-      extra_args = list(...)
+      extra_args = extra_args
     )
   }
 }

R/count_occurrences.R

@@ -157,14 +157,7 @@ a_count_occurrences <- function(df,
   .formats <- x_ungrp[[".formats"]]
 
   # Auto format handling
-  fmt_is_auto <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1))
-  if (any(fmt_is_auto)) {
-    res_l_auto <- x_stats[fmt_is_auto]
-    tmp_dt_var <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets
-    .formats[fmt_is_auto] <- lapply(seq_along(res_l_auto), function(rla) {
-      format_auto(tmp_dt_var, names(res_l_auto)[rla])
-    })
-  }
+  .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)
 
   in_rows(
     .list = x_stats,

R/formatting_functions.R

@@ -554,3 +554,23 @@ count_decimalplaces <- function(dec) {
     return(0)
   }
 }
+
+#' Apply Auto Formatting
+#'
+#' Checks if any of the listed formats in `.formats` are `"auto"`, and replaces `"auto"` with
+#' the correct implementation of `format_auto` for the given statistics, data, and variable.
+#'
+#' @inheritParams argument_convention
+#' @param x_stats (named `list`)\cr a named list of statistics where each element corresponds
+#'   to an element in `.formats`, with matching names.
+#'
+#' @keywords internal
+apply_auto_formatting <- function(.formats, x_stats, .df_row, .var) {
+  is_auto_fmt <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1))
+  if (any(is_auto_fmt)) {
+    auto_stats <- x_stats[is_auto_fmt]
+    var_df <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets
+    .formats[is_auto_fmt] <- lapply(names(auto_stats), format_auto, dt_var = var_df)
+  }
+  .formats
+}

R/utils_default_stats_formats_labels.R

@@ -306,10 +306,66 @@ get_indents_from_stats <- function(stats, indents_in = NULL, row_nms = NULL) {
   out
 }
 
-#' @describeIn default_stats_formats_labels Named list of default formats for `tern`.
+#' Update Labels According to Control Specifications
+#'
+#' @description `r lifecycle::badge("stable")`
+#'
+#' Given a list of statistic labels and and a list of control parameters, updates labels with a relevant
+#' control specification. For example, if control has element `conf_level` set to `0.9`, the default
+#' label for statistic `mean_ci` will be updated to `"Mean 90% CI"`. Any labels that are supplied
+#' via `labels_custom` will not be updated regardless of `control`.
+#'
+#' @param labels_default (named `vector` of `character`)\cr a named vector of statistic labels to modify
+#'   according to the control specifications. Labels that are explicitly defined in `labels_custom` will
+#'   not be affected.
+#' @param labels_custom (named `vector` of `character`)\cr named vector of labels that are customized by
+#'   the user and should not be affected by `control`.
+#' @param control (named `list`)\cr list of control parameters to apply to adjust default labels.
+#'
+#' @return A named character vector of labels with control specifications applied to relevant labels.
+#'
+#' @examples
+#' control <- list(conf_level = 0.80, quantiles = c(0.1, 0.83), test_mean = 0.57)
+#' get_labels_from_stats(c("mean_ci", "quantiles", "mean_pval")) %>%
+#'   labels_use_control(control = control)
+#'
+#' @export
+labels_use_control <- function(labels_default, control, labels_custom = NULL) {
+  if ("conf_level" %in% names(control)) {
+    labels_default <- sapply(
+      names(labels_default),
+      function(x) {
+        if (!x %in% names(labels_custom)) {
+          gsub(labels_default[[x]], pattern = "[0-9]+% CI", replacement = f_conf_level(control[["conf_level"]]))
+        } else {
+          labels_default[[x]]
+        }
+      }
+    )
+  }
+  if ("quantiles" %in% names(control) && "quantiles" %in% names(labels_default) &&
+    !"quantiles" %in% names(labels_custom)) { # nolint
+    labels_default["quantiles"] <- gsub(
+      "[0-9]+% and [0-9]+", paste0(control[["quantiles"]][1] * 100, "% and ", control[["quantiles"]][2] * 100, ""),
+      labels_default["quantiles"]
+    )
+  }
+  if ("test_mean" %in% names(control) && "mean_pval" %in% names(labels_default) &&
+    !"mean_pval" %in% names(labels_custom)) { # nolint
+    labels_default["mean_pval"] <- gsub(
+      "p-value \\(H0: mean = [0-9\\.]+\\)", f_pval(control[["test_mean"]]), labels_default["mean_pval"]
+    )
+  }
+
+  labels_default
+}
+
+#' @describeIn default_stats_formats_labels Named vector of default formats for `tern`.
+#'
 #' @format
-#' * `tern_default_formats` is a list of available formats, named after their relevant
-#'   statistic.
+#' * `tern_default_formats` is a named vector of available default formats, with each element
+#'   named for their corresponding statistic.
+#'
 #' @export
 tern_default_formats <- c(
   fraction = format_fraction_fixed_dp,
@@ -348,14 +404,14 @@ tern_default_formats <- c(
   pval_counts = "x.xxxx | (<0.0001)"
 )
 
-#' @describeIn default_stats_formats_labels `character` vector that contains default labels
-#'   for `tern`.
+#' @describeIn default_stats_formats_labels Named `character` vector of default labels for `tern`.
+#'
 #' @format
-#' * `tern_default_labels` is a character vector of available labels, named after their relevant
-#'   statistic.
+#' * `tern_default_labels` is a named `character` vector of available default labels, with each element
+#'   named for their corresponding statistic.
+#'
 #' @export
 tern_default_labels <- c(
-  # list of labels -> sorted? xxx it should be not relevant due to match
   fraction = "fraction",
   unique = "Number of patients with at least one event",
   nonunique = "Number of events",

_pkgdown.yml

@@ -70,6 +70,7 @@ reference:
       - default_stats_formats_labels
       - starts_with("h_")
       - imputation_rule
+      - labels_use_control
       - starts_with("or_")
       - starts_with("prop_")
       - -starts_with("h_col_")

tests/testthat/_snaps/utils_default_stats_formats_labels.md

@@ -51,6 +51,30 @@
                      fraction 
                             0 
 
+# labels_use_control works as expected
+
+    Code
+      res
+    Output
+                               mean_ci                        mean_pval 
+                         "Mean 34% CI" "Mean p-value (H0: mean = 0.47)" 
+                             median_ci                        quantiles 
+                       "Median 34% CI"                "24% and 86%-ile" 
+                          geom_mean_ci 
+               "Geometric Mean 34% CI" 
+
+---
+
+    Code
+      res
+    Output
+                               mean_ci                        mean_pval 
+                             "mean ci" "Mean p-value (H0: mean = 0.47)" 
+                             median_ci                        quantiles 
+                       "Median 34% CI"                   "my quantiles" 
+                          geom_mean_ci 
+               "Geometric Mean 34% CI" 
+
 # summary_formats works as expected
 
     Code