minor improvements to pmap/map shims

R/auto_partial.R

@@ -98,7 +98,7 @@ partial_self = function(name = NULL, waivable = TRUE) {
 
   waivable_arg_names = if (waivable) {
     f_args = formals(f)
-    is_required_arg = vapply(f_args, rlang::is_missing, FUN.VALUE = logical(1))
+    is_required_arg = map_lgl_(f_args, rlang::is_missing)
     names(f_args)[!is_required_arg]
   }
 
@@ -158,7 +158,7 @@ auto_partial = function(f, name = NULL, waivable = TRUE) {
   f_args = formals(f)
 
   # find the required arguments
-  is_required_arg = vapply(f_args, rlang::is_missing, FUN.VALUE = logical(1))
+  is_required_arg = map_lgl_(f_args, rlang::is_missing)
   required_arg_names = names(f_args)[is_required_arg]
   required_arg_names = required_arg_names[required_arg_names != "..."]
 

R/distributions.R

@@ -393,7 +393,7 @@ generate.ggdist__wrapped_categorical = function(x, ...) {
   x = vec_cast(x, list_of(x[[1]]))
   weights = vec_cast(weights, list_of(numeric()))
 
-  weight_is_null = vapply(weights, is.null, logical(1))
+  weight_is_null = map_lgl_(weights, is.null)
   stopifnot(lengths(x) == lengths(weights) | weight_is_null)
 
   # only allow univariate samples since that's all we should ever end
@@ -498,7 +498,7 @@ inverse_deriv_at_y = function(trans, y) {
       # we use this (slightly less quick) approach instead of numDeriv::grad()
       # on the whole vector because numDeriv::grad() errors out if any data
       # point fails while this will return `NA` for those points
-      vapply(y, FUN.VALUE = numeric(1), function(y_i) {
+      map_dbl_(y, function(y_i) {
         tryCatch(
           suppressWarnings(numDeriv::grad(func = trans$inverse, y_i)),
           error = function(e) NA_real_

R/geom_blur_dots.R

@@ -32,7 +32,7 @@ make_blurry_points_grob = auto_partial(name = "make_blurry_points_grob", functio
   r = unit(fontsize / font_size_ratio / 2, "points")
   sd = convertUnit(unit(sd %||% 0, "native"), unitTo = "points", axisFrom = axis, typeFrom = "dimension")
 
-  grobs = .mapply(list(x, y, fill, sd, lwd, lty, pch), NULL, FUN = function(x, y, fill, sd, lwd, lty, pch) {
+  grobs = pmap_(list(x, y, fill, sd, lwd, lty, pch), function(x, y, fill, sd, lwd, lty, pch) {
     shape = translate_blur_shape(pch)
     if (shape == "square") r = r * 0.9
     blur_width = 2 * sd + r

R/point_interval.R

@@ -523,7 +523,7 @@ Mode.default = function(x, na.rm = FALSE, ..., density = density_bounded(trim =
       ux[which.max(tabulate(match(x, ux)))]
     } else {
       ux = unique(x)
-      ux_weights = vapply(split(weights, factor(x, ux)), sum, numeric(1))
+      ux_weights = map_dbl_(split(weights, factor(x, ux)), sum)
       ux[which.max(ux_weights)]
     }
   } else {

R/rd.R

@@ -153,7 +153,7 @@ rd_layer_params = function(geom_name, stat = NULL, as_dots = FALSE) {
   )
   params = params[param_names]
 
-  missing_docs = vapply(params, is.null, logical(1))
+  missing_docs = map_lgl_(params, is.null)
   if (any(missing_docs)) {
     cli_abort("Missing docs for params: {param_names[missing_docs]}")
   }

R/stat_slabinterval.R

@@ -546,7 +546,7 @@ StatSlabinterval = ggproto("StatSlabinterval", AbstractStatSlabinterval,
 
       # convert character/factor dist aesthetic into distributional objects
       arg_cols = names(data)[startsWith(names(data), "arg")]
-      data$dist = pmap_(data[, c("dist", arg_cols)], function(dist, ...) {
+      data$dist = pmap_(data[, c("dist", arg_cols), drop = FALSE], function(dist, ...) {
         if (is.na(dist)) {
           dist_missing()
         } else {

R/stat_spike.R

@@ -189,7 +189,7 @@ check_at = function(at, call = parent.frame()) {
     )
   }
 
-  is_wrong_type = !vapply(at, function(x) is.function(x) || is.numeric(x) || is.character(x), logical(1))
+  is_wrong_type = !map_lgl_(at, function(x) is.function(x) || is.numeric(x) || is.character(x))
   if (any(is_wrong_type)) {
     wrong_type_i = which(is_wrong_type)
     i = wrong_type_i[[1]]
@@ -207,7 +207,7 @@ check_at = function(at, call = parent.frame()) {
 
   # push names down into vectors --- we do this so that when we unnest into a list
   # of scalars, if a name was provided for a vector it is retained
-  is_not_function = !vapply(at, is.function, logical(1))
+  is_not_function = !map_lgl_(at, is.function)
   named_vectors = which(rlang::have_name(at) & is_not_function)
   for (i in named_vectors) {
     if (!any(rlang::have_name(at[[i]]))) {
@@ -235,7 +235,7 @@ check_at = function(at, call = parent.frame()) {
   }
 
   # find functions for strings
-  is_character = vapply(at, is.character, logical(1))
+  is_character = map_lgl_(at, is.character)
   at[is_character] = lapply(at[is_character], match_function)
 
   at

R/util.R

@@ -193,9 +193,8 @@ row_map_dfr_ = function(data, fun, ...) {
   })
 }
 
-pmap_ = function(data, fun) {
-  # this is roughly equivalent to purrr::pmap
-  lapply(vctrs::vec_chop(data), function(row) do.call(fun, lapply(row, `[[`, 1)))
+pmap_ = function(.l, .f, ...) {
+  .mapply(.f, .l, list(...))
 }
 
 ddply_ = function(data, groups, fun, ...) {
@@ -240,15 +239,15 @@ split_df = function(data, groups) {
 }
 
 map_dbl_ = function(.x, .f, ...) {
-  vapply(.x, .f, FUN.VALUE = numeric(1), ...)
+  vapply(.x, .f, FUN.VALUE = NA_real_, ...)
 }
 
 map_lgl_ = function(.x, .f, ...) {
-  vapply(.x, .f, FUN.VALUE = logical(1), ...)
+  vapply(.x, .f, FUN.VALUE = NA, ...)
 }
 
-map2_ = function(.x, .y, .f) {
-  .mapply(.f, list(.x, .y), NULL)
+map2_ = function(.x, .y, .f, ...) {
+  .mapply(.f, list(.x, .y), list(...))
 }
 
 map2_chr_ = function(.x, .y, .f) {