Make as card check format

R/ard_attributes.R

@@ -54,7 +54,7 @@ ard_attributes.data.frame <- function(data,
 
   # return empty ARD if no variables selected ----------------------------------
   if (is_empty(variables)) {
-    return(dplyr::tibble() |> as_card())
+    return(dplyr::tibble() |> as_card(check = FALSE))
   }
 
 

R/ard_formals.R

@@ -46,5 +46,5 @@ ard_formals <- function(fun, arg_names, passed_args = list(),
   # put formals list in ARD structure ------------------------------------------
   enframe(lst_args[arg_names], "stat_name", "stat") |>
     dplyr::mutate(stat_label = .data$stat_name, .after = "stat_name") |>
-    as_card()
+    as_card(check = FALSE)
 }

R/ard_hierarchical.R

@@ -114,7 +114,7 @@ ard_hierarchical.data.frame <- function(data,
 
   # return empty ARD if no variables selected ----------------------------------
   if (is_empty(variables)) {
-    return(dplyr::tibble() |> as_card())
+    return(dplyr::tibble() |> as_card(check = FALSE))
   }
 
   # if denominator doesn't have all by, they need to be added ------------------
@@ -192,7 +192,7 @@ ard_hierarchical_count.data.frame <- function(data,
 
   # return empty ARD if no variables selected ----------------------------------
   if (is_empty(variables)) {
-    return(dplyr::tibble() |> as_card())
+    return(dplyr::tibble() |> as_card(check = FALSE))
   }
 
   # add dummy variable for counting --------------------------------------------
@@ -210,7 +210,7 @@ ard_hierarchical_count.data.frame <- function(data,
   ) |>
     .rename_last_group_as_variable(by = by, variables = variables) |>
     dplyr::mutate(context = "hierarchical_count") |>
-    as_card()
+    as_card(check = FALSE)
 }
 
 #' Rename Last Group to Variable

R/ard_missing.R

@@ -58,7 +58,7 @@ ard_missing.data.frame <- function(data,
 
   # return empty ARD if no variables selected ----------------------------------
   if (is_empty(variables)) {
-    return(dplyr::tibble() |> as_card())
+    return(dplyr::tibble() |> as_card(check = FALSE))
   }
 
   # convert all variables to T/F whether it's missing --------------------------

R/ard_mvsummary.R

@@ -91,7 +91,7 @@ ard_mvsummary.data.frame <- function(data,
 
   # return empty ARD if no variables selected ----------------------------------
   if (is_empty(variables)) {
-    return(dplyr::tibble() |> as_card())
+    return(dplyr::tibble() |> as_card(check = FALSE))
   }
 
   missing_statistics_vars <- setdiff(variables, names(statistic))

R/ard_stack_hierarchical.R

@@ -517,7 +517,7 @@ internal_stack_hierarchical <- function(
   }
 
   # return final result --------------------------------------------------------
-  result |> as_card()
+  result |> as_card(check = FALSE)
 }
 
 # this function calculates either the counts or the rates of the events

R/ard_strata.R

@@ -111,6 +111,6 @@ ard_strata <- function(.data, .by = NULL, .strata = NULL, .f, ...) {
   # unnest ard data frame and return final table -------------------------------
   df_nested_data |>
     tidyr::unnest(cols = all_of("ard")) |>
-    as_card() |>
+    as_card(check = FALSE) |>
     tidy_ard_column_order(group_order = "descending")
 }

R/ard_summary.R

@@ -127,7 +127,7 @@ ard_summary.data.frame <- function(data,
 
   # return empty ARD if no variables selected ----------------------------------
   if (is_empty(variables)) {
-    return(dplyr::tibble() |> as_card())
+    return(dplyr::tibble() |> as_card(check = FALSE))
   }
 
 
@@ -187,7 +187,7 @@ ard_summary.data.frame <- function(data,
     dplyr::mutate(context = "summary") |>
     tidy_ard_column_order() |>
     tidy_ard_row_order() |>
-    as_card()
+    as_card(check = FALSE)
 }
 
 

R/ard_tabulate.R

@@ -145,7 +145,7 @@ ard_tabulate.data.frame <- function(data,
 
   # return empty ARD if no variables selected ----------------------------------
   if (is_empty(variables)) {
-    return(dplyr::tibble() |> as_card())
+    return(dplyr::tibble() |> as_card(check = FALSE))
   }
 
   # return note about column names that result in errors -----------------------
@@ -218,7 +218,7 @@ ard_tabulate.data.frame <- function(data,
     dplyr::mutate(context = "tabulate") |>
     tidy_ard_column_order() |>
     tidy_ard_row_order() |>
-    as_card()
+    as_card(check = FALSE)
 }
 
 

R/ard_tabulate_value.R

@@ -70,7 +70,7 @@ ard_tabulate_value.data.frame <- function(data,
 
   # return empty ARD if no variables selected ----------------------------------
   if (is_empty(variables)) {
-    return(dplyr::tibble() |> as_card())
+    return(dplyr::tibble() |> as_card(check = FALSE))
   }
 
   # calculate summary statistics -----------------------------------------------

R/as_card.R

@@ -2,9 +2,11 @@
 #'
 #' Convert data frames to ARDs of class 'card'.
 #'
+#'
 #' @param x (`data.frame`)\cr
 #'   a data frame
-#'
+#' @param check (scalar `logical`)\cr
+#'   Whether the input data frame should be checked for standard ARD features
 #' @return an ARD data frame of class 'card'
 #' @export
 #'
@@ -14,17 +16,34 @@
 #'   stat_label = c("N", "Mean"),
 #'   stat = c(10, 0.5)
 #' ) |>
-#'   as_card()
-as_card <- function(x) {
+#'   as_card( check = FALSE)
+#'  dplyr::tibble(
+#'   variable = "AGE",
+#'   stat_name = c("N", "mean"),
+#'   stat_label = c("N", "Mean"),
+#'   stat = list(10, 0.5),
+#'   fmt_fun = replicate(2, list()),
+#'   warning = replicate(2, list()),
+#'   error = replicate(2, list())
+#' ) |>
+#'   as_card( )
+as_card <- function(x, check = TRUE) {
   set_cli_abort_call()
 
   # check in inputs ------------------------------------------------------------
   check_class(x, cls = "data.frame")
 
   # convert to class "card" ----------------------------------------------------
   if (inherits(x, "card")) {
-    x
+    out <- x
   } else {
-    structure(x, class = c("card", class(x)))
+    out <- structure(x, class = c("card", class(x)))
+  }
+  if(check){
+    check_ard_structure(out, column_order = FALSE, method = FALSE,
+                        error_on_fail = TRUE)
   }
+
+  return(out)
+
 }

R/bind_ard.R

@@ -99,5 +99,5 @@ bind_ard <- function(..., .distinct = TRUE, .update = FALSE, .order = FALSE, .qu
   }
 
   # return stacked ARDs --------------------------------------------------------
-  tidy_ard_column_order(data) |> as_card()
+  tidy_ard_column_order(data) |> as_card(check = FALSE)
 }

R/check_ard_structure.R

@@ -9,25 +9,34 @@
 #'   check whether ordering of columns adheres to to `cards::tidy_ard_column_order()`.
 #' @param method (scalar `logical`)\cr
 #'   check whether a `"stat_name"` equal to `"method"` appears in results.
+#' @param error_on_fail (scalar `logical`)\cr
+#'   Error if a check is failed? FALSE by default.
 #' @return an ARD data frame of class 'card' (invisible)
 #' @export
 #'
 #' @examples
 #' ard_summary(ADSL, variables = "AGE") |>
 #'   dplyr::select(-warning, -error) |>
 #'   check_ard_structure()
-check_ard_structure <- function(x, column_order = TRUE, method = TRUE) {
+check_ard_structure <- function(x, column_order = TRUE, method = TRUE,
+                                error_on_fail = FALSE) {
   set_cli_abort_call()
   check_scalar_logical(method)
   check_scalar_logical(column_order)
+  check_scalar_logical(error_on_fail)
 
   # check class ----------------------------------------------------------------
   if (!inherits(x, "card")) {
-    cli::cli_inform("Object is not of class {.cls card}.")
+    .message_or_error("Object is not of class {.cls card}.", error_on_fail,
+                      envir = environment())
   }
 
   # exit if not a data frame ---------------------------------------------------
   if (!inherits(x, "data.frame")) {
+    .message_or_error(
+      "Object is not of class {.cls data.frame}.",
+      error = error_on_fail,
+      envir = environment())
     return(invisible())
   }
 
@@ -39,42 +48,58 @@ check_ard_structure <- function(x, column_order = TRUE, method = TRUE) {
     ) |>
     setdiff(names(x))
   if (!is_empty(missing_variables)) {
-    cli::cli_inform("The following columns are not present: {.val {missing_variables}}.")
+    .message_or_error(
+      "The following columns are not present: {.val {missing_variables}}.",
+      error = error_on_fail,
+      envir = environment())
   }
 
   # check whether AR contains a method stat ------------------------------------
   if (isTRUE(method)) {
     if (!"method" %in% x$stat_name) {
-      cli::cli_inform("Expecting a row with {.code stat_name = 'method'}, but it is not present.")
+      .message_or_error(
+        "Expecting a row with {.code stat_name = 'method'}, but it is not present.",
+        error = error_on_fail,
+        envir = environment())
     }
   }
 
   # check order of columns -----------------------------------------------------
   if (isTRUE(column_order)) {
     if (!identical(names(x), names(tidy_ard_column_order(x)))) {
-      cli::cli_inform(
-        c("The column order is not in the standard order.",
+      .message_or_error(
+        c(
+          "The column order is not in the standard order.",
           i = "Use {.fun cards::tidy_ard_column_order} for standard ordering."
-        )
-      )
+          ),
+        error = error_on_fail,
+        envir = environment())
     }
   }
 
+  # Check whether expected columns are present ---------------------------------
+
+
+
   # check columns are list columns as expected ---------------------------------
   expected_lst_columns <-
     dplyr::select(
       x, all_ard_groups(), all_ard_variables(),
       any_of(c("stat", "fmt_fun", "warning", "error"))
     ) |>
     # remove group## and variable columns
-    dplyr::select(-matches("^group[0-9]$"), -"variable") |>
+    dplyr::select(-matches("^group[0-9]$"), -any_of("variable")) |>
     names()
   not_a_lst_columns <-
     x[expected_lst_columns] |>
     dplyr::select(-where(is.list)) |>
     names()
   if (!is_empty(not_a_lst_columns)) {
-    cli::cli_inform("The following columns are expected to be list columns: {.val {not_a_lst_columns}}.")
+    .message_or_error(
+      "The following columns are expected to be list columns: {.val {not_a_lst_columns}}.",
+      error = error_on_fail,
+      envir = environment()
+      )
   }
 
   invisible(x)

R/filter_ard_hierarchical.R

@@ -304,7 +304,7 @@ filter_ard_hierarchical <- function(x, filter, var = NULL, keep_empty = FALSE, q
             # add overall stats - derive values if overall=FALSE
             if (!no_overall) {
               .df_overall <- .g |>
-                as_card() |>
+                as_card(check = FALSE) |>
                 cards::rename_ard_groups_shift()
               .df_overall <- dplyr::left_join(.df_overall, x_overall, by = names(.df_overall))
             }
@@ -423,5 +423,5 @@ filter_ard_hierarchical <- function(x, filter, var = NULL, keep_empty = FALSE, q
   # if present, keep attributes at bottom of ARD
   if (has_attr) x <- dplyr::bind_rows(x, x_attr)
 
-  as_card(x)
+  as_card(x, check = FALSE)
 }

R/mock.R

@@ -96,7 +96,7 @@ mock_categorical <- function(variables,
 
   # merge the by ARD and the primary variable ARD ------------------------------
   merge(ard_by, ard_variables, by = NULL) |>
-    as_card() |>
+    as_card(check = FALSE) |>
     tidy_ard_row_order() |>
     tidy_ard_column_order()
 }
@@ -154,7 +154,7 @@ mock_continuous <- function(variables,
 
   # merge the by ARD and the primary variable ARD ------------------------------
   merge(ard_by, ard_variables, by = NULL) |>
-    as_card() |>
+    as_card(check = FALSE) |>
     tidy_ard_row_order() |>
     tidy_ard_column_order()
 }

R/tidy_as_ard.R

@@ -117,5 +117,5 @@ tidy_as_ard <- function(lst_tidy,
   ) |>
     tidy_ard_column_order() |>
     tidy_ard_row_order() |>
-    as_card()
+    as_card(check = FALSE)
 }

R/utils.R

@@ -90,3 +90,39 @@
 
   ret
 }
+
+
+#' Message or error
+#'
+#' Either error or message depending on input
+#'
+#' @param msg (scalar `character`)\cr
+#'   Error message
+#' @param error (scalar `logical`)\cr
+#'     If this should produce an error or a warning. FALSE by default
+#' @param envir (`environment`)\cr
+#'   Environment to evaluate the glue expressions in passed in `cli::cli_abort(message)`.
+#'   Default is `rlang::current_env()`
+#' @inheritParams cli::cli_abort
+#' @return Invisible NULL
+#' @keywords internal
+#'
+#' @examples
+#' \dontrun{
+#' cards:::..warn_or_error("This will be a message", FALSE)
+#' cards:::..warn_or_error("This will be an error", TRUE)
+#' }
+.message_or_error <- function(msg, error = FALSE, call = get_cli_abort_call(),
+                              envir = rlang::current_env()) {
+  if(error){
+    cli::cli_abort(
+      msg, call = call, .envir = envir
+    )
+  }else{
+    cli::cli_inform(msg, call = call, .envir = envir)
+  }
+  return(invisible())
+
+}
+
+