|
| 1 | +# Standalone file: do not edit by hand |
| 2 | +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-purrr.R |
| 3 | +# Generated by: usethis::use_standalone("r-lib/rlang", "purrr") |
| 4 | +# ---------------------------------------------------------------------- |
| 5 | +# |
| 6 | +# --- |
| 7 | +# repo: r-lib/rlang |
| 8 | +# file: standalone-purrr.R |
| 9 | +# last-updated: 2023-02-23 |
| 10 | +# license: https://unlicense.org |
| 11 | +# imports: rlang |
| 12 | +# --- |
| 13 | +# |
| 14 | +# This file provides a minimal shim to provide a purrr-like API on top of |
| 15 | +# base R functions. They are not drop-in replacements but allow a similar style |
| 16 | +# of programming. |
| 17 | +# |
| 18 | +# ## Changelog |
| 19 | +# |
| 20 | +# 2023-02-23: |
| 21 | +# * Added `list_c()` |
| 22 | +# |
| 23 | +# 2022-06-07: |
| 24 | +# * `transpose()` is now more consistent with purrr when inner names |
| 25 | +# are not congruent (#1346). |
| 26 | +# |
| 27 | +# 2021-12-15: |
| 28 | +# * `transpose()` now supports empty lists. |
| 29 | +# |
| 30 | +# 2021-05-21: |
| 31 | +# * Fixed "object `x` not found" error in `imap()` (@mgirlich) |
| 32 | +# |
| 33 | +# 2020-04-14: |
| 34 | +# * Removed `pluck*()` functions |
| 35 | +# * Removed `*_cpl()` functions |
| 36 | +# * Used `as_function()` to allow use of `~` |
| 37 | +# * Used `.` prefix for helpers |
| 38 | +# |
| 39 | +# nocov start |
| 40 | + |
| 41 | +map <- function(.x, .f, ...) { |
| 42 | + .f <- as_function(.f, env = global_env()) |
| 43 | + lapply(.x, .f, ...) |
| 44 | +} |
| 45 | +walk <- function(.x, .f, ...) { |
| 46 | + map(.x, .f, ...) |
| 47 | + invisible(.x) |
| 48 | +} |
| 49 | + |
| 50 | +map_lgl <- function(.x, .f, ...) { |
| 51 | + .rlang_purrr_map_mold(.x, .f, logical(1), ...) |
| 52 | +} |
| 53 | +map_int <- function(.x, .f, ...) { |
| 54 | + .rlang_purrr_map_mold(.x, .f, integer(1), ...) |
| 55 | +} |
| 56 | +map_dbl <- function(.x, .f, ...) { |
| 57 | + .rlang_purrr_map_mold(.x, .f, double(1), ...) |
| 58 | +} |
| 59 | +map_chr <- function(.x, .f, ...) { |
| 60 | + .rlang_purrr_map_mold(.x, .f, character(1), ...) |
| 61 | +} |
| 62 | +.rlang_purrr_map_mold <- function(.x, .f, .mold, ...) { |
| 63 | + .f <- as_function(.f, env = global_env()) |
| 64 | + out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) |
| 65 | + names(out) <- names(.x) |
| 66 | + out |
| 67 | +} |
| 68 | + |
| 69 | +map2 <- function(.x, .y, .f, ...) { |
| 70 | + .f <- as_function(.f, env = global_env()) |
| 71 | + out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) |
| 72 | + if (length(out) == length(.x)) { |
| 73 | + set_names(out, names(.x)) |
| 74 | + } else { |
| 75 | + set_names(out, NULL) |
| 76 | + } |
| 77 | +} |
| 78 | +map2_lgl <- function(.x, .y, .f, ...) { |
| 79 | + as.vector(map2(.x, .y, .f, ...), "logical") |
| 80 | +} |
| 81 | +map2_int <- function(.x, .y, .f, ...) { |
| 82 | + as.vector(map2(.x, .y, .f, ...), "integer") |
| 83 | +} |
| 84 | +map2_dbl <- function(.x, .y, .f, ...) { |
| 85 | + as.vector(map2(.x, .y, .f, ...), "double") |
| 86 | +} |
| 87 | +map2_chr <- function(.x, .y, .f, ...) { |
| 88 | + as.vector(map2(.x, .y, .f, ...), "character") |
| 89 | +} |
| 90 | +imap <- function(.x, .f, ...) { |
| 91 | + map2(.x, names(.x) %||% seq_along(.x), .f, ...) |
| 92 | +} |
| 93 | + |
| 94 | +pmap <- function(.l, .f, ...) { |
| 95 | + .f <- as.function(.f) |
| 96 | + args <- .rlang_purrr_args_recycle(.l) |
| 97 | + do.call( |
| 98 | + "mapply", |
| 99 | + c( |
| 100 | + FUN = list(quote(.f)), |
| 101 | + args, |
| 102 | + MoreArgs = quote(list(...)), |
| 103 | + SIMPLIFY = FALSE, |
| 104 | + USE.NAMES = FALSE |
| 105 | + ) |
| 106 | + ) |
| 107 | +} |
| 108 | +.rlang_purrr_args_recycle <- function(args) { |
| 109 | + lengths <- map_int(args, length) |
| 110 | + n <- max(lengths) |
| 111 | + |
| 112 | + stopifnot(all(lengths == 1L | lengths == n)) |
| 113 | + to_recycle <- lengths == 1L |
| 114 | + args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) |
| 115 | + |
| 116 | + args |
| 117 | +} |
| 118 | + |
| 119 | +keep <- function(.x, .f, ...) { |
| 120 | + .x[.rlang_purrr_probe(.x, .f, ...)] |
| 121 | +} |
| 122 | +discard <- function(.x, .p, ...) { |
| 123 | + sel <- .rlang_purrr_probe(.x, .p, ...) |
| 124 | + .x[is.na(sel) | !sel] |
| 125 | +} |
| 126 | +map_if <- function(.x, .p, .f, ...) { |
| 127 | + matches <- .rlang_purrr_probe(.x, .p) |
| 128 | + .x[matches] <- map(.x[matches], .f, ...) |
| 129 | + .x |
| 130 | +} |
| 131 | +.rlang_purrr_probe <- function(.x, .p, ...) { |
| 132 | + if (is_logical(.p)) { |
| 133 | + stopifnot(length(.p) == length(.x)) |
| 134 | + .p |
| 135 | + } else { |
| 136 | + .p <- as_function(.p, env = global_env()) |
| 137 | + map_lgl(.x, .p, ...) |
| 138 | + } |
| 139 | +} |
| 140 | + |
| 141 | +compact <- function(.x) { |
| 142 | + .x[as.logical(lengths(.x))] |
| 143 | +} |
| 144 | + |
| 145 | +transpose <- function(.l) { |
| 146 | + if (!length(.l)) { |
| 147 | + return(.l) |
| 148 | + } |
| 149 | + |
| 150 | + inner_names <- names(.l[[1]]) |
| 151 | + |
| 152 | + if (is.null(inner_names)) { |
| 153 | + fields <- seq_along(.l[[1]]) |
| 154 | + } else { |
| 155 | + fields <- set_names(inner_names) |
| 156 | + .l <- map(.l, function(x) { |
| 157 | + if (is.null(names(x))) { |
| 158 | + set_names(x, inner_names) |
| 159 | + } else { |
| 160 | + x |
| 161 | + } |
| 162 | + }) |
| 163 | + } |
| 164 | + |
| 165 | + # This way missing fields are subsetted as `NULL` instead of causing |
| 166 | + # an error |
| 167 | + .l <- map(.l, as.list) |
| 168 | + |
| 169 | + map(fields, function(i) { |
| 170 | + map(.l, .subset2, i) |
| 171 | + }) |
| 172 | +} |
| 173 | + |
| 174 | +every <- function(.x, .p, ...) { |
| 175 | + .p <- as_function(.p, env = global_env()) |
| 176 | + |
| 177 | + for (i in seq_along(.x)) { |
| 178 | + if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) |
| 179 | + } |
| 180 | + TRUE |
| 181 | +} |
| 182 | +some <- function(.x, .p, ...) { |
| 183 | + .p <- as_function(.p, env = global_env()) |
| 184 | + |
| 185 | + for (i in seq_along(.x)) { |
| 186 | + if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) |
| 187 | + } |
| 188 | + FALSE |
| 189 | +} |
| 190 | +negate <- function(.p) { |
| 191 | + .p <- as_function(.p, env = global_env()) |
| 192 | + function(...) !.p(...) |
| 193 | +} |
| 194 | + |
| 195 | +reduce <- function(.x, .f, ..., .init) { |
| 196 | + f <- function(x, y) .f(x, y, ...) |
| 197 | + Reduce(f, .x, init = .init) |
| 198 | +} |
| 199 | +reduce_right <- function(.x, .f, ..., .init) { |
| 200 | + f <- function(x, y) .f(y, x, ...) |
| 201 | + Reduce(f, .x, init = .init, right = TRUE) |
| 202 | +} |
| 203 | +accumulate <- function(.x, .f, ..., .init) { |
| 204 | + f <- function(x, y) .f(x, y, ...) |
| 205 | + Reduce(f, .x, init = .init, accumulate = TRUE) |
| 206 | +} |
| 207 | +accumulate_right <- function(.x, .f, ..., .init) { |
| 208 | + f <- function(x, y) .f(y, x, ...) |
| 209 | + Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) |
| 210 | +} |
| 211 | + |
| 212 | +detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) { |
| 213 | + .p <- as_function(.p, env = global_env()) |
| 214 | + .f <- as_function(.f, env = global_env()) |
| 215 | + |
| 216 | + for (i in .rlang_purrr_index(.x, .right)) { |
| 217 | + if (.p(.f(.x[[i]], ...))) { |
| 218 | + return(.x[[i]]) |
| 219 | + } |
| 220 | + } |
| 221 | + NULL |
| 222 | +} |
| 223 | +detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { |
| 224 | + .p <- as_function(.p, env = global_env()) |
| 225 | + .f <- as_function(.f, env = global_env()) |
| 226 | + |
| 227 | + for (i in .rlang_purrr_index(.x, .right)) { |
| 228 | + if (.p(.f(.x[[i]], ...))) { |
| 229 | + return(i) |
| 230 | + } |
| 231 | + } |
| 232 | + 0L |
| 233 | +} |
| 234 | +.rlang_purrr_index <- function(x, right = FALSE) { |
| 235 | + idx <- seq_along(x) |
| 236 | + if (right) { |
| 237 | + idx <- rev(idx) |
| 238 | + } |
| 239 | + idx |
| 240 | +} |
| 241 | + |
| 242 | +list_c <- function(x) { |
| 243 | + inject(c(!!!x)) |
| 244 | +} |
| 245 | + |
| 246 | +# nocov end |
0 commit comments