updated utils-sfmsc to latest version

Author: s-fleck

.Rbuildignore

@@ -8,4 +8,4 @@
 ^cran-comments\.md$
 ^docs$
 .*rsconnect.*
-revdep
+^revdep$

R/utils-sfmisc.R

@@ -1,4 +1,4 @@
-# sfmisc utils 0.0.1.9003
+# sfmisc utils 0.0.1.9010
 
 
 
@@ -25,15 +25,64 @@ walk <- function(.x, .f, ...){
 
 # assertions --------------------------------------------------------------
 
+#' Assert a condition
+#'
+#' A simpler and more efficient for [base::stopifnot()] that has an easy
+#' mechanism for supplying custom error messages. As opposed to `stopifnot()`,
+#' `assert()` only works with a single (scalar) assertions.
+#'
+#' @param cond `TRUE` or `FALSE` (without any attributes). `FALSE` will throw
+#'   an exception with an automatically constructed error message (if `...`
+#'   was not supplied). Anything else will throw an exception stating that
+#'   `cond` was not valid.
+#' @param ... passed on to [stop()]
+#' @param call. passed on to [stop()]
+#' @param domain passed on to [stop()]
+#'
+#' @noRd
+#'
+#' @return TRUE on success
+#'
+#' @examples
+#'
+#' \dontrun{
+#' assert(1 == 1)
+#' assert(1 == 2)
+#' }
+#'
+#'
+assert <- function(
+  cond,
+  ...,
+  call. = FALSE,
+  domain = NULL
+){
+  if (identical(cond, TRUE)){
+    return(TRUE)
+  } else if (identical(cond, FALSE)){
+    if (identical(length(list(...)), 0L)){
+      msg <- paste0("`", deparse(match.call()[[2]]), "`", " is not 'TRUE'")
+      stop(msg, call. = call., domain = domain)
+    } else {
+      suppressWarnings( stop(..., call. = call., domain = domain) )
+    }
+
+  } else {
+    stop("Assertion must be either 'TRUE' or 'FALSE'")
+  }
+}
+
+
+
+
 assert_namespace <- function(x){
-  stopifnot(requireNamespace(x, quietly = TRUE))
+  assert(requireNamespace(x, quietly = TRUE))
   invisible(TRUE)
 }
 
 
 
 
-
 # conditions --------------------------------------------------------------
 
 #' Condition constructor
@@ -88,15 +137,23 @@ condition <- function(subclass, message, call = sys.call(-1), ...) {
 
 
 
-#' @rdname condition
 error <- function(subclass, message, call = sys.call(-1), ...) {
   structure(
     class = c(subclass, "error", "condition"),
     list(message = message, call = call, ...)
   )
 }
 
+
+
+
 # predicates --------------------------------------------------------------
+is_scalar <- function(x){
+  identical(length(x), 1L)
+}
+
+
+
 
 is_scalar_character <- function(x){
   is.character(x) && is_scalar(x)
@@ -119,18 +176,25 @@ is_scalar_integerish <- function(x){
 
 
 
-is_scalar <- function(x){
-  identical(length(x), 1L)
+is_tf <- function(x){
+  is.logical(x) && !anyNA(x)
+}
+
+
+
+
+is_scalar_tf <- function(x){
+  identical(x, TRUE) || identical(x, FALSE)
 }
 
 
 
 
 is_integerish <- function(x){
   if (!is.numeric(x)){
-    vector("logical", length(x))
+    FALSE
   } else {
-    as.integer(x) == x
+    all(as.integer(x) == x)
   }
 }
 
@@ -158,6 +222,7 @@ is_blank <- function(x){
 
 
 
+
 # all_are -----------------------------------------------------------------
 
 
@@ -178,7 +243,7 @@ is_blank <- function(x){
 #' all_are_identical(c(1,1,1))
 #'
 all_are_identical <- function(x, empty_value = FALSE) {
-  assert_that(length(empty_value) <= 1)
+  assert(length(empty_value) <= 1)
 
   if (length(x) > 0L) {
     return(identical(length(unique(x)), 1L))
@@ -216,7 +281,7 @@ all_are_distinct <- function(
   x,
   empty_value = FALSE
 ){
-  assert_that(length(empty_value) <= 1)
+  assert(length(empty_value) <= 1)
 
   if (identical(length(x), 1L)) {
     return(TRUE)
@@ -235,4 +300,3 @@ all_are_distinct <- function(
     return(empty_value)
   }
 }
-