Use vctrs for input validation

Based on #945

R/map2.R

@@ -57,6 +57,18 @@ map2_chr <- function(.x, .y, .f, ..., .progress = FALSE) {
 map2_ <- function(.x, .y, .f, ..., .type, .progress = FALSE, .error_call = caller_env()) {
   .f <- as_mapper(.f, ...)
   i <- 0L
+
+  if (is.list(.x) && !vec_is_list(.x)) {
+    .x <- unclass(.x)
+  }
+  if (is.list(.y) && !vec_is_list(.y)) {
+    .y <- unclass(.y)
+  }
+
+  args <- vec_recycle_common(.x = .x, .y = .y, .call = .error_call)
+  .x <- args$.x
+  .y <- args$.y
+
   with_indexed_errors(
     i = i,
     error_call = .error_call,

R/pmap.R

@@ -100,10 +100,13 @@ pmap_chr <- function(.l, .f, ..., .progress = FALSE) {
 }
 
 pmap_ <- function(.l, .f, ..., .type, .progress = FALSE, .error_call = caller_env()) {
-  .f <- as_mapper(.f, ...)
   if (is.data.frame(.l)) {
     .l <- as.list(.l)
   }
+  vec_check_list(.l, call = .error_call)
+  .l <- vec_recycle_common(!!!.l, .arg = ".l", .call = .error_call)
+
+  .f <- as_mapper(.f, ...)
   i <- 0L
 
   with_indexed_errors(

src/map.c

@@ -107,30 +107,19 @@ SEXP map2_impl(SEXP env, SEXP type_, SEXP progress, SEXP error_call) {
   SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_)));
 
   SEXP x_val = PROTECT(Rf_eval(x, env));
-  check_vector(x_val, ".x", error_call);
   SEXP y_val = PROTECT(Rf_eval(y, env));
-  check_vector(y_val, ".y", error_call);
-
-  int nx = Rf_length(x_val), ny = Rf_length(y_val);
-  if (nx != ny && nx != 1 && ny != 1) {
-    r_abort_call(
-      error_call,
-      "`.y must have length 1 or %i, not %i.",
-      nx, ny
-    );
-  }
-  int n = (nx == 1) ? ny : nx;
+
+  int n = Rf_length(x_val);
 
   // Constructs a call like f(x[[i]], y[[i]], ...)
-  SEXP one = PROTECT(Rf_ScalarInteger(1));
-  SEXP Xi = PROTECT(Rf_lang3(R_Bracket2Symbol, x, nx == 1 ? one : i));
-  SEXP Yi = PROTECT(Rf_lang3(R_Bracket2Symbol, y, ny == 1 ? one : i));
+  SEXP Xi = PROTECT(Rf_lang3(R_Bracket2Symbol, x, i));
+  SEXP Yi = PROTECT(Rf_lang3(R_Bracket2Symbol, y, i));
   SEXP f_call = PROTECT(Rf_lang4(f, Xi, Yi, R_DotsSymbol));
 
   SEXP out = PROTECT(call_loop(env, f_call, n, type, 2, progress));
   copy_names(x_val, out);
 
-  UNPROTECT(7);
+  UNPROTECT(6);
   return out;
 }
 
@@ -139,57 +128,15 @@ SEXP pmap_impl(SEXP env, SEXP type_, SEXP progress, SEXP error_call) {
   SEXP l_val = PROTECT(Rf_eval(l, env));
   SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_)));
 
-  if (!Rf_isVectorList(l_val)) {
-    r_abort_call(
-      error_call,
-      "`.l` must be a list, not %s.",
-      rlang_obj_type_friendly_full(l_val, true, false)
-    );
-  }
-
   // Check all elements are lists and find recycled length
   int m = Rf_length(l_val);
-  int has_scalar = 0;
-  int n = -1;
-  for (int j = 0; j < m; ++j) {
-    SEXP j_val = VECTOR_ELT(l_val, j);
-
-    if (!Rf_isVector(j_val) && !Rf_isNull(j_val)) {
-      r_abort_call(
-        error_call,
-        "`.l[[%i]]` must be a vector, not %s.",
-        j + 1,
-        rlang_obj_type_friendly_full(j_val, true, false)
-      );
-    }
-
-    int nj = Rf_length(j_val);
-    if (nj == 1) {
-      has_scalar = 1;
-      continue;
-    }
-
-    if (n == -1) {
-      n = nj;
-    } else if (nj != n) {
-      r_abort_call(
-        error_call,
-        "`.l[[%i]]` must have length 1 or %i, not %i.",
-        j + 1, n, nj
-      );
-    }
-  }
-
-  if (n == -1) {
-    n = has_scalar ? 1 : 0;
-  }
+  int n = m == 0 ? 0 : Rf_length(VECTOR_ELT(l_val, 0));
 
   SEXP l_names = PROTECT(Rf_getAttrib(l_val, R_NamesSymbol));
   int has_names = !Rf_isNull(l_names);
 
   SEXP f = Rf_install(".f");
   SEXP i = Rf_install("i");
-  SEXP one = PROTECT(Rf_ScalarInteger(1));
 
   // Construct call like f(.l[[1]][[i]], .l[[2]][[i]], ...)
   //
@@ -205,12 +152,10 @@ SEXP pmap_impl(SEXP env, SEXP type_, SEXP progress, SEXP error_call) {
   PROTECT_WITH_INDEX(f_call, &fi);
 
   for (int j = m - 1; j >= 0; --j) {
-    int nj = Rf_length(VECTOR_ELT(l_val, j));
-
     // Construct call like .l[[j]][[i]]
     SEXP j_ = PROTECT(Rf_ScalarInteger(j + 1));
     SEXP l_j = PROTECT(Rf_lang3(R_Bracket2Symbol, l, j_));
-    SEXP l_ji = PROTECT(Rf_lang3(R_Bracket2Symbol, l_j, nj == 1 ? one : i));
+    SEXP l_ji = PROTECT(Rf_lang3(R_Bracket2Symbol, l_j, i));
 
     REPROTECT(f_call = Rf_lcons(l_ji, f_call), fi);
     if (has_names && CHAR(STRING_ELT(l_names, j))[0] != '\0')
@@ -227,6 +172,6 @@ SEXP pmap_impl(SEXP env, SEXP type_, SEXP progress, SEXP error_call) {
     copy_names(VECTOR_ELT(l_val, 0), out);
   }
 
-  UNPROTECT(5);
+  UNPROTECT(4);
   return out;
 }

tests/testthat/_snaps/map2.md

@@ -39,10 +39,10 @@
       map2(1:2, 1:3, `+`)
     Condition
       Error in `map2()`:
-      ! `.y must have length 1 or 2, not 3.
+      ! Can't recycle `.x` (size 2) to match `.y` (size 3).
     Code
       map2(1:2, integer(), `+`)
     Condition
       Error in `map2()`:
-      ! `.y must have length 1 or 2, not 0.
+      ! Can't recycle `.x` (size 2) to match `.y` (size 0).
 

tests/testthat/_snaps/modify.md

@@ -50,12 +50,12 @@
       modify2(1:3, integer(), `+`)
     Condition
       Error in `map2()`:
-      ! `.y must have length 1 or 3, not 0.
+      ! Can't recycle `.x` (size 3) to match `.y` (size 0).
     Code
       modify2(1:3, 1:4, `+`)
     Condition
       Error in `map2()`:
-      ! `.y must have length 1 or 3, not 4.
+      ! Can't recycle `.x` (size 3) to match `.y` (size 4).
 
 # modify_if() requires predicate functions
 

tests/testthat/_snaps/pmap.md

@@ -39,10 +39,10 @@
       pmap(list(1:2, 1:3), `+`)
     Condition
       Error in `pmap()`:
-      ! `.l[[2]]` must have length 1 or 2, not 3.
+      ! Can't recycle `.l[[1]]` (size 2) to match `.l[[2]]` (size 3).
     Code
       pmap(list(1:2, integer()), `+`)
     Condition
       Error in `pmap()`:
-      ! `.l[[2]]` must have length 1 or 2, not 0.
+      ! Can't recycle `.l[[1]]` (size 2) to match `.l[[2]]` (size 0).