allow more statistics in cfbt01 template

R/cfbt01.R

@@ -10,9 +10,10 @@
 #' @param precision (named `list` of `integer`) where names are values found in the `PARAMCD` column and the the values
 #'   indicate the number of digits that should be represented for `min`, `max` and `median`. `Mean` and `sd` are
 #'   represented with one more decimal of precision.
-#' @param default_precision (`integer`) the default number of digits.
 #' @param page_by (`flag`) indicator whether the parameter row split is by page.
 #' @param row_split_var (`character`) row split variable other than `PARAMCD`.
+#' @param .stats (`character`) statistics names, see `summarize_vars()`.
+#' @param ... additional arguments like `.indent_mods`, `.labels`.
 #'
 #' @details
 #'  * The `Analysis Value` column, displays the number of patients, the mean, standard deviation, median and range of
@@ -36,9 +37,9 @@ cfbt01_main <- function(adam_db,
                         row_split_var = NULL,
                         summaryvars = c("AVAL", "CHG"),
                         visitvar = "AVISIT",
-                        precision = list(),
-                        default_precision = 2,
+                        precision = list(default = 2L),
                         page_by = TRUE,
+                        .stats = c("n", "mean_sd", "median", "range"),
                         ...) {
   assert_all_tablenames(adam_db, c("adsl", dataset))
   checkmate::assert_string(arm_var)
@@ -61,8 +62,12 @@ cfbt01_main <- function(adam_db,
   assert_valid_var_pair(adam_db$adsl, adam_db[[dataset]], arm_var)
   checkmate::assert_list(precision, types = "integerish", names = "unique")
   vapply(precision, checkmate::assert_int, FUN.VALUE = numeric(1), lower = 0)
-  checkmate::assert_integerish(default_precision, lower = 0)
-
+  all_stats <- c(
+    "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei",
+    "mean_sdi", "mean_pval", "median", "mad", "median_ci", "quantiles", "iqr", "range",
+    "cv", "min", "max", "median_range", "geom_mean", "geom_cv"
+  )
+  checkmate::assert_subset(.stats, all_stats)
   lbl_avisit <- var_labels_for(adam_db[[dataset]], visitvar)
   lbl_param <- var_labels_for(adam_db[[dataset]], "PARAM")
 
@@ -79,10 +84,10 @@ cfbt01_main <- function(adam_db,
     lbl_avisit = lbl_avisit,
     lbl_param = lbl_param,
     precision = precision,
-    default_precision = default_precision,
-    page_by = page_by
+    .stats = .stats,
+    page_by = page_by,
+    ...
   )
-
   tbl <- build_table(
     lyt,
     df = adam_db[[dataset]],
@@ -116,8 +121,9 @@ cfbt01_lyt <- function(arm_var,
                        lbl_avisit,
                        lbl_param,
                        precision,
-                       default_precision,
-                       page_by) {
+                       page_by,
+                       .stats,
+                       ...) {
   label_pos <- if (page_by) "hidden" else "topleft"
   basic_table(show_colcounts = TRUE) %>%
     split_cols_by(arm_var) %>%
@@ -148,7 +154,8 @@ cfbt01_lyt <- function(arm_var,
         paramcdvar = "PARAMCD",
         skip = c("BASELINE" = summaryvars[2]),
         precision = precision,
-        default_precision = default_precision
+        .stats = .stats,
+        ...
       )
     )
 }

R/rtables_utils.R

@@ -362,49 +362,65 @@ ifneeded_add_overall_col <- function(lyt, lbl_overall) {
 #' @param paramcdvar (`string`) name of parameter code.
 #' @param visitvar (`string`) name of the visit variable.
 #' @param skip Named (`character`) indicating the pairs to skip in analyze.
+#' @param .stats (`character`) See `tern::summarize_variables`.
+#' @param .label (`character`) See `tern::summarize_variables`.
+#' @param .indent_mods (`integer`) See `tern::summarize_variables`.
+#' @param .N_col (`int`) See `tern::summarize_variables`.
+#' @param .N_row (`int`) See `tern::summarize_variables`.
+#' @param ... additional arguments for `tern::create_afun_summary`.
 #' @inheritParams cfbt01_main
 #' @keywords internal
-afun_skip_baseline <- function(x, .var, .spl_context, paramcdvar, visitvar, skip, precision, default_precision, ...) {
+afun_skip_baseline <- function(
+    x, .var, .spl_context, paramcdvar, visitvar, skip,
+    precision, .stats, .labels = NULL, .indent_mods = NULL, .N_col, .N_row, ...) { # nolint
   param_val <- .spl_context$value[which(.spl_context$split == paramcdvar)]
-  pcs <- precision[[param_val]] %||% default_precision
-
-  # Create context dependent function.
-  n_fun <- sum(!is.na(x), na.rm = TRUE)
-  if (n_fun == 0) {
-    mean_sd_fun <- c(NA, NA)
-    median_fun <- NA
-    min_max_fun <- c(NA, NA)
-  } else {
-    mean_sd_fun <- c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE))
-    median_fun <- median(x, na.rm = TRUE)
-    min_max_fun <- c(min(x), max(x))
-  }
-
-  # Identify context-
+  # Identify context
   is_chg <- .var == skip
 
   is_baseline <- .spl_context$value[which(.spl_context$split == visitvar)] == names(skip)
-
   if (is_baseline && is_chg) {
-    n_fun <- mean_sd_fun <- median_fun <- min_max_fun <- NULL
+    pcs <- NA
+  } else {
+    pcs <- precision[[param_val]] %||% precision[["default"]] %||% 2
   }
 
-  in_rows(
-    "n" = n_fun,
-    "Mean (SD)" = mean_sd_fun,
-    "Median" = median_fun,
-    "Min - Max" = min_max_fun,
-    .formats = list(
-      "n" = "xx",
-      "Mean (SD)" = h_format_dec(format = "%f (%f)", digits = pcs + 1),
-      "Median" = h_format_dec(format = "%f", digits = pcs + 1),
-      "Min - Max" = h_format_dec(format = "%f - %f", digits = pcs)
-    ),
-    .format_na_strs = list(
-      "n" = "NE",
-      "Mean (SD)" = "NE (NE)",
-      "Median" = "NE",
-      "Min - Max" = "NE - NE"
-    )
+  fmts <- lapply(.stats, summary_formats, pcs = pcs, FALSE)
+  names(fmts) <- .stats
+  fmts_na <- lapply(.stats, summary_formats, pcs = pcs, ne = TRUE)
+  ret <- tern::create_afun_summary(
+    .stats, fmts, .labels, .indent_mods
+  )(x = x, .var = .var, .spl_context = .spl_context, .N_col = .N_col, .N_row = .N_row, ...)
+  for (i in seq_len(length(ret))) {
+    attr(ret[[i]], "format_na_str") <- fmts_na[[i]]()
+  }
+  ret
+}
+
+summary_formats <- function(x, pcs, ne = FALSE) {
+  checkmate::assert_int(pcs, lower = 0, na.ok = TRUE)
+  switch(x,
+    n = h_format_dec(format = "%s", digits = pcs - pcs, ne = ne),
+    min = ,
+    max = ,
+    sum = h_format_dec(format = "%s", digits = pcs, ne = ne),
+    mean = ,
+    sd = ,
+    median = ,
+    mad = ,
+    iqr = ,
+    cv = ,
+    geom_mean = ,
+    geom_cv = ,
+    se = h_format_dec(format = "%s", digits = pcs + 1, ne = ne),
+    mean_sd = ,
+    mean_se = h_format_dec(format = "%s (%s)", digits = rep(pcs + 1, 2), ne = ne),
+    mean_ci = ,
+    mean_sei = ,
+    median_ci = ,
+    mean_sdi = h_format_dec(format = "(%s, %s)", digits = rep(pcs + 1, 2), ne = ne),
+    mean_pval = h_format_dec(format = "%s", digits = 2, ne = ne),
+    quantiles = h_format_dec(format = "(%s - %s)", digits = rep(pcs + 1, 2), ne = ne),
+    range = h_format_dec(format = "%s - %s", digits = rep(pcs, 2), ne = ne),
+    median_range = h_format_dec(format = "%s (%s - %s)", digits = c(pcs, pcs + 1, pcs + 1), ne = ne)
   )
 }

R/utils.R

@@ -61,30 +61,33 @@ std_postprocess <- function(tlg, ind = 2L, ...) {
 #'
 #' @param digits (`integer`) number of digits.
 #' @param format (`string`) describing how the numbers should be formatted following the `sprintf` syntax.
+#' @param ne (`flag`) indicator whether to use "NE" to replace the actual value.
 #'
-#' @return `function` formatting numbers with the defined format or `NULL` if the format is not defined.
+#' @return `function` formatting numbers with the defined format.
 #'
 #' @export
 #'
 #' @examples
-#' fun <- h_format_dec(1, "%f - %f")
+#' fun <- h_format_dec(c(1, 1), "%s - %s")
 #' fun(c(123, 567.89))
 #'
-h_format_dec <- function(digits = NA, format = NA) {
-  checkmate::assert_int(digits, lower = 0, na.ok = TRUE)
-  checkmate::assert_string(format, na.ok = TRUE)
-
-  if (is.na(format)) {
-    NULL
-  } else {
+h_format_dec <- function(digits, format, ne = FALSE) {
+  checkmate::assert_integerish(digits, lower = 0)
+  checkmate::assert_string(format)
+  if (any(is.na(digits))) {
     function(x, ...) {
-      checkmate::assert_numeric(x)
-
-      digit_string <- ifelse(is.na(digits), "", paste0(".", digits))
-      new_format <- gsub("%([a-z])", paste0("%", digit_string, "\\1"), format)
-
-      formatters::sprintf_format(new_format)(x)
+      ""
+    }
+  } else {
+    if (ne) {
+      ret <- function(x, ...) {
+        do.call(sprintf, c(list(fmt = format), rep("NE", length(digits))))
+      }
+      return(ret)
     }
+    digit_string <- paste0("%", ifelse(is.na(digits), "", paste0(".", digits)), "f")
+    new_format <- do.call(sprintf, c(list(fmt = format), digit_string))
+    formatters::sprintf_format(new_format)
   }
 }