Use standalone purrr file

R/check-devtools.R

@@ -23,13 +23,13 @@ check_dev_versions <- function(pkg = ".") {
   pkg <- as.package(pkg)
 
   dep_list <- pkg[tolower(remotes::standardise_dep(TRUE))]
-  deps <- do.call("rbind", unname(compact(lapply(dep_list, parse_deps))))
+  deps <- do.call("rbind", unname(compact(map(dep_list, parse_deps))))
   deps <- deps[!is.na(deps$version), , drop = FALSE]
 
-  parsed <- lapply(deps$version, function(x) unlist(numeric_version(x)))
+  parsed <- map(deps$version, function(x) unlist(numeric_version(x)))
 
   lens <- lengths(parsed)
-  last_ver <- vapply(parsed, function(x) x[[length(x)]], integer(1))
+  last_ver <- map_int(parsed, function(x) x[[length(x)]])
 
   is_dev <- lens == 4 & last_ver >= 9000
 
@@ -68,7 +68,7 @@ check_vignette_titles <- function(pkg = ".") {
     any(grepl("Vignette Title", h))
   }
   v <- stats::setNames(vigns$docs, path_file(vigns$docs))
-  has_vt <- vapply(v, has_vignette_title, logical(1), n = 30)
+  has_vt <- map_lgl(v, has_vignette_title, n = 30)
 
   check_status(
     !any(has_vt),

R/check-doc.R

@@ -84,18 +84,18 @@ check_doc_fields <- function(pkg = ".", fields = c("value", "examples")) {
 
   paths <- dir_ls(path(pkg$path, "man"), regexp = "\\.Rd$")
   names(paths) <- path_rel(paths, pkg$path)
-  rd <- lapply(paths, tools::parse_Rd, permissive = TRUE)
-  rd_tags <- lapply(rd, \(x) unlist(lapply(x, attr, "Rd_tag")))
+  rd <- map(paths, tools::parse_Rd, permissive = TRUE)
+  rd_tags <- map(rd, \(x) unlist(map(x, attr, "Rd_tag")))
 
   has_tag <- function(tags, this) {
     any(paste0("\\", this) %in% tags)
   }
 
-  has_usage <- vapply(rd_tags, has_tag, logical(1), this = "usage")
+  has_usage <- map_lgl(rd_tags, has_tag, this = "usage")
   rd_tags <- rd_tags[has_usage]
 
-  results <- lapply(fields, function(field) {
-    missing <- !vapply(rd_tags, has_tag, logical(1), this = field)
+  results <- map(fields, function(field) {
+    missing <- !map_lgl(rd_tags, has_tag, this = field)
     names(rd_tags)[missing]
   })
 

R/check-mac.R

@@ -107,7 +107,7 @@ check_mac <- function(
   )
 
   if (length(dep_built_paths) > 0) {
-    uploads <- lapply(dep_built_paths, httr::upload_file)
+    uploads <- map(dep_built_paths, httr::upload_file)
     names(uploads) <- rep("depfiles", length(uploads))
     body <- append(body, uploads)
   }

R/check-win.R

@@ -137,7 +137,7 @@ check_win <- function(
     "/",
     path_file(built_path)
   )
-  lapply(url, upload_ftp, file = built_path)
+  walk(url, upload_ftp, file = built_path)
 
   if (!quiet) {
     time <- strftime(Sys.time() + 30 * 60, "%I:%M %p")
@@ -192,7 +192,7 @@ change_maintainer_email <- function(path, email, call = parent.frame()) {
   if (!is.list(roles)) {
     roles <- list(roles)
   }
-  is_maintainer <- vapply(roles, function(r) all("cre" %in% r), logical(1))
+  is_maintainer <- map_lgl(roles, function(r) all("cre" %in% r))
   aut[is_maintainer]$email <- email
   desc$set_authors(aut)
 

R/dev-mode.R

@@ -88,7 +88,7 @@ is_library <- function(path) {
   dirs <- dir_ls(path, type = "directory")
 
   has_pkg_dir <- function(path) length(dir_ls(path, regexp = "Meta")) > 0
-  help_dirs <- vapply(dirs, has_pkg_dir, logical(1))
+  help_dirs <- map_lgl(dirs, has_pkg_dir)
 
   all(help_dirs)
 }

R/import-standalone-purrr.R

@@ -0,0 +1,246 @@
+# Standalone file: do not edit by hand
+# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-purrr.R
+# Generated by: usethis::use_standalone("r-lib/rlang", "purrr")
+# ----------------------------------------------------------------------
+#
+# ---
+# repo: r-lib/rlang
+# file: standalone-purrr.R
+# last-updated: 2023-02-23
+# license: https://unlicense.org
+# imports: rlang
+# ---
+#
+# This file provides a minimal shim to provide a purrr-like API on top of
+# base R functions. They are not drop-in replacements but allow a similar style
+# of programming.
+#
+# ## Changelog
+#
+# 2023-02-23:
+# * Added `list_c()`
+#
+# 2022-06-07:
+# * `transpose()` is now more consistent with purrr when inner names
+#   are not congruent (#1346).
+#
+# 2021-12-15:
+# * `transpose()` now supports empty lists.
+#
+# 2021-05-21:
+# * Fixed "object `x` not found" error in `imap()` (@mgirlich)
+#
+# 2020-04-14:
+# * Removed `pluck*()` functions
+# * Removed `*_cpl()` functions
+# * Used `as_function()` to allow use of `~`
+# * Used `.` prefix for helpers
+#
+# nocov start
+
+map <- function(.x, .f, ...) {
+  .f <- as_function(.f, env = global_env())
+  lapply(.x, .f, ...)
+}
+walk <- function(.x, .f, ...) {
+  map(.x, .f, ...)
+  invisible(.x)
+}
+
+map_lgl <- function(.x, .f, ...) {
+  .rlang_purrr_map_mold(.x, .f, logical(1), ...)
+}
+map_int <- function(.x, .f, ...) {
+  .rlang_purrr_map_mold(.x, .f, integer(1), ...)
+}
+map_dbl <- function(.x, .f, ...) {
+  .rlang_purrr_map_mold(.x, .f, double(1), ...)
+}
+map_chr <- function(.x, .f, ...) {
+  .rlang_purrr_map_mold(.x, .f, character(1), ...)
+}
+.rlang_purrr_map_mold <- function(.x, .f, .mold, ...) {
+  .f <- as_function(.f, env = global_env())
+  out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE)
+  names(out) <- names(.x)
+  out
+}
+
+map2 <- function(.x, .y, .f, ...) {
+  .f <- as_function(.f, env = global_env())
+  out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE)
+  if (length(out) == length(.x)) {
+    set_names(out, names(.x))
+  } else {
+    set_names(out, NULL)
+  }
+}
+map2_lgl <- function(.x, .y, .f, ...) {
+  as.vector(map2(.x, .y, .f, ...), "logical")
+}
+map2_int <- function(.x, .y, .f, ...) {
+  as.vector(map2(.x, .y, .f, ...), "integer")
+}
+map2_dbl <- function(.x, .y, .f, ...) {
+  as.vector(map2(.x, .y, .f, ...), "double")
+}
+map2_chr <- function(.x, .y, .f, ...) {
+  as.vector(map2(.x, .y, .f, ...), "character")
+}
+imap <- function(.x, .f, ...) {
+  map2(.x, names(.x) %||% seq_along(.x), .f, ...)
+}
+
+pmap <- function(.l, .f, ...) {
+  .f <- as.function(.f)
+  args <- .rlang_purrr_args_recycle(.l)
+  do.call(
+    "mapply",
+    c(
+      FUN = list(quote(.f)),
+      args,
+      MoreArgs = quote(list(...)),
+      SIMPLIFY = FALSE,
+      USE.NAMES = FALSE
+    )
+  )
+}
+.rlang_purrr_args_recycle <- function(args) {
+  lengths <- map_int(args, length)
+  n <- max(lengths)
+
+  stopifnot(all(lengths == 1L | lengths == n))
+  to_recycle <- lengths == 1L
+  args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n))
+
+  args
+}
+
+keep <- function(.x, .f, ...) {
+  .x[.rlang_purrr_probe(.x, .f, ...)]
+}
+discard <- function(.x, .p, ...) {
+  sel <- .rlang_purrr_probe(.x, .p, ...)
+  .x[is.na(sel) | !sel]
+}
+map_if <- function(.x, .p, .f, ...) {
+  matches <- .rlang_purrr_probe(.x, .p)
+  .x[matches] <- map(.x[matches], .f, ...)
+  .x
+}
+.rlang_purrr_probe <- function(.x, .p, ...) {
+  if (is_logical(.p)) {
+    stopifnot(length(.p) == length(.x))
+    .p
+  } else {
+    .p <- as_function(.p, env = global_env())
+    map_lgl(.x, .p, ...)
+  }
+}
+
+compact <- function(.x) {
+  .x[as.logical(lengths(.x))]
+}
+
+transpose <- function(.l) {
+  if (!length(.l)) {
+    return(.l)
+  }
+
+  inner_names <- names(.l[[1]])
+
+  if (is.null(inner_names)) {
+    fields <- seq_along(.l[[1]])
+  } else {
+    fields <- set_names(inner_names)
+    .l <- map(.l, function(x) {
+      if (is.null(names(x))) {
+        set_names(x, inner_names)
+      } else {
+        x
+      }
+    })
+  }
+
+  # This way missing fields are subsetted as `NULL` instead of causing
+  # an error
+  .l <- map(.l, as.list)
+
+  map(fields, function(i) {
+    map(.l, .subset2, i)
+  })
+}
+
+every <- function(.x, .p, ...) {
+  .p <- as_function(.p, env = global_env())
+
+  for (i in seq_along(.x)) {
+    if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE)
+  }
+  TRUE
+}
+some <- function(.x, .p, ...) {
+  .p <- as_function(.p, env = global_env())
+
+  for (i in seq_along(.x)) {
+    if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE)
+  }
+  FALSE
+}
+negate <- function(.p) {
+  .p <- as_function(.p, env = global_env())
+  function(...) !.p(...)
+}
+
+reduce <- function(.x, .f, ..., .init) {
+  f <- function(x, y) .f(x, y, ...)
+  Reduce(f, .x, init = .init)
+}
+reduce_right <- function(.x, .f, ..., .init) {
+  f <- function(x, y) .f(y, x, ...)
+  Reduce(f, .x, init = .init, right = TRUE)
+}
+accumulate <- function(.x, .f, ..., .init) {
+  f <- function(x, y) .f(x, y, ...)
+  Reduce(f, .x, init = .init, accumulate = TRUE)
+}
+accumulate_right <- function(.x, .f, ..., .init) {
+  f <- function(x, y) .f(y, x, ...)
+  Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE)
+}
+
+detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) {
+  .p <- as_function(.p, env = global_env())
+  .f <- as_function(.f, env = global_env())
+
+  for (i in .rlang_purrr_index(.x, .right)) {
+    if (.p(.f(.x[[i]], ...))) {
+      return(.x[[i]])
+    }
+  }
+  NULL
+}
+detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) {
+  .p <- as_function(.p, env = global_env())
+  .f <- as_function(.f, env = global_env())
+
+  for (i in .rlang_purrr_index(.x, .right)) {
+    if (.p(.f(.x[[i]], ...))) {
+      return(i)
+    }
+  }
+  0L
+}
+.rlang_purrr_index <- function(x, right = FALSE) {
+  idx <- seq_along(x)
+  if (right) {
+    idx <- rev(idx)
+  }
+  idx
+}
+
+list_c <- function(x) {
+  inject(c(!!!x))
+}
+
+# nocov end

R/run-examples.R

@@ -102,7 +102,7 @@ run_examples <- function(
   load_all(pkg$path, reset = TRUE, export_all = FALSE, helpers = FALSE)
   on.exit(load_all(pkg$path, reset = TRUE))
 
-  lapply(
+  walk(
     files,
     pkgload::run_example,
     run_donttest = run_donttest,

R/session-info.R

@@ -20,11 +20,7 @@ loaded_packages <- function() {
 #' @export
 #' @keywords internal
 dev_packages <- function() {
-  packages <- vapply(
-    loadedNamespaces(),
-    function(x) !is.null(pkgload::dev_meta(x)),
-    logical(1)
-  )
+  packages <- map_lgl(loadedNamespaces(), \(x) !is.null(pkgload::dev_meta(x)))
 
   names(packages)[packages]
 }

R/sitrep.R

@@ -53,8 +53,8 @@ check_for_rstudio_updates <- function(
     return()
   }
 
-  nms <- vcapply(result, `[[`, 1)
-  values <- vcapply(result, function(x) utils::URLdecode(x[[2]]))
+  nms <- map_chr(result, `[[`, 1)
+  values <- map_chr(result, function(x) utils::URLdecode(x[[2]]))
 
   result <- stats::setNames(values, nms)
 

R/utils.R

@@ -1,9 +1,3 @@
-compact <- function(x) {
-  x[lengths(x) > 0]
-}
-
-"%||%" <- function(a, b) if (!is.null(a)) a else b
-
 "%:::%" <- function(p, f) {
   get(f, envir = asNamespace(p))
 }
@@ -26,10 +20,6 @@ is_attached <- function(pkg = ".") {
   !is.null(pkgload::pkg_env(pkg$package))
 }
 
-vcapply <- function(x, FUN, ...) {
-  vapply(x, FUN, FUN.VALUE = character(1), ...)
-}
-
 release_bullets <- function() {
   c(
     '`usethis::use_latest_dependencies(TRUE, "CRAN")`',

R/vignettes.R

@@ -122,7 +122,7 @@ clean_vignettes <- function(pkg = ".") {
     file_delete(to_remove)
   }
 
-  lapply(c(doc_path, meta_path), dir_delete_if_empty)
+  walk(c(doc_path, meta_path), dir_delete_if_empty)
 
   invisible(TRUE)
 }