Implement argument checking for exported functions

NAMESPACE

@@ -22,6 +22,11 @@ importFrom(REDCapR,redcap_metadata_read)
 importFrom(REDCapR,redcap_read_oneshot)
 importFrom(checkmate,assert_character)
 importFrom(checkmate,assert_data_frame)
+importFrom(checkmate,check_character)
+importFrom(checkmate,check_choice)
+importFrom(checkmate,check_data_frame)
+importFrom(checkmate,check_environment)
+importFrom(checkmate,check_logical)
 importFrom(checkmate,expect_character)
 importFrom(checkmate,expect_double)
 importFrom(checkmate,expect_factor)
@@ -54,6 +59,7 @@ importFrom(purrr,pluck)
 importFrom(rlang,"!!!")
 importFrom(rlang,.data)
 importFrom(rlang,as_closure)
+importFrom(rlang,caller_arg)
 importFrom(rlang,caller_env)
 importFrom(rlang,check_installed)
 importFrom(rlang,current_env)

R/bind_tibbles.R

@@ -43,6 +43,10 @@
 bind_tibbles <- function(supertbl,
                          environment = global_env(),
                          tbls = NULL) {
+  check_arg_is_dataframe(supertbl)
+  check_arg_is_env(environment)
+  check_arg_is_character(tbls, null.ok = TRUE)
+
   # Name variables
   my_supertbl <- supertbl
 

R/checks.R

@@ -272,3 +272,65 @@ check_req_labelled_metadata_fields <- function(supertbl) {
     )
   }
 }
+
+
+#' @title
+#' Check an argument with checkmate
+#'
+#' @importFrom cli cli_abort
+#' @importFrom rlang caller_arg
+#'
+#' @param x An object to check
+#' @param arg The name of the argument to include in an error message. Captured
+#' by `rlang::caller_arg()` by default
+#' @param ... additional arguments passed on to checkmate
+#'
+#' @return
+#' `TRUE` if `x` passes the checkmate check. An error otherwise with the name of
+#' the checkmate function as a `class`
+#'
+#' @name checkmate
+#' @keywords internal
+NULL
+
+# Function factory to wrap checkmate functions
+#' @importFrom rlang caller_arg
+#' @importFrom cli cli_abort
+#' @noRd
+wrap_checkmate <- function(f, f_name = caller_arg(f)) {
+  function(x, ..., arg = caller_arg(x)) {
+    out <- f(x, ...)
+
+    if (isTRUE(out)) {
+      return(TRUE)
+    }
+
+    cli_abort(
+      message = c(
+        "x" = "{.arg {arg}} is invalid",
+        "!" = "{out}"
+      ),
+      class = c(f_name, "REDCapTidieR_cond")
+    )
+  }
+}
+
+#' @rdname checkmate
+#' @importFrom checkmate check_data_frame
+check_arg_is_dataframe <- wrap_checkmate(check_data_frame)
+
+#' @rdname checkmate
+#' @importFrom checkmate check_environment
+check_arg_is_env <- wrap_checkmate(check_environment)
+
+#' @rdname checkmate
+#' @importFrom checkmate check_character
+check_arg_is_character <- wrap_checkmate(check_character)
+
+#' @rdname checkmate
+#' @importFrom checkmate check_logical
+check_arg_is_logical <- wrap_checkmate(check_logical)
+
+#' @rdname checkmate
+#' @importFrom checkmate check_choice
+check_arg_choices <- wrap_checkmate(check_choice)

R/extract_tibble.R

@@ -32,12 +32,9 @@
 
 extract_tibble <- function(supertbl,
                            tbl) {
-  # Check tbl is valid ----
-  assert_character(tbl)
-
-  if (length(tbl) > 1) {
-    cli_abort("Only one table may be supplied.")
-  }
+  # Check args ----
+  check_arg_is_dataframe(supertbl)
+  check_arg_is_character(tbl, len = 1)
 
   # Extract specified table ----
   out <- extract_tibbles(supertbl, tbls = all_of(tbl))[[1]]
@@ -88,6 +85,8 @@ extract_tibble <- function(supertbl,
 
 extract_tibbles <- function(supertbl,
                             tbls = everything()) {
+  check_arg_is_dataframe(supertbl)
+
   # Extract specified table ----
   # Pass tbls as an expression for enquosure
   tbls <- enquo(tbls)

R/labelled.R

@@ -54,7 +54,7 @@ make_labelled <- function(supertbl, format_labels = NULL) {
 
   formatter <- resolve_formatter(format_labels) # nolint: object_usage_linter
 
-  assert_data_frame(supertbl)
+  check_arg_is_dataframe(supertbl)
   check_req_labelled_fields(supertbl)
   check_req_labelled_metadata_fields(supertbl)
 

R/read_redcap.R

@@ -72,6 +72,14 @@ read_redcap <- function(redcap_uri,
                         forms = NULL,
                         export_survey_fields = TRUE,
                         suppress_redcapr_messages = TRUE) {
+
+  check_arg_is_character(redcap_uri, len = 1)
+  check_arg_is_character(token, len = 1)
+  check_arg_choices(raw_or_label, choices = c("label", "raw"))
+  check_arg_is_character(forms, null.ok = TRUE)
+  check_arg_is_logical(export_survey_fields, len = 1)
+  check_arg_is_logical(suppress_redcapr_messages, len = 1)
+
   # Load REDCap Metadata ----
   db_metadata <- redcap_metadata_read(
     redcap_uri = redcap_uri,

tests/testthat/test-bind_tibbles.R

@@ -42,3 +42,9 @@ test_that("bind_tibbles works with forms specification", {
   expect_true(exists("repeated", envir = global_env()))
   rm(list = c("nonrepeated", "repeated"), envir = global_env())
 })
+
+test_that("bind_tibbles errors with bad inputs", {
+  expect_error(bind_tibbles(123), class = "check_data_frame")
+  expect_error(bind_tibbles(tibble(), environment = "abc"), class = "check_environment")
+  expect_error(bind_tibbles(tibble(), tbls = 123), class = "check_character")
+})

tests/testthat/test-checks.R

@@ -104,3 +104,27 @@ test_that("check_req_labelled_metadata_fields works", {
   check_req_labelled_metadata_fields(supertbl_no_field_label) %>%
     expect_error(class = "missing_req_labelled_metadata_fields")
 })
+
+test_that("checkmate wrappers work", {
+  # tibble or dataframe
+  expect_error(check_arg_is_dataframe(123), class = "check_data_frame")
+  expect_true(check_arg_is_dataframe(data.frame()))
+  expect_true(check_arg_is_dataframe(tibble()))
+
+  # environment
+  expect_error(check_arg_is_env(123), class = "check_environment")
+  expect_true(check_arg_is_env(new.env()))
+
+  # character
+  expect_error(check_arg_is_character(123), class = "check_character")
+  expect_true(check_arg_is_character("abc"))
+
+  # logical
+  expect_error(check_arg_is_logical(123), class = "check_logical")
+  expect_true(check_arg_is_logical(TRUE))
+
+  # choices
+  expect_error(check_arg_choices(123, choices = letters[1:3]), class = "check_choice")
+  expect_true(check_arg_choices("a", choices = letters[1:3]))
+
+})

tests/testthat/test-extract_tibble.R

@@ -43,10 +43,16 @@ test_that("extract_tibbles works with a vector and tidyselect selectors", {
   )
   expect_error(redcaptidier_longitudintal_db %>%
     extract_tibbles(tbls = c("repeated", "fake_instrument_name")))
+
+  expect_error(extract_tibbles(123), class = "check_data_frame")
+
 })
 
 test_that("extract_tibble works", {
   expect_error(extract_tibble(redcaptidier_longitudintal_db, "fake_instrument_name"))
+  expect_error(extract_tibble(123, "my_tibble"), class = "check_data_frame")
+  expect_error(extract_tibble(tibble(), tbl = 123), class = "check_character")
+  expect_error(extract_tibble(tibble(), tbl = letters[1:3]), class = "check_character")
 
   expected_out <- redcaptidier_longitudintal_db$redcap_data[[1]]
   expect_equal(

tests/testthat/test-labelled.R

@@ -286,3 +286,9 @@ test_that("make_labelled accepts all valid input types to format_labels", {
   make_labelled(supertbl, format_labels = 1) %>%
     expect_error(class = "unresolved_formatter")
 })
+
+test_that("make_labelled errors with bad inputs", {
+  # Input to format_labels is tested above
+
+  expect_error(make_labelled(123), class = "check_data_frame")
+})

tests/testthat/test-read_redcap.R

@@ -387,3 +387,48 @@ test_that("read_redcap returns expected survey fields", {
 
   checkmate::expect_class(survey_data$redcap_survey_timestamp, c("POSIXct", "POSIXt"))
 })
+
+test_that("read_redcap errors with bad inputs", {
+  # Checking for type and length constraints where relevant
+
+
+  # redcap uri
+  expect_error(read_redcap(123, classic_token), class = "check_character")
+  expect_error(read_redcap(letters[1:3], classic_token), class = "check_character")
+
+  # token
+  expect_error(read_redcap(redcap_uri, 123), class = "check_character")
+  expect_error(read_redcap(redcap_uri, letters[1:3]), class = "check_character")
+
+  # raw_or_label
+  expect_error(
+    read_redcap(redcap_uri, classic_token, raw_or_label = "bad option"),
+    class = "check_choice"
+  )
+
+  # forms
+  expect_error(
+    read_redcap(redcap_uri, classic_token, forms = 123),
+    class = "check_character"
+  )
+
+  # export_survey_fields
+  expect_error(
+    read_redcap(redcap_uri, classic_token, export_survey_fields = 123),
+    class = "check_logical"
+  )
+  expect_error(
+    read_redcap(redcap_uri, classic_token, export_survey_fields = c(TRUE, TRUE)),
+    class = "check_logical"
+  )
+
+  # suppress_redcapr_messages
+  expect_error(
+    read_redcap(redcap_uri, classic_token, suppress_redcapr_messages = 123),
+    class = "check_logical"
+  )
+  expect_error(
+    read_redcap(redcap_uri, classic_token, suppress_redcapr_messages = c(TRUE, TRUE)),
+    class = "check_logical"
+  )
+})