Improve compatibility with dplyr API

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: incase
 Title: Pipe-Friendly Vector Replacement with Case Statements
-Version: 0.3.1.9000
+Version: 0.3.1.9001
 Authors@R: c(
     person("Alexander", "Rossell Hayes", , "alexander@rossellhayes.com", role = c("aut", "cre", "cph"),
            comment = c(ORCID = "0000-0001-9412-0457")),

NEWS.md

@@ -1,6 +1,9 @@
 # incase (development version)
 
-* No longer rely on deprecated `plu` functions.
+* Accept named arguments with or without preceding dots, e.g. `default` or `.default` (#5).
+* Take `default` into account when determining the class of output (#5).
+* Improve error messages (#5).
+* No longer rely on deprecated `plu` functions (#4).
 
 # incase 0.3.1
 

R/fn_case.R

@@ -44,7 +44,8 @@
 #' @example examples/fn_case.R
 
 fn_case <- function(x, fn, ..., preserve = FALSE, default = NA) {
-  inputs <- fn_case_setup(...)
+  dots <- allow_dot_aliases(compact_list(...))
+  inputs <- fn_case_setup(dots)
 
   replace(
     inputs$fs, x, default, preserve, fn, inputs$args,
@@ -53,10 +54,9 @@ fn_case <- function(x, fn, ..., preserve = FALSE, default = NA) {
   )
 }
 
-fn_case_setup <- function(...) {
-  input <- compact_list(...)
-  fs    <- Filter(rlang::is_formula, input)
-  args  <- input[!input %in% fs]
+fn_case_setup <- function(dots) {
+  fs    <- Filter(rlang::is_formula, dots)
+  args  <- dots[!dots %in% fs]
 
   list(fs = fs, args = args)
 }

R/in_case.R

@@ -52,7 +52,8 @@
 #' @example examples/in_case.R
 
 in_case <- function(..., preserve = FALSE, default = NA) {
-  inputs <- in_case_setup(..., preserve = preserve, fn = "in_case")
+  dots <- allow_dot_aliases(compact_list(...))
+  inputs <- in_case_setup(dots, preserve = preserve, fn = "in_case")
 
   replace(
     fs          = inputs$fs,
@@ -64,14 +65,16 @@ in_case <- function(..., preserve = FALSE, default = NA) {
   )
 }
 
-in_case_setup <- function(..., preserve, fn) {
-  ellipsis <- compact_list(...)
+in_case_setup <- function(dots, preserve, fn) {
+  if (length(dots) == 0) {
+    return(list(fs = list(), x = vector()))
+  }
 
-  if (!rlang::is_formula(ellipsis[[1]])) {
-    fs <- ellipsis[-1]
-    x  <- ellipsis[[1]]
+  if (!rlang::is_formula(dots[[1]])) {
+    fs <- dots[-1]
+    x  <- dots[[1]]
   } else {
-    fs <- ellipsis
+    fs <- dots
     x  <- NULL
     assert_no_preserve_without_pipe(preserve, fn)
   }

R/in_case_fct.R

@@ -23,7 +23,8 @@
 #' @example examples/in_case_fct.R
 
 in_case_fct <- function(..., preserve = FALSE, default = NA, ordered = FALSE) {
-  inputs <- in_case_setup(..., preserve = preserve, fn = "in_case_fct()")
+  dots <- allow_dot_aliases(compact_list(...))
+  inputs <- in_case_setup(dots, preserve = preserve, fn = "in_case_fct()")
 
   replace(
     fs          = inputs$fs,
@@ -75,7 +76,8 @@ grep_case_fct <- function(
 fn_case_fct <- function(
   x, fn, ..., preserve = FALSE, default = NA, ordered = FALSE
 ) {
-  inputs <- fn_case_setup(...)
+  dots <- allow_dot_aliases(compact_list(...))
+  inputs <- fn_case_setup(dots)
 
   replace(
     inputs$fs, x, default, preserve, fn, inputs$args,

R/in_case_list.R

@@ -20,7 +20,8 @@
 #' @example examples/in_case_list.R
 
 in_case_list <- function(..., preserve = FALSE, default = NA) {
-  inputs <- in_case_setup(..., preserve = preserve, fn = "in_case_list()")
+  dots <- allow_dot_aliases(compact_list(...))
+  inputs <- in_case_setup(dots, preserve = preserve, fn = "in_case_list()")
 
   replace(
     inputs$fs, inputs$x, default, preserve,
@@ -60,7 +61,8 @@ grep_case_list <- function(x, ..., preserve = FALSE, default = NA) {
 #' @export
 
 fn_case_list <- function(x, fn, ..., preserve = FALSE, default = NA) {
-  inputs <- fn_case_setup(...)
+  dots <- allow_dot_aliases(compact_list(...))
+  inputs <- fn_case_setup(dots)
 
   replace(
     inputs$fs, x, default, preserve, fn, inputs$args, list = TRUE,

R/replace.R

@@ -6,7 +6,7 @@ replace <- function(
   factor = FALSE, ordered = FALSE, list = FALSE,
   default_env, current_env
 ) {
-  assert_length(fs)
+  assert_length(fs, call = current_env)
 
   pairs <- extract_formula_pairs(
     fs, x, default, fn, args, default_env, current_env, list = list
@@ -18,32 +18,37 @@ replace <- function(
     warn_if_default(default)
 
     if (list) {
-      pairs$query[[length(pairs$value) + 1]] <- rep(TRUE, length(x))
-      pairs$value[[length(pairs$value) + 1]] <- as.list(x)
+      pairs$query <- append(pairs$query, list(rep(TRUE, length(x))))
+      pairs$value <- append(pairs$value, list(as.list(x)))
     } else {
-      pairs$query[[length(pairs$query) + 1]] <- TRUE
-      pairs$value[[length(pairs$value) + 1]] <- x
+      pairs$query <- append(pairs$query, list(TRUE))
+      pairs$value <- append(pairs$value, list(x))
     }
   }
 
   n <- validate_case_length(pairs$query, pairs$value, fs)
 
-  if (n == 0) {return(NULL)}
+  if (identical(n, 0L) || length(n) == 0) {
+    return(default[0])
+  }
 
-  if (list) {default <- list(default)}
+  if (list) {
+    default <- list(default)
+  }
 
   out      <- rep_len(default, n)
   replaced <- rep(FALSE, n)
 
   if (!list) {
-    class       <- class(c(pairs$value, recursive = TRUE))
+    class       <- class(c(pairs$value, default, recursive = TRUE))
     pairs$value <- lapply(pairs$value, `class<-`, class)
     class(out)  <- class
   }
 
   for (i in seq_along(pairs$query)) {
     out <- replace_with(out, pairs$query[[i]] & !replaced, pairs$value[[i]])
     replaced <- replaced | (pairs$query[[i]] & !is.na(pairs$query[[i]]))
+    if (all(replaced)) break
   }
 
   if (factor) {

R/staticimports.R

@@ -0,0 +1,77 @@
+# Generated by staticimports; do not edit by hand.
+# ======================================================================
+# Imported from pkg:stringstatic
+# ======================================================================
+
+#' Remove matched patterns in a string
+#'
+#' Dependency-free drop-in alternative for `stringr::str_remove()`.
+#'
+#' @source Adapted from the [stringr](https://stringr.tidyverse.org/) package.
+#'
+#' @param string Input vector.
+#'   Either a character vector, or something coercible to one.
+#'
+#' @param pattern Pattern to look for.
+#'
+#'   The default interpretation is a regular expression,
+#'   as described in [base::regex].
+#'   Control options with [regex()].
+#'
+#'   Match a fixed string (i.e. by comparing only bytes), using [fixed()].
+#'   This is fast, but approximate.
+#'
+#' @return A character vector.
+#' @noRd
+str_remove <- function(string, pattern) {
+	if (length(string) == 0 || length(pattern) == 0) return(character(0))
+	is_fixed <- inherits(pattern, "stringr_fixed")
+	Vectorize(sub, c("pattern", "x"), USE.NAMES = FALSE)(
+		pattern, replacement = "", x = string, perl = !is_fixed, fixed = is_fixed
+	)
+}
+
+#' Keep strings matching a pattern
+#'
+#' Dependency-free drop-in alternative for `stringr::str_subset()`.
+#'
+#' @source Adapted from the [stringr](https://stringr.tidyverse.org/) package.
+#'
+#' @param string Input vector.
+#'   Either a character vector, or something coercible to one.
+#'
+#' @param pattern Pattern to look for.
+#'
+#'   The default interpretation is a regular expression,
+#'   as described in [base::regex].
+#'   Control options with [regex()].
+#'
+#'   Match a fixed string (i.e. by comparing only bytes), using [fixed()].
+#'   This is fast, but approximate.
+#'
+#' @param negate If `TRUE`, return non-matching elements.
+#'
+#' @return A character vector.
+#' @noRd
+str_subset <- function(string, pattern, negate = FALSE) {
+	if (length(string) == 0 || length(pattern) == 0) return(character(0))
+
+	ignore.case <- isTRUE(attr(pattern, "options")$case_insensitive)
+	is_fixed <- !ignore.case && inherits(pattern, "stringr_fixed")
+
+	result <- Map(
+		function(string, pattern) {
+			grep(
+				pattern,
+				x = string,
+				ignore.case = ignore.case,
+				perl = !is_fixed,
+				fixed = is_fixed,
+				invert = negate
+			)
+		},
+		string, pattern, USE.NAMES = FALSE
+	)
+
+	string[which(lengths(result) > 0)]
+}

R/switch_case.R

@@ -78,7 +78,7 @@ fn_switch_case_setup <- function(..., fn, default_env, current_env) {
   fs    <- Filter(rlang::is_formula, input)
   args  <- input[!input %in% fs]
 
-  assert_length(fs)
+  assert_length(fs, call = current_env)
 
   pairs <- extract_formula_pairs(
     fs,

R/utils.R

@@ -0,0 +1,36 @@
+assert_length <- function(fs, call = rlang::caller_env()) {
+  if (!length(fs)) cli::cli_abort("No cases provided", call = call)
+}
+
+compact_list <- function(...) {
+  Filter(function(x) !is.null(x), rlang::list2(...))
+}
+
+# @staticimports pkg:stringstatic
+#  str_remove str_subset
+
+allow_dot_aliases <- function(
+    dots,
+    call = rlang::caller_call(),
+    env = rlang::caller_env()
+) {
+  call_formals <- formals(rlang::call_name(call))
+
+  dot_args <- str_subset(names(dots), "^\\.")
+
+  if (length(dot_args) == 0) {
+    return(dots)
+  }
+
+  undot_args <- str_remove(dot_args, "^\\.")
+
+  for (i in sort(match(names(call_formals), undot_args), decreasing = TRUE)) {
+    if (exists(undot_args[[i]], envir = env, mode = "language")) {
+      dots <- append(dots, get(undot_args[[i]], envir = env), after = 0)
+    }
+    assign(undot_args[[i]], dots[[dot_args[[i]]]], envir = env)
+    dots[dot_args[[i]]] <- NULL
+  }
+
+  dots
+}

R/validate_case_length.R

@@ -3,45 +3,57 @@ validate_case_length <- function(query, value, fs) {
   rhs_lengths <- lengths(value)
   all_lengths <- unique(c(lhs_lengths, rhs_lengths))
 
-  if (length(all_lengths) == 0) {
-    return(0)
-  } else if (length(all_lengths) == 1) {
-    return(all_lengths[[1]])
+  if (length(all_lengths) <= 1) {
+    return(all_lengths)
   }
 
   non_atomic_lengths <- all_lengths[all_lengths != 1]
-  len                <- non_atomic_lengths[[1]]
 
-  if (length(non_atomic_lengths) == 1) {return(len)}
+  if (length(unique(non_atomic_lengths)) == 1) {
+    return(non_atomic_lengths[[1]])
+  }
+
+  modal_length <- modes(non_atomic_lengths)[[1]]
 
-  inconsistent_lengths <- non_atomic_lengths[non_atomic_lengths != len]
+  inconsistent_lhs_lengths <- setdiff(lhs_lengths, c(modal_length, 1))
+  lhs_problems <- lhs_lengths %in% inconsistent_lhs_lengths
 
-  lhs_problems         <- lhs_lengths %in% inconsistent_lengths
-  rhs_problems         <- rhs_lengths %in% inconsistent_lengths
-  problems             <- lhs_problems | rhs_problems
+  inconsistent_rhs_lengths <- setdiff(rhs_lengths, c(modal_length, 1))
+  rhs_problems <- rhs_lengths %in% inconsistent_rhs_lengths
 
   cli::cli_abort(c(
-    "All formulas' right-hand sides must be the same length ({.val {len}}),
-     or {.val {1}}.",
-    check_length_val(
-      vapply(fs[problems], rlang::as_label, character(1)),
-      inconsistent_lengths,
-      len
-    )
+    "The left- and right-hand sides of all formulas must be the same length
+    ({.val {modal_length}}) or length {.val {1}}.",
+    if (any(lhs_problems)) {
+      check_length_val(
+        vapply(fs[lhs_problems], rlang::expr_text, character(1)),
+        inconsistent_lhs_lengths,
+        "left"
+      )
+    },
+    if (any(rhs_problems)) {
+      check_length_val(
+        vapply(fs[rhs_problems], rlang::expr_text, character(1)),
+        inconsistent_rhs_lengths,
+        "right"
+      )
+    }
   ))
 }
 
-check_length_val <- function(formulas, length_x, n) {
-  n <- if (n > 1) {
-    sprintf("{.or {.val {c(1, %d)}}}", n)
-  } else {
-    "{.val {1}}"
-  }
+modes <- function(x) {
+  counts <- table(x)
+  counts <- counts[match(names(counts), unique(x))]
+  modes <- names(counts[counts == max(counts)])
+  mode(modes) <- mode(x)
+  modes
+}
 
+check_length_val <- function(formulas, length_x, side) {
   out <- sprintf(
-    "{.code %s} should be length %s, not {.val {%d}}.",
+    "The %s-hand side of {.code %s} is length {.val {%d}}.",
+    side,
     formulas,
-    n,
     length_x
   )
   names(out) <- rep("x", length(out))