address #6: allow custom messages

.Rbuildignore

@@ -1,3 +1,4 @@
 ^.*\.Rproj$
 ^\.Rproj\.user$
 ^LICENSE\.md$
+.lintr

DESCRIPTION

@@ -22,7 +22,8 @@ Suggests:
     testthat (>= 3.0.0),
     roxygen2,
     usethis,
-    devtools
+    devtools,
+    cli
 Config/testthat/edition: 3
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3

R/checkDT.R

@@ -29,49 +29,42 @@
 #' @export
 checkDT <- function(
   data,
-  require = NULL, forbid = NULL
+  require = NULL, forbid = NULL,
+  rqr_message = "`require`d are missing or not compliant in `data`: %s",
+  fbd_message = "`forbid`den columns are present in `data`: %s"
 ) {
-  if (!is.data.table(data)) stop(
+  if (!is.data.table(data)) internal_error(
     "`data` must be a data.table; perhaps `coerceDT()` first?"
   )
   if (!is.null(require)) {
     require <- check_required(require)
     if (is.character(require)) {
-      if (!all(require %in% names(data))) {
-        stop("`data` does not contain `require` columns.")
-      }
+      report_error(setdiff(require, names(data)), rqr_message)
     } else if (is.list(require)) {
       cols <- names(require)
-      if (!all(cols %in% names(data))) {
-        stop("`data` does not contain `require` columns.")
-      }
-      failed <- data[,
+      report_error(setdiff(cols, names(data)), rqr_message)
+      report_error(data[,
          cols[!mapply(
            function(f, col) all(f(.SD[[col]])),
            f = require, col = cols, SIMPLIFY = TRUE
          )],
          .SDcols = cols
-      ]
-      if (length(failed) != 0L) {
-        stop("`require` some column did not pass.")
-      }
+      ], rqr_message)
     }
   }
   if (!is.null(forbid)) {
-    if (!is.character(forbid)) stop("`forbid` must be a `character`")
-    if (any(forbid %in% names(data))) {
-      stop("`data` contains `forbid` columns.")
-    }
+    if (!is.character(forbid)) internal_error("`forbid` must be a `character`")
+    report_error(intersect(forbid, names(data)), fbd_message)
   }
   data
 }
 
-check_required <- function(require) {
+check_required <- function(require, call = parent.frame()) {
   if (!(is.character(require) || is.list(require))) {
-    stop("`require` is not a `character` or named `list`")
+    internal_error("`require` is not a `character` or named `list`", call = call)
   } else if (is.list(require)) {
     if (is.null(names(require)) || any(names(require) == "")) {
-      stop("If a `list`, `require` must have `all(names(require) != '')`.")
+      internal_error("If a `list`, `require` must have `all(names(require) != '')`.", call = call)
     }
     require <- lapply(require, function(arg) {
       if (is.null(arg)) {
@@ -81,11 +74,12 @@ check_required <- function(require) {
       } else if (is.function(arg)) {
         arg
       } else {
-        stop(
+        internal_error(
           "If a `list`, `require` must specify checks, either",
           "as NULL (no check other than presence),",
           "a string (is.TYPE check),",
-          "or a function (f(x) check)"
+          "or a function (f(x) check)",
+          call = call
         )
       }
     })

R/coerceDT.R

@@ -49,11 +49,12 @@ coerceDT <- function(
   data,
   select, drop,
   default,
-  copy = TRUE
+  copy = TRUE,
+  sel_message = "`select`ed are missing or not compliant in `data`: %s"
 ) {
 
   if (!missing(select) && !missing(drop)) {
-    stop("Use either select= or drop= but not both")
+    internal_error("Use either select= or drop= but not both")
   }
 
   doargs <- list()
@@ -69,7 +70,7 @@ coerceDT <- function(
   if (is.character(data)) {
     if (grepl(pattern = "\\.rds$", x = data, ignore.case = TRUE)) {
       doargs$data <- setDT(readRDS(
-        tryCatch(normalizePath(data), warning = function(e) stop(e))
+        tryCatch(normalizePath(data), warning = internal_error)
       ))
       do.call(internal_select_drop_convert, doargs)
     } else {
@@ -78,11 +79,13 @@ coerceDT <- function(
         selcoerce <- doargs$select
         doargs$select <- names(select)
         coerce_select(
-          do.call(data.table::fread, doargs), selcoerce, doargs$select
+          # TODO
+          tryCatch(do.call(data.table::fread, doargs), warning = stop),
+          selcoerce, doargs$select
         )
       } else {
         if (is.null(doargs$default)) {
-          do.call(data.table::fread, doargs)
+          tryCatch(do.call(data.table::fread, doargs), warning = stop)
         } else {
           default <- doargs$default
           doargs$select <- names(default)
@@ -102,16 +105,18 @@ coerceDT <- function(
 
 #' Regularize `select` argument
 #'
+#' @param call the calling environment, used in error messages
+#'
 #' @inheritParams coerceDT
 #'
 #' @return a checked `select` value; if `select` is a list, will have converted
 #' all the elements to function calls.
-check_select <- function(select) {
+check_select <- function(select, call = parent.frame()) {
   if (!(is.character(select) || is.integer(select) || is.list(select))) {
-    stop("`select` is not a `character`, `integer`, or `list`")
+    internal_error("`select` is not a `character`, `integer`, or `list`", call = call)
   } else if (is.list(select)) {
     if (any(names(select) == "")) {
-      stop("If a `list`, `select` must have `all(names(select) != '')`.")
+      internal_error("If a `list`, `select` must have `all(names(select) != '')`.", call = call)
     }
     select <- lapply(select, function(arg) {
       if (is.null(arg)) {
@@ -121,11 +126,12 @@ check_select <- function(select) {
       } else if (is.function(arg)) {
         arg
       } else {
-        stop(
+        internal_error(
           "If a `list`, `select` must specify conversions, either",
           "as NULL (no conversion),",
           "a string (as.TYPE conversion),",
-          "or a function (f(x) conversion)"
+          "or a function (f(x) conversion)",
+          call = call
         )
       }
     })
@@ -135,13 +141,15 @@ check_select <- function(select) {
 
 #' Regularize `default` argument
 #'
+#' @param call the calling environment, used in error messages
+#'
 #' @inheritParams coerceDT
 #'
 #' @return a checked `default` list.
-check_default <- function(default) {
+check_default <- function(default, call = parent.frame()) {
   default <- as.list(default)
   if (any(names(default) == "")) {
-    stop("`default` must have `all(names(default) != '')`.")
+    internal_error("`default` must have `all(names(default) != '')`.", call = call)
   }
   return(default)
 }
@@ -170,6 +178,8 @@ coerce_default <- function(data, default) {
 #'
 #' @param data a `data.table`
 #'
+#' @param call the calling environment, used in error messages
+#'
 #' @inheritParams coerceDT
 #'
 #' @details
@@ -179,7 +189,9 @@ coerce_default <- function(data, default) {
 #' @importFrom data.table setcolorder
 internal_select_drop_convert <- function(
   data,
-  select, drop, default
+  select, drop, default,
+  sel_message,
+  call = parent.frame()
 ) {
 
   # first, consider default columns:
@@ -211,19 +223,15 @@ internal_select_drop_convert <- function(
     } else {
       selnames <- names(select)
     }
+    report_error(setdiff(selnames, names(data)), sel_message, call = call)
+    setcolorder(data, selnames)
+    if (is.list(select)) {
+      coerce_select(data, select, selnames)
+    }
     if (missing(drop)) {
       # null everything that isn't in select
       drop <- setdiff(names(data), selnames)
     }
-    selord <- intersect(selnames, names(data))
-    # warn for non-present items
-    if (length(select) != length(selord)) {
-      warning("Some cols not present")
-    }
-    setcolorder(data, selord)
-    if (is.list(select)) {
-      coerce_select(data, select, selnames)
-    }
   }
 
   if (!missing(drop) && length(drop) > 0L) {

R/makeDT.R

@@ -22,13 +22,20 @@ makeDT <- function(
   data,
   select, drop,
   require, forbid,
-  copy = TRUE
+  copy = TRUE,
+  sel_message = "`select`ed are missing or not compliant in `data`: %s",
+  rqr_message = "`require`d are missing or not compliant in `data`: %s",
+  fbd_message = "`forbid`den columns are present in `data`: %s"
 ) {
   doargs_coerce <- list(data = data, copy = copy)
   if (!missing(select)) doargs_coerce$select <- select
   if (!missing(drop)) doargs_coerce$drop <- drop
+  if (!missing(sel_message)) doargs_coerce$sel_message <- sel_message
+
   doargs_check <- list(data = do.call(coerceDT, doargs_coerce))
   if (!missing(require)) doargs_check$require <- require
   if (!missing(forbid)) doargs_check$forbid <- forbid
+  if (!missing(rqr_message)) doargs_check$rqr_message <- rqr_message
+  if (!missing(fbd_message)) doargs_check$fbd_message <- fbd_message
   do.call(checkDT, doargs_check)
 }

R/zzz.R

@@ -0,0 +1,38 @@
+
+# default handling
+internal_error <- function(..., call) stop(...)
+internal_warn <- function(..., call) warning(...)
+
+.onLoad <- function(libname, pkgname) {
+  if (requireNamespace("cli", quietly = TRUE)) {
+    utils::assignInMyNamespace(
+      "internal_error",
+      function(
+        ..., call = parent.frame()
+      ) {
+        cli::cli_abort(message = c(...), call = call)
+      }
+    )
+    utils::assignInMyNamespace(
+      "internal_warn",
+      function(
+        ..., call = parent.frame()
+      ) {
+        cli::cli_warn(message = c(...), call = call)
+      }
+    )
+  }
+}
+
+.onAttach <- function(libname, pkgname) {
+  if (requireNamespace("cli", quietly = TRUE)) {
+    packageStartupMessage("coerceDT: using `cli` messaging.")
+  } else {
+    packageStartupMessage(
+      paste(c(
+        "coerceDT: using `base` messaging.",
+        "To use `cli` messages, install `cli` and restart your session."
+      ), collapse = "\n\t")
+    )
+  }
+}