Apply vctrs principles to map() and modify()

NAMESPACE

@@ -4,27 +4,10 @@ S3method(as_mapper,character)
 S3method(as_mapper,default)
 S3method(as_mapper,list)
 S3method(as_mapper,numeric)
-S3method(modify,character)
 S3method(modify,default)
-S3method(modify,double)
-S3method(modify,integer)
-S3method(modify,logical)
-S3method(modify,pairlist)
-S3method(modify2,character)
 S3method(modify2,default)
-S3method(modify2,double)
-S3method(modify2,integer)
-S3method(modify2,logical)
-S3method(modify_at,character)
 S3method(modify_at,default)
-S3method(modify_at,double)
-S3method(modify_at,integer)
-S3method(modify_at,logical)
-S3method(modify_if,character)
 S3method(modify_if,default)
-S3method(modify_if,double)
-S3method(modify_if,integer)
-S3method(modify_if,logical)
 S3method(print,purrr_function_compose)
 S3method(print,purrr_function_partial)
 S3method(print,purrr_rate_backoff)
@@ -152,6 +135,7 @@ export(map2_dfr)
 export(map2_int)
 export(map2_lgl)
 export(map2_raw)
+export(map2_vec)
 export(map_at)
 export(map_chr)
 export(map_dbl)
@@ -163,6 +147,7 @@ export(map_if)
 export(map_int)
 export(map_lgl)
 export(map_raw)
+export(map_vec)
 export(modify)
 export(modify2)
 export(modify_at)
@@ -184,6 +169,7 @@ export(pmap_dfr)
 export(pmap_int)
 export(pmap_lgl)
 export(pmap_raw)
+export(pmap_vec)
 export(possibly)
 export(prepend)
 export(pwalk)

NEWS.md

@@ -70,6 +70,10 @@
 * `*_at()` can now take a function (or formula) that's passed the vector of
   element names and returns the elements to select.
 
+* New `map_vec()`, `map2_vec()`, and `pmap_vec()` work on all types of vectors,
+  extending `map_lgl()`, `map_int()`, and friends so that you can easily work
+  with dates, factors, date-times and more (#435).
+
 * New `keep_at()` and `discard_at()` that work like `keep()` and `discard()`
   but operation on element names rather than element contents (#817).
 
@@ -117,6 +121,10 @@
 * `map2()` and `pmap()` now recycle names of their first input if
   needed (#783).
 
+* `modify()`, `modify_if()`, and `modify_at()` have been reimplemented using
+  vctrs principles. This shouldn't have an user facing impact, but it does
+  make the implementation much simpler.
+
 ### Plucking
 
 * `vec_depth()` is now `pluck_depth()` and works with more types of input
@@ -155,6 +163,8 @@
 
 ## Minor improvements and bug fixes
 
+* `modify()` no longer supports modifying calls or pairlists.
+
 * `modify_depth()` is no longer a generic. This makes it more consistent
   with `map_depth()`.
 

R/map.R

@@ -12,6 +12,9 @@
 #'   atomic vector of the indicated type (or die trying). For these functions,
 #'   `.f` must return a length-1 vector of the appropriate type.
 #'
+#' * `map_vec()` simplifies to the common type of the output. It works with
+#'   most types of simple vectors like Date, POSIXct, factors, etc.
+#'
 #' * `walk()` calls `.f` for its side-effect and returns
 #'   the input `.x`.
 #'
@@ -40,9 +43,12 @@
 #'
 #' * No suffix: a list.
 #'
-#' * `_lgl`, `_int`, `_dbl`, `_chr` return a logical, integer, double,
+#' * `_lgl()`, `_int()`, `_dbl()`, `_chr()` return a logical, integer, double,
 #'   or character vector respectively. It will be named if the input was named.
 #'
+#' * `_vec()` return an atomic or S3 vector, that is guaranteed to be
+#'   simpler than list.
+#'
 #' * `walk()` returns the input `.x` (invisibly). This makes it easy to
 #'    use in a pipe.
 #' @export
@@ -120,23 +126,33 @@ map_lgl <- function(.x, .f, ..., .progress = FALSE) {
 
 #' @rdname map
 #' @export
-map_chr <- function(.x, .f, ..., .progress = FALSE) {
+map_int <- function(.x, .f, ..., .progress = FALSE) {
   .f <- as_mapper(.f, ...)
-  .Call(map_impl, environment(), ".x", ".f", "character", .progress)
+  .Call(map_impl, environment(), ".x", ".f", "integer", .progress)
 }
 
 #' @rdname map
 #' @export
-map_int <- function(.x, .f, ..., .progress = FALSE) {
+map_dbl <- function(.x, .f, ..., .progress = FALSE) {
   .f <- as_mapper(.f, ...)
-  .Call(map_impl, environment(), ".x", ".f", "integer", .progress)
+  .Call(map_impl, environment(), ".x", ".f", "double", .progress)
 }
 
 #' @rdname map
 #' @export
-map_dbl <- function(.x, .f, ..., .progress = FALSE) {
+map_chr <- function(.x, .f, ..., .progress = FALSE) {
   .f <- as_mapper(.f, ...)
-  .Call(map_impl, environment(), ".x", ".f", "double", .progress)
+  .Call(map_impl, environment(), ".x", ".f", "character", .progress)
+}
+
+#' @rdname map
+#' @param .ptype If `NULL`, the default, the output type is the common type
+#'   of the elements of the result. Otherwise, supply a "prototype" giving
+#'   the desired type of output.
+#' @export
+map_vec <- function(.x, .f, ..., .ptype = NULL, .progress = FALSE) {
+  out <- map(.x, .f, ..., .progress = .progress)
+  simplify_impl(out, ptype = .ptype)
 }
 
 #' @rdname map

R/map2.R

@@ -64,11 +64,16 @@ map2_chr <- function(.x, .y, .f, ..., .progress = NULL) {
   .Call(map2_impl, environment(), ".x", ".y", ".f", "character", .progress)
 }
 
+#' @rdname map2
+#' @export
+map2_vec <- function(.x, .y, .f, ..., .ptype = NULL, .progress = NULL) {
+  out <- map2(.x, .y, .f, ..., .progress = .progress)
+  simplify_impl(out, ptype = .ptype)
+}
 
 #' @export
 #' @rdname map2
 walk2 <- function(.x, .y, .f, ...) {
   map2(.x, .y, .f, ...)
   invisible(.x)
 }
-

R/modify.R

@@ -93,41 +93,18 @@ modify <- function(.x, .f, ...) {
 modify.default <- function(.x, .f, ...) {
   .f <- as_mapper(.f, ...)
 
-  for (i in seq_along(.x)) {
-    list_slice2(.x, i) <- .f(.x[[i]], ...)
+  if (vec_is_list(.x) || is.data.frame(.x)) {
+    out <- map(vec_proxy(.x), .f, ...)
+    vec_restore(out, .x)
+  } else if (vec_is(.x)) {
+    map_vec(.x, .f, ..., .ptype = .x)
+  } else if (is.null(.x) || is.list(.x)) {
+    .x[] <- map(.x, .f, ...)
+    .x
+  } else {
+    cli::cli_abort("Don't know how to modify {.obj_type_friendly {.x}}.")
   }
-
-  .x
-}
-# TODO: Replace all the following methods with a generic strategy that
-# implements sane coercion rules for base vectors
-#' @export
-modify.integer  <- function (.x, .f, ...) {
-  .x[] <- map_int(.x, .f, ...)
-  .x
-}
-#' @export
-modify.double  <- function (.x, .f, ...) {
-  .x[] <- map_dbl(.x, .f, ...)
-  .x
-}
-#' @export
-modify.character  <- function (.x, .f, ...) {
-  .x[] <- map_chr(.x, .f, ...)
-  .x
-}
-#' @export
-modify.logical  <- function (.x, .f, ...) {
-  .x[] <- map_lgl(.x, .f, ...)
-  .x
 }
-#' @export
-modify.pairlist <- function(.x, .f, ...) {
-  as.pairlist(map(.x, .f, ...))
-}
-
-
-# modify_if ---------------------------------------------------------------
 
 #' @rdname modify
 #' @inheritParams map_if
@@ -139,52 +116,16 @@ modify_if <- function(.x, .p, .f, ..., .else = NULL) {
 #' @export
 modify_if.default <- function(.x, .p, .f, ..., .else = NULL) {
   where <- where_if(.x, .p)
-  index <- seq_along(.x)
+  .x <- modify_where(.x, where, .f, ...)
 
-  .f <- as_mapper(.f, ...)
-  for (i in index[where]) {
-    list_slice2(.x, i) <- .f(.x[[i]], ...)
-  }
-
-  if (!is_null(.else)) {
+  if (!is.null(.else)) {
     .else <- as_mapper(.else, ...)
-    for (i in index[!where]) {
-      list_slice2(.x, i) <- .else(.x[[i]], ...)
-    }
-  }
-
-  .x
-}
-#' @export
-modify_if.integer <- function(.x, .p, .f, ..., .else = NULL) {
-  modify_if_base(map_int, .x, .p, .true = .f, .false = .else, ...)
-}
-#' @export
-modify_if.double <- function(.x, .p, .f, ..., .else = NULL) {
-  modify_if_base(map_dbl, .x, .p, .true = .f, .false = .else, ...)
-}
-#' @export
-modify_if.character <- function(.x, .p, .f, ..., .else = NULL) {
-  modify_if_base(map_chr, .x, .p, .true = .f, .false = .else, ...)
-}
-#' @export
-modify_if.logical <- function(.x, .p, .f, ..., .else = NULL) {
-  modify_if_base(map_lgl, .x, .p, .true = .f, .false = .else, ...)
-}
-
-modify_if_base <- function(.fmap, .x, .p, .true, .false = NULL, ..., .error_call = caller_env()) {
-  where <- where_if(.x, .p, .error_call = .error_call)
-  .x[where] <- .fmap(.x[where], .true, ...)
-
-  if (!is.null(.false)) {
-    .x[!where] <- .fmap(.x[!where], .false, ...)
+    .x <- modify_where(.x, !where, .else, ...)
   }
 
   .x
 }
 
-# modify_at ---------------------------------------------------------------
-
 #' @rdname modify
 #' @inheritParams map_at
 #' @export
@@ -195,76 +136,59 @@ modify_at <- function(.x, .at, .f, ...) {
 #' @export
 modify_at.default <- function(.x, .at, .f, ...) {
   where <- where_at(.x, .at)
-  modify_if(.x, where, .f, ...)
-}
-#' @export
-modify_at.integer <- function(.x, .at, .f, ...) {
-  where <- where_at(.x, .at)
-  .x[where] <- map_int(.x[where], .f, ...)
-  .x
-}
-#' @export
-modify_at.double <- function(.x, .at, .f, ...) {
-  where <- where_at(.x, .at)
-  .x[where] <- map_dbl(.x[where], .f, ...)
-  .x
-}
-#' @export
-modify_at.character <- function(.x, .at, .f, ...) {
-  where <- where_at(.x, .at)
-  .x[where] <- map_chr(.x[where], .f, ...)
-  .x
-}
-#' @export
-modify_at.logical <- function(.x, .at, .f, ...) {
-  where <- where_at(.x, .at)
-  .x[where] <- map_lgl(.x[where], .f, ...)
-  .x
+  modify_where(.x, where, .f, ...)
 }
 
-# modify2 -----------------------------------------------------------------
-
 #' @rdname modify
 #' @export
 modify2 <- function(.x, .y, .f, ...) {
   UseMethod("modify2")
 }
 #' @export
 modify2.default <- function(.x, .y, .f, ...) {
-  modify2_base(map2, .x, .y, .f, ...)
-}
-# TODO: Improve genericity (see above)
-#' @export
-modify2.integer  <- function(.x, .y, .f, ...) {
-  modify2_base(map2_int, .x, .y, .f, ...)
-}
-#' @export
-modify2.double  <- function(.x, .y, .f, ...) {
-  modify2_base(map2_dbl, .x, .y, .f, ...)
-}
-#' @export
-modify2.character  <- function(.x, .y, .f, ...) {
-  modify2_base(map2_chr, .x, .y, .f, ...)
-}
-#' @export
-modify2.logical  <- function(.x, .y, .f, ...) {
-  modify2_base(map2_lgl, .x, .y, .f, ...)
-}
-
-modify2_base <- function(mapper, .x, .y, .f, ...) {
   .f <- as_mapper(.f, ...)
-  out <- mapper(.x, .y, .f, ...)
 
-  # if .x got recycled by map2
-  if (length(out) > length(.x)) {
-    .x <- .x[rep(1L, length(out))]
+  if (vec_is_list(.x) || is.data.frame(.x)) {
+    out <- map2(vec_proxy(.x), .y, .f, ...)
+    vec_restore(out, .x)
+  } else if (vec_is(.x)) {
+    map2_vec(.x, .y, .f, ..., .ptype = .x)
+  } else if (is.null(.x) || is.list(.x)) {
+    out <- map2(.x, .y, .f, ...)
+    if (length(out) > length(.x)) {
+      .x <- .x[rep(1L, length(out))]
+    }
+    .x[] <- out
+    .x
+  } else {
+    cli::cli_abort("Don't know how to modify {.obj_type_friendly {.x}}.")
   }
-  .x[] <- out
-  .x
 }
 
 #' @rdname modify
 #' @export
 imodify <- function(.x, .f, ...) {
   modify2(.x, vec_index(.x), .f, ...)
 }
+
+
+# helpers -----------------------------------------------------------------
+
+modify_where <- function(.x, .where, .f, ..., .error_call = caller_env()) {
+  if (vec_is_list(.x) || is.data.frame(.x)) {
+    out <- vec_proxy(.x)
+    out[.where] <- map(out[.where], .f, ...)
+    vec_restore(out, .x)
+  } else if (vec_is(.x)) {
+    .x[.where] <- map_vec(.x[.where], .f, ..., .ptype = .x)
+    .x
+  } else if (is.null(.x) || is.list(.x)) {
+    .x[.where] <- map(.x[.where], .f, ...)
+    .x
+  } else {
+    cli::cli_abort(
+      "Don't know how to modify {.obj_type_friendly {.x}}.",
+      call = .error_call
+    )
+  }
+}