Merge branch 'main' into 1105_fix_params@main

Signed-off-by: Davide Garolini <[email protected]>
insightsengineering · Oct 31, 2023 · 23dc605 · 23dc605
2 parents 8a9e767 + 413f6d9
commit 23dc605
Show file tree

Hide file tree

Showing 21 changed files with 1,094 additions and 74 deletions.
diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml
@@ -6,7 +6,7 @@ default_language_version:
   python: python3
 repos:
   - repo: https://github.com/lorenzwalthert/precommit
-    rev: v0.3.2.9023
+    rev: v0.3.2.9025
     hooks:
       - id: style-files
         name: Style code with `styler`

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: tern
 Title: Create Common TLGs Used in Clinical Trials
-Version: 0.9.2.9002
-Date: 2023-10-27
+Version: 0.9.2.9004
+Date: 2023-10-31
 Authors@R: c(
     person("Joe", "Zhu", , "[email protected]", role = c("aut", "cre")),
     person("Daniel", "Sabanés Bové", , "[email protected]", role = "aut"),
@@ -167,3 +167,4 @@ Collate:
     'utils_factor.R'
     'utils_grid.R'
     'utils_rtables.R'
+    'utils_split_funs.R'
diff --git a/NAMESPACE b/NAMESPACE
@@ -129,6 +129,7 @@ export(g_lineplot)
 export(g_step)
 export(g_waterfall)
 export(get_formats_from_stats)
+export(get_indents_from_stats)
 export(get_labels_from_stats)
 export(get_smooths)
 export(get_stats)
@@ -218,6 +219,7 @@ export(has_fractions_difference)
 export(imputation_rule)
 export(keep_content_rows)
 export(keep_rows)
+export(level_order)
 export(logistic_regression_cols)
 export(logistic_summary_by_flag)
 export(month2day)
@@ -235,6 +237,7 @@ export(prop_strat_wilson)
 export(prop_wald)
 export(prop_wilson)
 export(reapply_varlabels)
+export(ref_group_position)
 export(s_compare)
 export(s_count_occurrences)
 export(s_count_occurrences_by_grade)
@@ -268,6 +271,7 @@ export(summarize_coxreg)
 export(summarize_glm_count)
 export(summarize_logistic)
 export(summarize_num_patients)
+export(summarize_occurrences)
 export(summarize_occurrences_by_grade)
 export(summarize_patients_events_in_cols)
 export(summarize_patients_exposure_in_cols)

diff --git a/NEWS.md b/NEWS.md
@@ -1,4 +1,9 @@
-# tern 0.9.2.9002
+# tern 0.9.2.9004
+
+### New Features
+* 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.
 
 ### Miscellaneous
 * Specified minimal version of package dependencies.
@@ -7,6 +12,8 @@
 
 ### New Features
 * Added the `na_str` argument to `analyze` & `summarize_row_groups` wrapper functions `count_abnormal`, `count_abnormal_by_baseline`, `count_abnormal_by_marked`, `count_abnormal_by_worst_grade`, `count_abnormal_lab_worsen_by_baseline`, `count_cumulative`, `count_missed_doses`, `count_occurrences`, `count_occurrences_by_grade`, `summarize_occurrences_by_grade`, `summarize_patients_events_in_cols`, `count_patients_with_event`, `count_patients_with_flags`, `count_values`, `estimate_multinomial_response`, `estimate_proportion`, `h_tab_one_biomarker`, `estimate_incidence_rate`, `logistic_summary_by_flag`, `estimate_odds_ratio`, `estimate_proportion_diff`, `test_proportion_diff`, `summarize_ancova`, `summarize_change`, `summarize_glm_count`, `summarize_num_patients`, `analyze_num_patients`, `summarize_patients_exposure_in_cols`, `coxph_pairwise`, `tabulate_survival_subgroups`, `surv_time`, and `surv_timepoint`.
+* Added function `get_indents_from_stats` to format and return indent modifiers for a given set of statistics.
+* Added summarize function version of `count_occurrences` analyze function, `summarize_occurrences`.
 
 ### Enhancements
 * Added formatting function `format_count_fraction_lt10` for formatting `count_fraction` with special consideration when count is less than 10.

diff --git a/R/count_occurrences.R b/R/count_occurrences.R
@@ -111,10 +111,7 @@ s_count_occurrences <- function(df,
 #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()].
 #'
 #' @examples
-#' #  We need to ungroup `count_fraction` first so that the `rtables` formatting
-#' # function `format_count_fraction()` can be applied correctly.
-#' afun <- make_afun(a_count_occurrences, .ungroup_stats = c("count", "count_fraction", "fraction"))
-#' afun(
+#' a_count_occurrences(
 #'   df,
 #'   .N_col = N_per_col,
 #'   .df_row = df,
@@ -123,10 +120,61 @@ s_count_occurrences <- function(df,
 #' )
 #'
 #' @export
-a_count_occurrences <- make_afun(
-  s_count_occurrences,
-  .formats = c(count = "xx", count_fraction = format_count_fraction_fixed_dp, fraction = format_fraction_fixed_dp)
-)
+a_count_occurrences <- function(df,
+                                labelstr = "",
+                                id = "USUBJID",
+                                denom = c("N_col", "n"),
+                                drop = TRUE,
+                                .N_col, # nolint
+                                .var = NULL,
+                                .df_row = NULL,
+                                .stats = NULL,
+                                .formats = NULL,
+                                .labels = NULL,
+                                .indent_mods = NULL,
+                                na_str = NA_character_) {
+  denom <- match.arg(denom)
+  x_stats <- s_count_occurrences(
+    df = df, denom = denom, .N_col = .N_col, .df_row = .df_row, drop = drop, .var = .var, id = id
+  )
+  if (is.null(unlist(x_stats))) {
+    return(NULL)
+  }
+  x_lvls <- names(x_stats[[1]])
+
+  # Fill in with formatting defaults if needed
+  .stats <- get_stats("count_occurrences", stats_in = .stats)
+  .formats <- get_formats_from_stats(.stats, .formats)
+  .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls)
+  .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = x_lvls)
+
+  if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
+  x_stats <- x_stats[.stats]
+
+  # Ungroup statistics with values for each level of x
+  x_ungrp <- ungroup_stats(x_stats, .formats, list(), list())
+  x_stats <- x_ungrp[["x"]]
+  .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])
+    })
+  }
+
+  in_rows(
+    .list = x_stats,
+    .formats = .formats,
+    .names = .labels,
+    .labels = .labels,
+    .indent_mods = .indent_mods,
+    .format_na_strs = na_str
+  )
+}
 
 #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments
 #'   and additional format arguments. This function is a wrapper for [rtables::analyze()].
@@ -147,7 +195,8 @@ a_count_occurrences <- make_afun(
 #'     "MH1", "MH2", "MH1", "MH1", "MH1", "MH3",
 #'     "MH2", "MH2", "MH3", "MH1", "MH2", "MH4"
 #'   ),
-#'   ARM = rep(c("A", "B"), each = 6)
+#'   ARM = rep(c("A", "B"), each = 6),
+#'   SEX = c("F", "F", "M", "M", "M", "M", "F", "F", "F", "M", "M", "F")
 #' )
 #' df_adsl <- df %>%
 #'   select(USUBJID, ARM) %>%
@@ -174,36 +223,32 @@ count_occurrences <- function(lyt,
                               nested = TRUE,
                               ...,
                               table_names = vars,
-                              .stats = "count_fraction",
+                              .stats = "count_fraction_fixed_dp",
                               .formats = NULL,
                               .labels = NULL,
                               .indent_mods = NULL) {
   checkmate::assert_flag(riskdiff)
 
-  afun <- make_afun(
-    a_count_occurrences,
-    .stats = .stats,
-    .formats = .formats,
-    .labels = .labels,
-    .indent_mods = .indent_mods,
-    .ungroup_stats = .stats
+  extra_args <- list(
+    .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str
   )
 
-  extra_args <- if (isFALSE(riskdiff)) {
-    list(...)
+  if (isFALSE(riskdiff)) {
+    extra_args <- c(extra_args, list(...))
   } else {
-    list(
-      afun = list("s_count_occurrences" = afun),
-      .stats = .stats,
-      .indent_mods = .indent_mods,
-      s_args = list(...)
+    extra_args <- c(
+      extra_args,
+      list(
+        afun = list("s_count_occurrences" = a_count_occurrences),
+        s_args = list(...)
+      )
     )
   }
 
   analyze(
     lyt = lyt,
     vars = vars,
-    afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),
+    afun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),
     var_labels = var_labels,
     show_labels = show_labels,
     table_names = table_names,
@@ -212,3 +257,59 @@ count_occurrences <- function(lyt,
     extra_args = extra_args
   )
 }
+
+#' @describeIn count_occurrences Layout-creating function which can take content function arguments
+#'   and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].
+#'
+#' @return
+#' * `summarize_occurrences()` returns a layout object suitable for passing to further layouting functions,
+#'   or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows
+#'   containing the statistics from `s_count_occurrences()` to the table layout.
+#'
+#' @examples
+#' # Layout creating function with custom format.
+#' basic_table() %>%
+#'   add_colcounts() %>%
+#'   split_rows_by("SEX", child_labels = "visible") %>%
+#'   summarize_occurrences(
+#'     var = "MHDECOD",
+#'     .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+#'   ) %>%
+#'   build_table(df, alt_counts_df = df_adsl)
+#'
+#' @export
+summarize_occurrences <- function(lyt,
+                                  var,
+                                  riskdiff = FALSE,
+                                  na_str = NA_character_,
+                                  ...,
+                                  .stats = "count_fraction_fixed_dp",
+                                  .formats = NULL,
+                                  .indent_mods = NULL,
+                                  .labels = NULL) {
+  checkmate::assert_flag(riskdiff)
+
+  extra_args <- list(
+    .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str
+  )
+
+  if (isFALSE(riskdiff)) {
+    extra_args <- c(extra_args, list(...))
+  } else {
+    extra_args <- c(
+      extra_args,
+      list(
+        afun = list("s_count_occurrences" = a_count_occurrences),
+        s_args = list(...)
+      )
+    )
+  }
+
+  summarize_row_groups(
+    lyt = lyt,
+    var = var,
+    cfun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),
+    na_str = na_str,
+    extra_args = extra_args
+  )
+}
diff --git a/R/riskdiff.R b/R/riskdiff.R
@@ -78,7 +78,10 @@ afun_riskdiff <- function(df,
                           .spl_context,
                           .all_col_counts,
                           .stats,
-                          .indent_mods,
+                          .formats = NULL,
+                          .labels = NULL,
+                          .indent_mods = NULL,
+                          na_str = NA_character_,
                           afun,
                           s_args = list()) {
   if (!any(grepl("riskdiff", names(.spl_context)))) {
@@ -89,8 +92,10 @@ afun_riskdiff <- function(df,
   }
   checkmate::assert_list(afun, len = 1, types = "function")
   checkmate::assert_named(afun)
-
-  afun_args <- list(.var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr)
+  afun_args <- list(
+    .var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr,
+    .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str
+  )
   afun_args <- afun_args[intersect(names(afun_args), names(as.list(args(afun[[1]]))))]
   if ("denom" %in% names(s_args)) afun_args[["denom"]] <- NULL
 
@@ -113,8 +118,9 @@ afun_riskdiff <- function(df,
     cur_var <- tail(.spl_context$cur_col_split[[1]], 1)
 
     # Apply statistics function to arm X and arm Y data
-    s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), afun_args, s_args))
-    s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), afun_args, s_args))
+    s_args <- c(s_args, afun_args[intersect(names(afun_args), names(as.list(args(names(afun)))))])
+    s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), s_args))
+    s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), s_args))
 
     # Get statistic name and row names
     stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")

diff --git a/R/summarize_functions.R b/R/summarize_functions.R
@@ -10,6 +10,7 @@
 #' * [h_tab_one_biomarker()] (probably to deprecate)
 #' * [logistic_summary_by_flag()]
 #' * [summarize_num_patients()]
+#' * [summarize_occurrences()]
 #' * [summarize_occurrences_by_grade()]
 #' * [summarize_patients_events_in_cols()]
 #' * [summarize_patients_exposure_in_cols()]