From dd6bb00444b46389c5e4e483d4d2ca35fc0dde8c Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 12 Feb 2026 17:20:41 -0600 Subject: [PATCH] Use standalone purrr file --- R/check-devtools.R | 8 +- R/check-doc.R | 10 +- R/check-mac.R | 2 +- R/check-win.R | 4 +- R/dev-mode.R | 2 +- R/import-standalone-purrr.R | 246 ++++++++++++++++++++++++++++++++++++ R/run-examples.R | 2 +- R/session-info.R | 6 +- R/sitrep.R | 4 +- R/utils.R | 10 -- R/vignettes.R | 2 +- 11 files changed, 264 insertions(+), 32 deletions(-) create mode 100644 R/import-standalone-purrr.R diff --git a/R/check-devtools.R b/R/check-devtools.R index 29e767b2c..04ddad1e4 100644 --- a/R/check-devtools.R +++ b/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), diff --git a/R/check-doc.R b/R/check-doc.R index 8191fc921..bcb8ecba2 100644 --- a/R/check-doc.R +++ b/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] }) diff --git a/R/check-mac.R b/R/check-mac.R index 4b3ab098d..9b2070e7f 100644 --- a/R/check-mac.R +++ b/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) } diff --git a/R/check-win.R b/R/check-win.R index e1d0e29f0..11bd586d2 100644 --- a/R/check-win.R +++ b/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) diff --git a/R/dev-mode.R b/R/dev-mode.R index 01122dc2d..09c4c2a87 100644 --- a/R/dev-mode.R +++ b/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) } diff --git a/R/import-standalone-purrr.R b/R/import-standalone-purrr.R new file mode 100644 index 000000000..85a185f30 --- /dev/null +++ b/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 diff --git a/R/run-examples.R b/R/run-examples.R index a3c47216c..e2313c8fe 100644 --- a/R/run-examples.R +++ b/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, diff --git a/R/session-info.R b/R/session-info.R index 4223379b1..df91a1f42 100644 --- a/R/session-info.R +++ b/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] } diff --git a/R/sitrep.R b/R/sitrep.R index c37adbaff..933b3f55b 100644 --- a/R/sitrep.R +++ b/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) diff --git a/R/utils.R b/R/utils.R index 6e68356f4..4fb9e981c 100644 --- a/R/utils.R +++ b/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")`', diff --git a/R/vignettes.R b/R/vignettes.R index 453f54424..747d608b9 100644 --- a/R/vignettes.R +++ b/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) }