Rewrite every(), some(), and none() in C

NEWS.md

@@ -8,10 +8,14 @@
 
 * `map_chr()` no longer coereces from logical, integer, or double to strings.
 
+* `every()`, `some()`, and `none()` now require that `.p` return logical scalar `TRUE`, `FALSE`, or `NA`. Previously, `NA` was allowed to be a non-logical `NA`, and would be coerced to a logical `NA`.
+
 ## Minor improvements and bug fixes
 
 * New "getting started" vignette, `vignette("purrr")` (#915, @ogolovkina).
 
+* `every()`, `some()`, and `none()` are now more performant. They are now as fast as or faster than their equivalent `any(map_lgl())` or `all(map_lgl())` calls (#1036, @ErdaradunGaztea).
+
 * `as_mapper.default()` optimized by removing special named argument handling for primitive functions (@mtcarsalot, #1088).
 
 * `list_flatten()` gains an `is_node` parameter taking a predicate function that determines whether an input element is a node or a leaf (@salim-b, #1179).

R/every-some-none.R

@@ -22,39 +22,48 @@
 #' # unsafe (e.g. in `if ()` conditions), make sure to use safe predicates:
 #' if (some(list(NA, FALSE), rlang::is_true)) "foo" else "bar"
 every <- function(.x, .p, ...) {
-  .p <- as_predicate(.p, ..., .mapper = TRUE, .allow_na = TRUE)
-
-  val <- TRUE
-  for (i in seq_along(.x)) {
-    val <- val && .p(.x[[i]], ...)
-
-    if (is_false(val)) {
-      return(FALSE)
-    }
-  }
-
-  val
+  satisfies_predicate(.x, .p, ..., .purrr_predicate = "every")
 }
 
 #' @export
 #' @rdname every
 some <- function(.x, .p, ...) {
-  .p <- as_predicate(.p, ..., .mapper = TRUE, .allow_na = TRUE)
-
-  val <- FALSE
-  for (i in seq_along(.x)) {
-    val <- val || .p(.x[[i]], ...)
-
-    if (is_true(val)) {
-      return(TRUE)
-    }
-  }
-
-  val
+  satisfies_predicate(.x, .p, ..., .purrr_predicate = "some")
 }
 
 #' @export
 #' @rdname every
 none <- function(.x, .p, ...) {
-  every(.x, negate(.p), ...)
+  satisfies_predicate(.x, .p, ..., .purrr_predicate = "none")
+}
+
+satisfies_predicate <- function(
+  .x,
+  .p,
+  ...,
+  .purrr_predicate,
+  .purrr_user_env = caller_env(2),
+  .purrr_error_call = caller_env()
+) {
+  # Not using `as_predicate()` as R level predicate result checks are too slow.
+  # Checks are done at the C level instead (#1169). Also, `NA` propagates
+  # through these functions, which `as_predicate()` doesn't allow.
+  .p <- as_mapper(.p, ...)
+
+  # Consistent with `map()`
+  .x <- vctrs_vec_compat(.x, .purrr_user_env)
+  obj_check_vector(.x, arg = ".x", call = .purrr_error_call)
+
+  n <- vec_size(.x)
+
+  i <- 0L
+
+  # We refer to `.p`, `.x`, `i`, `...`, and `.purrr_error_call` all from C level
+  switch(
+    .purrr_predicate,
+    every = .Call(every_impl, environment(), n, i),
+    some = .Call(some_impl, environment(), n, i),
+    none = .Call(none_impl, environment(), n, i),
+    abort("Unreachable", .internal = TRUE)
+  )
 }

R/utils.R

@@ -60,7 +60,6 @@ as_predicate <- function(
   .fn,
   ...,
   .mapper,
-  .allow_na = FALSE,
   .purrr_error_call = caller_env(),
   .purrr_error_arg = caller_arg(.fn)
 ) {
@@ -75,10 +74,6 @@ as_predicate <- function(
     out <- .fn(...)
 
     if (!is_bool(out)) {
-      if (is_na(out) && .allow_na) {
-        # Always return a logical NA
-        return(NA)
-      }
       cli::cli_abort(
         "{.fn { .purrr_error_arg }} must return a single `TRUE` or `FALSE`, not {.obj_type_friendly {out}}.",
         arg = .purrr_error_arg,
@@ -115,8 +110,9 @@ vctrs_list_compat <- function(
 }
 
 # When we want to use vctrs, but treat lists like purrr does
-# Treat data frames and S3 scalar lists like bare lists.
-# But ensure rcrd vctrs retain their class.
+#
+# Treats data frames and S3 scalar lists like bare lists.
+# But ensures rcrd vctrs retain their class.
 vctrs_vec_compat <- function(x, user_env) {
   if (inherits(x, "by")) {
     class(x) <- NULL
@@ -127,7 +123,7 @@ vctrs_vec_compat <- function(x, user_env) {
   } else if (is.pairlist(x)) {
     lifecycle::deprecate_soft(
       when = "1.0.0",
-      what = I("Use of pairlists in map functions"),
+      what = I("Use of pairlists in purrr functions"),
       details = "Please coerce explicitly with `as.list()`",
       user_env = user_env
     )
@@ -138,7 +134,7 @@ vctrs_vec_compat <- function(x, user_env) {
   } else if (is_call(x) || is.expression(x)) {
     lifecycle::deprecate_soft(
       when = "1.0.0",
-      what = I("Use of calls and pairlists in map functions"),
+      what = I("Use of calls and expressions in purrr functions"),
       details = "Please coerce explicitly with `as.list()`",
       user_env = user_env
     )

src/every-some-none.c

@@ -0,0 +1,110 @@
+#define R_NO_REMAP
+#include <R.h>
+#include <Rinternals.h>
+#include <stdbool.h>
+
+#include "conditions.h"
+
+/**
+ * Is `x` a scalar logical?
+ *
+ * Notably we bypass the class and any attributes, i.e. `structure(TRUE, foo =
+ * "bar", class = "my-class")` does count for these purrr functions for
+ * historical reasons. We also ignore any R level `length()` method, but that
+ * would be incredibly rare to see here.
+ */
+static inline
+bool is_scalar_logicalish(SEXP x) {
+  return TYPEOF(x) == LGLSXP && Rf_xlength(x) == 1;
+}
+
+/**
+ * C loop for `every()`, `some()`, and `none()`
+ *
+ * Uses `vctrs_vec_compat()` at the R level so that we can use `vec_size()` to
+ * compute `n`, while also using `[[` to extract elements, which is consistent
+ * with `map()`.
+ */
+static
+SEXP satisfies_predicate(
+  SEXP env,
+  SEXP ffi_n,
+  SEXP ffi_i,
+  int initial,
+  int early_stop
+) {
+  const int n = INTEGER_ELT(ffi_n, 0);
+  int* p_i = INTEGER(ffi_i);
+
+  static SEXP call = NULL;
+  if (call == NULL) {
+    SEXP x_sym = Rf_install(".x");
+    SEXP p_sym = Rf_install(".p");
+    SEXP i_sym = Rf_install("i");
+
+    // Constructs a call of the form .p(.x[[i]], ...)
+    SEXP x_i_sym = PROTECT(Rf_lang3(R_Bracket2Symbol, x_sym, i_sym));
+
+    call = Rf_lang3(p_sym, x_i_sym, R_DotsSymbol);
+    R_PreserveObject(call);
+
+    UNPROTECT(1);
+  }
+
+  // Number of arguments within `call` to force.
+  // Same as `map()`.
+  const int force = 1;
+
+  int out = initial;
+
+  for (int i = 0; i < n; ++i) {
+    *p_i = i + 1;
+
+    if (i % 1024 == 0) {
+      R_CheckUserInterrupt();
+    }
+
+    SEXP ffi_elt = PROTECT(R_forceAndCall(call, force, env));
+
+    if (!is_scalar_logicalish(ffi_elt)) {
+      // We don't pass `.purrr_error_call` through `.Call()` so we can avoid
+      // evaluating it when it isn't needed, so we have to retrieve it when
+      // required.
+      SEXP error_call = PROTECT(Rf_eval(Rf_install(".purrr_error_call"), env));
+
+      r_abort_call(
+        error_call,
+        "`.p()` must return a single `TRUE`, `FALSE`, or `NA`, not %s.",
+        rlang_obj_type_friendly_full(ffi_elt, true, false)
+      );
+    }
+
+    const int elt = LOGICAL_ELT(ffi_elt, 0);
+    UNPROTECT(1);
+
+    if (elt == early_stop) {
+      // Early exit
+      out = !initial;
+      break;
+    }
+
+    if (elt == NA_LOGICAL) {
+      // Propagate `NA`, but keep going
+      out = NA_LOGICAL;
+    }
+  }
+
+  *p_i = 0;
+
+  return Rf_ScalarLogical(out);
+}
+
+SEXP every_impl(SEXP ffi_env, SEXP ffi_n, SEXP ffi_i) {
+  return satisfies_predicate(ffi_env, ffi_n, ffi_i, 1, 0);
+}
+SEXP some_impl(SEXP ffi_env, SEXP ffi_n, SEXP ffi_i) {
+  return satisfies_predicate(ffi_env, ffi_n, ffi_i, 0, 1);
+}
+SEXP none_impl(SEXP ffi_env, SEXP ffi_n, SEXP ffi_i) {
+  return satisfies_predicate(ffi_env, ffi_n, ffi_i, 1, 1);
+}

src/init.c

@@ -13,6 +13,9 @@
 extern SEXP coerce_impl(SEXP, SEXP);
 extern SEXP pluck_impl(SEXP, SEXP, SEXP, SEXP);
 extern SEXP flatten_impl(SEXP);
+extern SEXP every_impl(SEXP, SEXP, SEXP);
+extern SEXP some_impl(SEXP, SEXP, SEXP);
+extern SEXP none_impl(SEXP, SEXP, SEXP);
 extern SEXP map_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
 extern SEXP map2_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
 extern SEXP pmap_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
@@ -24,6 +27,9 @@ static const R_CallMethodDef CallEntries[] = {
   {"coerce_impl",           (DL_FUNC) &coerce_impl,    2},
   {"pluck_impl",            (DL_FUNC) &pluck_impl,     4},
   {"flatten_impl",          (DL_FUNC) &flatten_impl,   1},
+  {"every_impl",            (DL_FUNC) &every_impl,     3},
+  {"some_impl",             (DL_FUNC) &some_impl,      3},
+  {"none_impl",             (DL_FUNC) &none_impl,      3},
   {"map_impl",              (DL_FUNC) &map_impl,       6},
   {"map2_impl",             (DL_FUNC) &map2_impl,      6},
   {"pmap_impl",             (DL_FUNC) &pmap_impl,      8},

tests/testthat/_snaps/every-some-none.md

@@ -1,16 +1,123 @@
-# every() requires logical value
+# every(), some(), and none() require logical scalar predicate results
 
     Code
-      every(list(1:3), identity)
+      every(list(1), function(x) 1)
     Condition
       Error in `every()`:
-      ! `.p()` must return a single `TRUE` or `FALSE`, not an integer vector.
+      ! `.p()` must return a single `TRUE`, `FALSE`, or `NA`, not the number 1.
 
 ---
 
     Code
-      every(list(function() NULL), identity)
+      some(list(1), function(x) 1)
+    Condition
+      Error in `some()`:
+      ! `.p()` must return a single `TRUE`, `FALSE`, or `NA`, not the number 1.
+
+---
+
+    Code
+      none(list(1), function(x) 1)
+    Condition
+      Error in `none()`:
+      ! `.p()` must return a single `TRUE`, `FALSE`, or `NA`, not the number 1.
+
+---
+
+    Code
+      every(list(1), function(x) NA_integer_)
     Condition
       Error in `every()`:
-      ! `.p()` must return a single `TRUE` or `FALSE`, not a function.
+      ! `.p()` must return a single `TRUE`, `FALSE`, or `NA`, not an integer `NA`.
+
+---
+
+    Code
+      some(list(1), function(x) NA_integer_)
+    Condition
+      Error in `some()`:
+      ! `.p()` must return a single `TRUE`, `FALSE`, or `NA`, not an integer `NA`.
+
+---
+
+    Code
+      none(list(1), function(x) NA_integer_)
+    Condition
+      Error in `none()`:
+      ! `.p()` must return a single `TRUE`, `FALSE`, or `NA`, not an integer `NA`.
+
+---
+
+    Code
+      every(list(1), function(x) c(TRUE, FALSE))
+    Condition
+      Error in `every()`:
+      ! `.p()` must return a single `TRUE`, `FALSE`, or `NA`, not a logical vector.
+
+---
+
+    Code
+      some(list(1), function(x) c(TRUE, FALSE))
+    Condition
+      Error in `some()`:
+      ! `.p()` must return a single `TRUE`, `FALSE`, or `NA`, not a logical vector.
+
+---
+
+    Code
+      none(list(1), function(x) c(TRUE, FALSE))
+    Condition
+      Error in `none()`:
+      ! `.p()` must return a single `TRUE`, `FALSE`, or `NA`, not a logical vector.
+
+# every(), some(), and none() require vector `.x`
+
+    Code
+      every(function() 1, identity)
+    Condition
+      Error in `every()`:
+      ! `.x` must be a vector, not a function.
+
+---
+
+    Code
+      some(function() 1, identity)
+    Condition
+      Error in `some()`:
+      ! `.x` must be a vector, not a function.
+
+---
+
+    Code
+      none(function() 1, identity)
+    Condition
+      Error in `none()`:
+      ! `.x` must be a vector, not a function.
+
+# pairlists, expressions, and calls are deprecated but work
+
+    Code
+      out <- every(expression(1, 2), is.double)
+    Condition
+      Warning:
+      Use of calls and expressions in purrr functions was deprecated in purrr 1.0.0.
+      i Please coerce explicitly with `as.list()`
+
+---
+
+    Code
+      out <- every(pairlist(1, 2), is.double)
+    Condition
+      Warning:
+      Use of pairlists in purrr functions was deprecated in purrr 1.0.0.
+      i Please coerce explicitly with `as.list()`
+
+---
+
+    Code
+      x <- every(quote(f(a, b)), is.name)
+    Condition
+      Warning:
+      Use of calls and expressions in purrr functions was deprecated in purrr 1.0.0.
+      i Please coerce explicitly with `as.list()`