Data Registration

NAMESPACE

@@ -16,10 +16,12 @@ S3method(ard_tabulate_value,data.frame)
 S3method(ard_total_n,data.frame)
 S3method(fill_formula_selectors,data.frame)
 S3method(print,card)
+S3method(print,cards_data_desc)
 S3method(process_formula_selectors,data.frame)
 S3method(process_selectors,data.frame)
 export("%>%")
 export(add_calculated_row)
+export(add_registered_data_column)
 export(alias_as_fmt_fn)
 export(alias_as_fmt_fun)
 export(all_ard_group_n)
@@ -88,6 +90,7 @@ export(one_of)
 export(print_ard_conditions)
 export(process_formula_selectors)
 export(process_selectors)
+export(register_data)
 export(rename_ard_columns)
 export(rename_ard_groups_reverse)
 export(rename_ard_groups_shift)

R/ard_summary.R

@@ -184,6 +184,7 @@ ard_summary.data.frame <- function(data,
 
   # add meta data and class ----------------------------------------------------
   df_results |>
+    add_registered_data_column(data = data) |>
     dplyr::mutate(context = "summary") |>
     tidy_ard_column_order() |>
     tidy_ard_row_order() |>

R/print.R

@@ -40,7 +40,9 @@ print.card <- function(x, n = NULL, columns = c("auto", "all"), n_col = 6L, ...)
   if (arg_match(columns) %in% "auto") {
     x_print <-
       dplyr::select(
-        x_print, all_ard_groups(), all_ard_variables(),
+        x_print,
+        any_of("data"),
+        all_ard_groups(), all_ard_variables(),
         any_of(c(
           "context", "stat_name", "stat_label", "stat", "stat_fmt",
           "fmt_fun", "warning", "error"

R/register_data.R

@@ -0,0 +1,72 @@
+#' Register Data Frame
+#'
+#' - `register_data()`: Register a data frame
+#' - `add_registered_data_column()`: Add the data registration information to the ARD
+#'
+#' @param data a data frame, e.g. `ADSL`.
+#' @param filter_expr an expression that will be applied to the data frame passed in `data`.
+#' @param data_name string of the data frame name. Default is `rlang::caller_arg(data)`.
+#' @param filter_label string describing the filter. The default is the string version
+#'   filter expression.
+#'
+#' @returns data frame
+#' @name register_data
+#'
+#' @examples
+NULL
+
+#' @export
+#' @rdname register_data
+register_data <- function(data,
+                          filter_expr = TRUE,
+                          data_name = rlang::caller_arg(data),
+                          filter_label = rlang::expr_deparse(filter_expr, width = Inf)) {
+  set_cli_abort_call()
+
+  # check inputs ---------------------------------------------------------------
+  check_data_frame(data)
+  if (!missing(filter_expr)) {
+    filter_expr <- rlang::enexpr(filter_expr)
+    if (!rlang::is_call_simple(filter_expr)) {
+      cli::cli_abort(
+        c("The {.arg filter_expr} argument must be a simple {.emph simple} call.",
+          "i" = "See {.fun is_call_simple} for details."),
+        call = get_cli_abort_call()
+      )
+    }
+  }
+  check_string(data_name)
+  check_string(filter_label)
+
+  # Add column and apply filter --------------------------------------------------
+  data <-
+    data |>
+    dplyr::filter(!!filter_expr) |>
+    structure(class = c("cards_data", class(data)))
+
+  attr(data, "cards_data_desc") <-
+    list(data_name = data_name, filter_label = filter_label) |>
+    structure(class = "cards_data_desc")
+
+  data
+}
+
+#' @export
+#' @rdname register_data
+add_registered_data_column <- function(x, data) {
+  # if not a registered data frame, return the ARD as it is
+  if (!inherits(data, "cards_data")) return(x)
+
+  x |>
+    dplyr::mutate(
+      .before = 1L,
+      data = list(attr(data, "cards_data_desc"))
+    )
+}
+
+#' @export
+#' @rdname register_data
+print.cards_data_desc <- function(x) {
+  paste(data_name, filter_label, sep = ": ") |>
+    print()
+}

R/tidy_ard_order.R

@@ -52,6 +52,7 @@ tidy_ard_column_order <- function(x, group_order = c("ascending", "descending"))
   # selecting the columns in the tidy order
   dplyr::select(
     x,
+    any_of("data"),
     all_of(group_cols),
     all_ard_variables(),
     any_of(c(

tests/testthat/test-register_data.R

@@ -0,0 +1,16 @@
+test_that("register_data() works", {
+
+})
+
+test_that("register_data() in put checks", {
+  expect_snapshot(
+    register_data(data = letters)
+  )
+  expect_snapshot(
+    register_data(data = ADSL, name = letters)
+  )
+  expect_snapshot(
+    register_data(data = ADSL, name = letters)
+  )
+})
+