Merge branch 'main' into ci

DESCRIPTION

@@ -51,8 +51,6 @@ Imports:
 Suggests:
     arrow,
     bigrquery,
-    covr,
-    crayon,
     data.table,
     duckdb,
     ggforce,

R/col_schema_match.R

@@ -617,7 +617,7 @@ col_schema <- function(
 
   db_col_types <- match.arg(.db_col_types)
 
-  x <- list(...)
+  x <- rlang::list2(...)
 
   # Transform SQL column types to lowercase to allow
   # both uppercase and lowercase conventions while

R/create_multiagent.R

@@ -159,7 +159,7 @@ create_multiagent <- function(
     locale = NULL
 ) {
 
-  agent_list <- list(...)
+  agent_list <- rlang::list2(...)
   if (!all(sapply(agent_list, is_ptblank_agent))) {
     rlang::abort("All components of `...` must be an agent")
   }

R/datasets.R

@@ -73,18 +73,10 @@
 small_table_sqlite <- function() {
 
   # nocov start
-
-  if (!requireNamespace("DBI", quietly = TRUE) &&
-      !requireNamespace("RSQLite", quietly = TRUE)) {
-
-    stop(
-      "Creating the SQLite table object requires both the DBI and RSQLite ",
-      "packages:\n",
-      "* Install them with `install.packages(\"DBI\")` and ",
-      "`install.packages(\"RSQLite\")`.",
-      call. = FALSE
-    )
-  }
+  rlang::check_installed(
+    c("DBI", "RSQLite"),
+    "to create an SQLite table object."
+  )
 
   con <- 
     DBI::dbConnect(

R/get_sundered_data.R

@@ -268,6 +268,14 @@ get_sundered_data <- function(
     )
   }
 
+  # Stop function if `tbl_checked` is not present
+  if (!"tbl_checked" %in% colnames(agent$validation_set)) {
+    stop(
+      "`agent` is missing `tbl_checked` information required for sundering. ",
+      "See `?interrogate`."
+    )
+  }
+
   # Get the row count of the input table
   row_count_input_tbl <- 
     input_tbl %>%

R/info_add.R

@@ -193,7 +193,7 @@ info_tabular <- function(
     ...
 ) {
 
-  metadata_items <- list(...)
+  metadata_items <- rlang::list2(...)
 
   metadata <- x
 
@@ -442,7 +442,7 @@ info_columns <- function(
   # Capture the `columns` expression
   columns <- rlang::enquo(columns)
 
-  metadata_items <- list(...)
+  metadata_items <- rlang::list2(...)
 
   metadata <- x
 
@@ -892,7 +892,7 @@ info_section <- function(
     ...
 ) {
 
-  metadata_items <- list(...)
+  metadata_items <- rlang::list2(...)
 
   metadata <- x
 
@@ -1231,6 +1231,12 @@ info_snippet <- function(
 #'   derived from `character` or `factor` values; numbers, dates, and logical
 #'   values won't have quotation marks. We can explicitly use quotations (or
 #'   not) with either `TRUE` or `FALSE` here.
+#'   
+#' @param na_rm *Remove NA values from list*
+#' 
+#'   `scalar<logical>` // *default:* `FALSE`
+#' 
+#'   An option for whether NA values should be counted as an item in the list.
 #' 
 #' @param lang *Reporting language*
 #' 
@@ -1301,6 +1307,7 @@ snip_list <- function(
     oxford = TRUE,
     as_code = TRUE,
     quot_str = NULL,
+    na_rm = FALSE,
     lang = NULL
 ) {
 
@@ -1365,9 +1372,9 @@ snip_list <- function(
       stats::as.formula(
         as.character(
           glue::glue(
-            "~ . %>% dplyr::select(<<column>>) %>%",
+            "~ . %>% dplyr::select(`<<column>>`) %>%",
             "dplyr::distinct() %>%",
-            "dplyr::pull(<<column>>) %>%",
+            "dplyr::pull(`<<column>>`) %>%",
             ifelse(reverse, "rev() %>%", ""),
             "pb_str_catalog(
             limit = <<limit[1]>>,
@@ -1376,6 +1383,7 @@ snip_list <- function(
             oxford = <<oxford>>,
             as_code = <<as_code>>,
             quot_str = <<quot_str>>,
+            na_rm = <<na_rm>>,
             lang = <<lang>>
           )",
           .open = "<<", .close = ">>"   
@@ -1389,23 +1397,24 @@ snip_list <- function(
       stats::as.formula(
         as.character(
           glue::glue(
-            "~ . %>% dplyr::select(<<column>>) %>%",
-            "dplyr::group_by(<<column>>) %>%",
+            "~ . %>% dplyr::select(`<<column>>`) %>%",
+            "dplyr::group_by(`<<column>>`) %>%",
             "dplyr::summarize(`_count_` = dplyr::n(), .groups = 'keep') %>%",
             ifelse(
               reverse,
               "dplyr::arrange(`_count_`) %>%",
               "dplyr::arrange(dplyr::desc(`_count_`)) %>%"
             ),
-            "dplyr::select(<<column>>) %>%",
-            "dplyr::pull(<<column>>) %>%",
+            "dplyr::select(`<<column>>`) %>%",
+            "dplyr::pull(`<<column>>`) %>%",
             "pb_str_catalog(
             limit = <<limit[1]>>,
             sep = <<sep>>,
             and_or = <<and_or>>,
             oxford = <<oxford>>,
             as_code = <<as_code>>,
             quot_str = <<quot_str>>,
+            na_rm = <<na_rm>>,
             lang = <<lang>>
           )",
           .open = "<<", .close = ">>"   
@@ -1420,9 +1429,9 @@ snip_list <- function(
       stats::as.formula(
         as.character(
           glue::glue(
-            "~ . %>% dplyr::select(<<column>>) %>%",
+            "~ . %>% dplyr::select(`<<column>>`) %>%",
             "dplyr::distinct() %>%",
-            "dplyr::pull(<<column>>) %>%",
+            "dplyr::pull(`<<column>>`) %>%",
             ifelse(
               reverse,
               "sort(decreasing = TRUE) %>%",
@@ -1435,6 +1444,7 @@ snip_list <- function(
             oxford = <<oxford>>,
             as_code = <<as_code>>,
             quot_str = <<quot_str>>,
+            na_rm = <<na_rm>>,
             lang = <<lang>>
           )",
           .open = "<<", .close = ">>"   
@@ -1533,7 +1543,7 @@ snip_stats <- function(
     as.character(
       glue::glue(
         "~ . %>%
-    dplyr::select(<<column>>) %>%
+    dplyr::select(`<<column>>`) %>%
     pb_str_summary(type = '<<type>>')",
     .open = "<<", .close = ">>"
       )
@@ -1607,8 +1617,8 @@ snip_lowest <- function(column) {
     as.character(
       glue::glue(
         "~ . %>%
-    dplyr::select(<<column>>) %>% dplyr::distinct() %>%
-    dplyr::summarize(`pb_summary` = min(<<column>>, na.rm = TRUE)) %>%
+    dplyr::select(`<<column>>`) %>% dplyr::distinct() %>%
+    dplyr::summarize(`pb_summary` = min(`<<column>>`, na.rm = TRUE)) %>%
     dplyr::pull(`pb_summary`) %>% as.character()",
     .open = "<<", .close = ">>"
       )
@@ -1681,8 +1691,8 @@ snip_highest <- function(column) {
     as.character(
       glue::glue(
         "~ . %>%
-    dplyr::select(<<column>>) %>% dplyr::distinct() %>%
-    dplyr::summarize(`pb_summary` = max(<<column>>, na.rm = TRUE)) %>%
+    dplyr::select(`<<column>>`) %>% dplyr::distinct() %>%
+    dplyr::summarize(`pb_summary` = max(`<<column>>`, na.rm = TRUE)) %>%
     dplyr::pull(`pb_summary`) %>% as.character()",
     .open = "<<", .close = ">>"
       )

R/interrogate.R

@@ -44,6 +44,15 @@
 #'   The default is `TRUE` and further options allow for fine control of how
 #'   these rows are collected.
 #'   
+#' @param extract_tbl_checked *Collect validation results from each step*
+#' 
+#'   `scalar<logical>` // *default:* `TRUE`
+#' 
+#'   An option to collect processed data frames produced by executing the
+#'   validation steps. This information is necessary for some functions
+#'   (e.g., `get_sundered_data()`), but may grow to a large size. To opt out
+#'   of attaching this data to the agent, set this argument to `FALSE`.
+#'   
 #' @param get_first_n *Get the first n values*
 #' 
 #'   `scalar<integer>` // *default:* `NULL` (`optional`)
@@ -143,6 +152,7 @@
 interrogate <- function(
     agent,
     extract_failed = TRUE,
+    extract_tbl_checked = TRUE,
     get_first_n = NULL,
     sample_n = NULL,
     sample_frac = NULL,
@@ -729,6 +739,11 @@ interrogate <- function(
   # all validation steps have been carried out
   class(agent) <- c("has_intel", "ptblank_agent")
 
+  # Drop $tbl_checked if `extract_tbl_checked = FALSE`
+  if (!extract_tbl_checked) {
+    agent$validation_set$tbl_checked <- NULL
+  }
+
   # Add the ending time to the `agent` object
   agent$time_end <- Sys.time()
 

R/logging.R

@@ -184,14 +184,7 @@ log4r_step <- function(
     append_to = "pb_log_file"
 ) {
 
-  if (!requireNamespace("log4r", quietly = TRUE)) {
-
-    stop(
-      "Using the `log4r_step()` function requires the log4r package:\n",
-      "* It can be installed with `install.packages(\"log4r\")`.",
-      call. = FALSE
-    )
-  }
+  rlang::check_installed("log4r", "to use the `log4r_step()` function.")
 
   type <- x$this_type
   warn_val <- x$warn

R/scan_data.R

@@ -221,26 +221,10 @@ scan_data <- function(
   }
 
   if (any(c("interactions", "correlations") %in% sections)) {
-
-    if (!requireNamespace("ggplot2", quietly = TRUE)) {
-
-      stop(
-        "The `interactions` and `correlations` sections require ", 
-        "the ggplot2 package:\n",
-        "* It can be installed with `install.packages(\"ggplot2\")`.",
-        call. = FALSE
-      )
-    }
-
-    if (!requireNamespace("ggforce", quietly = TRUE)) {
-
-      stop(
-        "The `interactions` and `correlations` sections require ", 
-        "the ggforce package:\n",
-        "* It can be installed with `install.packages(\"ggforce\")`.",
-        call. = FALSE
-      )
-    }
+    rlang::check_installed(
+      c("ggforce", "ggplot2"),
+      "to use the `interactions` and `correlations` sections."
+    )
   }
 
   # Normalize the reporting language identifier and stop if necessary

R/steps_and_briefs.R

@@ -187,9 +187,10 @@ apply_segments_to_tbl <- function(agent, idx, tbl) {
   }
 
   # Generate a second set of 'preconditions' to filter the table
+  seg_val <- gsub("'", "\\\\'", seg_val)
   preconditions <- 
     stats::as.formula(
-      glue::glue("~ . %>% dplyr::filter({seg_col} == '{seg_val}')")
+      glue::glue("~ . %>% dplyr::filter(`{seg_col}` == '{seg_val}')")
     )
 
   tbl <- apply_preconditions(tbl = tbl, preconditions = preconditions)

R/table_transformers.R

@@ -546,18 +546,7 @@ tt_time_shift <- function(
     time_shift = "0y 0m 0d 0H 0M 0S"
 ) {
 
-  # nocov start
-
-  if (!requireNamespace("lubridate", quietly = TRUE)) {
-
-    stop(
-      "The `tt_time_shift()` function requires the lubridate package:\n",
-      "* It can be installed with `install.packages(\"lubridate\")`.",
-      call. = FALSE
-    )
-  }
-
-  # nocov end
+  rlang::check_installed("lubridate", "to use the `tt_time_shift()` function.")
 
   # Determine whether the `tbl` object is acceptable here
   check_is_a_table_object(tbl = tbl)
@@ -760,18 +749,7 @@ tt_time_slice <- function(
     arrange = FALSE
 ) {
 
-  # nocov start
-
-  if (!requireNamespace("lubridate", quietly = TRUE)) {
-
-    stop(
-      "The `tt_time_shift()` function requires the lubridate package:\n",
-      "* It can be installed with `install.packages(\"lubridate\")`.",
-      call. = FALSE
-    )
-  }
-
-  # nocov end
+  rlang::check_installed("lubridate", "to use the `tt_time_slice()` function.")
 
   keep <- match.arg(keep)