diff --git a/DESCRIPTION b/DESCRIPTION index 7fb39554..1c0556e0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -48,7 +48,6 @@ Imports: jsonlite, pkgbuild (>= 1.4.0), processx, - purrr, rlang (>= 1.0.5), rprojroot, stringi, @@ -72,4 +71,3 @@ Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 SystemRequirements: Rust 'cargo'; the crate 'libR-sys' must compile without error -Config/rextendr/version: 0.3.1.9001 diff --git a/NAMESPACE b/NAMESPACE index a5420ce8..8570dae7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -30,14 +30,6 @@ importFrom(dplyr,"%>%") importFrom(dplyr,mutate) importFrom(glue,glue) importFrom(glue,glue_collapse) -importFrom(purrr,discard) -importFrom(purrr,every) -importFrom(purrr,flatten_chr) -importFrom(purrr,map) -importFrom(purrr,map2) -importFrom(purrr,map2_chr) -importFrom(purrr,map_if) -importFrom(purrr,map_lgl) importFrom(rlang,"%||%") importFrom(rlang,.data) importFrom(rlang,.env) diff --git a/NEWS.md b/NEWS.md index 81bc493e..73280190 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # rextendr (development version) +* `purrr` has been replaced with [`R/standalone-purrr.R`](https://github.com/r-lib/rlang/blob/main/R/standalone-purrr.R) removing `purrr` from `Imports` * `document()` will no longer try to save all open files using rstudioapi * `use_cran_default()` has been removed as the default package template is CRAN compatible * `use_extendr()` now creates `tools/msrv.R`, `configure` and `configure.win`. These have been moved out of `use_cran_defaults()` diff --git a/R/create_extendr_package.R b/R/create_extendr_package.R index e970b9ce..e66dee94 100644 --- a/R/create_extendr_package.R +++ b/R/create_extendr_package.R @@ -25,7 +25,7 @@ create_extendr_package <- function(path, ...) { if (rlang::is_string(x) && nzchar(x)) x else NULL } - args <- purrr::map(args, nullify_empty_string) + args <- map(args, nullify_empty_string) # build package directory, but don't start a new R session with # it as the working directory! i.e., set `open = FALSE` diff --git a/R/eval.R b/R/eval.R index 71ddd299..abd676f1 100644 --- a/R/eval.R +++ b/R/eval.R @@ -119,7 +119,7 @@ fn {fn_name}() -> Result {{ #' `NULL` if no such dll is loaded. #' @noRd find_loaded_dll <- function(name) { - dlls <- purrr::keep(getLoadedDLLs(), ~ .x[["name"]] == name) + dlls <- keep(getLoadedDLLs(), ~ .x[["name"]] == name) if (rlang::is_empty(dlls)) { NULL } else { diff --git a/R/find_exports.R b/R/find_exports.R index 71727e10..6356d0cb 100644 --- a/R/find_exports.R +++ b/R/find_exports.R @@ -8,7 +8,7 @@ find_exports <- function(clean_lns) { return(tibble::tibble(name = character(0), type = character(0), lifetime = character(0))) } - purrr::map2(start, end, ~ extract_meta(clean_lns[.x:.y])) %>% + map2(start, end, ~ extract_meta(clean_lns[.x:.y])) %>% dplyr::bind_rows() %>% dplyr::mutate(type = dplyr::coalesce(.data$impl, .data$fn)) %>% dplyr::select(dplyr::all_of(c("name", "type", "lifetime"))) diff --git a/R/function_options.R b/R/function_options.R index c5d7c0c1..e3df302c 100644 --- a/R/function_options.R +++ b/R/function_options.R @@ -27,21 +27,21 @@ convert_function_options <- function(options, suppress_warnings) { options_table <- tibble::tibble(Name = rlang::names2(options), Value = unname(options)) %>% dplyr::left_join(extendr_function_config$known_options, by = "Name") %>% dplyr::mutate( - Value = purrr::pmap( + Value = pmap( list(.data$Value, .data$Ptype, .data$Name), ~ if (rlang::is_null(..2)) ..1 else vctrs::vec_cast(..1, ..2, x_arg = ..3) ), ) unknown_option_names <- options_table %>% - dplyr::filter(purrr::map_lgl(.data$Ptype, rlang::is_null)) %>% + dplyr::filter(map_lgl(.data$Ptype, rlang::is_null)) %>% dplyr::pull(.data$Name) invalid_options <- options_table %>% dplyr::mutate( IsNameInvalid = !is_valid_rust_name(.data$Name), - IsValueNull = purrr::map_lgl(.data$Value, rlang::is_null), - IsNotScalar = !.data$IsValueNull & !purrr::map_lgl(.data$Value, vctrs::vec_is, size = 1L) + IsValueNull = map_lgl(.data$Value, rlang::is_null), + IsNotScalar = !.data$IsValueNull & !map_lgl(.data$Value, vctrs::vec_is, size = 1L) ) %>% dplyr::filter( .data$IsNameInvalid | .data$IsValueNull | .data$IsNotScalar @@ -59,7 +59,7 @@ convert_function_options <- function(options, suppress_warnings) { options_table %>% dplyr::transmute( .data$Name, - RustValue = purrr::map_chr(.data$Value, convert_option_to_rust) + RustValue = map_chr(.data$Value, convert_option_to_rust) ) } diff --git a/R/generate_toml.R b/R/generate_toml.R index 39de1845..8010d905 100644 --- a/R/generate_toml.R +++ b/R/generate_toml.R @@ -3,6 +3,17 @@ generate_cargo.toml <- function(libname = "rextendr", patch.crates_io = NULL, extendr_deps = NULL, features = character(0)) { + + # create an empty list if no dependencies are provided + deps <- dependencies %||% list() + # enabled extendr features that we need to impute into all of the + # dependencies + to_impute <- enable_features(extendr_deps, features) + + for (.name in names(to_impute)) { + deps[[.name]] <- to_impute[[.name]] + } + to_toml( package = list( name = libname, @@ -13,10 +24,7 @@ generate_cargo.toml <- function(libname = "rextendr", lib = list( `crate-type` = array("cdylib", 1) ), - dependencies = purrr::list_modify( - dependencies %||% list(), - !!!enable_features(extendr_deps, features) - ), + dependencies = deps, `patch.crates-io` = patch.crates_io, `profile.perf` = list( inherits = "release", diff --git a/R/rextendr.R b/R/rextendr.R index 09aee13d..f8b26d4b 100644 --- a/R/rextendr.R +++ b/R/rextendr.R @@ -7,7 +7,6 @@ "_PACKAGE" #' @importFrom dplyr mutate %>% -#' @importFrom purrr map2 map2_chr map_lgl flatten_chr map_if every map discard #' @importFrom glue glue glue_collapse #' @importFrom rlang dots_list names2 as_function is_missing is_atomic is_null #' @importFrom rlang is_na .data .env caller_env as_name as_label enquo %||% diff --git a/R/sanitize_code.R b/R/sanitize_code.R index 368e1d87..cfcb88fa 100644 --- a/R/sanitize_code.R +++ b/R/sanitize_code.R @@ -35,8 +35,8 @@ fill_block_comments <- function(lns, fill_with = " ") { # nolint: object_usage_l # A sorted DF having `start`, `end`, and `type` comment_syms <- locations %>% - purrr::map(tibble::as_tibble) %>% - purrr::imap( + map(tibble::as_tibble) %>% + imap( ~ dplyr::mutate( .x, type = dplyr::if_else(.y == 1L, "open", "close") @@ -136,20 +136,16 @@ fill_block_comments <- function(lns, fill_with = " ") { # nolint: object_usage_l # of the same length -- this is needed to preserve line length # and previously computed positions, and it does not affect # parsing at later stages. - result <- purrr::reduce2( - to_replace[["start_open"]], - to_replace[["end_close"]], - function(ln, from, to) { - stringi::stri_sub( - ln, - from, - to, - ) <- strrep(fill_with, to - from + 1L) - ln - }, - .init = lns - ) + .open <- to_replace[["start_open"]] + .close <- to_replace[["end_close"]] + gap_size <- (.close - .open) + 1 + result <- stringi::stri_sub_replace_all( + lns, + .open, + .close, + replacement = strrep(fill_with, gap_size) + ) result <- stringi::stri_split_lines(result, omit_empty = TRUE)[[1]] result diff --git a/R/source.R b/R/source.R index 8ec5adb5..d4ad449a 100644 --- a/R/source.R +++ b/R/source.R @@ -404,10 +404,10 @@ invoke_cargo <- function(toolchain, specific_target, dir, profile, gather_cargo_output <- function(json_output, level, tty_has_colors) { rendered_output <- json_output %>% - purrr::keep( + keep( ~ .x$reason == "compiler-message" && .x$message$level == level ) %>% - purrr::map_chr(~ .x$message$rendered) + map_chr(~ .x$message$rendered) if (!tty_has_colors) { rendered_output <- cli::ansi_strip(rendered_output) @@ -433,7 +433,7 @@ gather_cargo_output <- function(json_output, level, tty_has_colors) { #' @param call Caller environment used for error message formatting. #' @noRd check_cargo_output <- function(compilation_result, message_buffer, tty_has_colors, quiet, call = caller_env()) { - cargo_output <- purrr::map( + cargo_output <- map( message_buffer, jsonlite::parse_json ) @@ -445,7 +445,7 @@ check_cargo_output <- function(compilation_result, message_buffer, tty_has_color "error", tty_has_colors ) %>% - purrr::map_chr( + map_chr( cli::format_inline, keep_whitespace = TRUE ) %>% diff --git a/R/standalone-purrr.R b/R/standalone-purrr.R new file mode 100644 index 00000000..f9322322 --- /dev/null +++ b/R/standalone-purrr.R @@ -0,0 +1,236 @@ +# --- +# 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 <- rlang::as_function(.f, env = rlang::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 <- rlang::as_function(.f, env = rlang::global_env()) + out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) + names(out) <- names(.x) + out +} + +map2 <- function(.x, .y, .f, ...) { + .f <- rlang::as_function(.f, env = rlang::global_env()) + out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) + if (length(out) == length(.x)) { + rlang::set_names(out, names(.x)) + } else { + rlang::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 <- rlang::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 (rlang::is_logical(.p)) { + stopifnot(length(.p) == length(.x)) + .p + } else { + .p <- rlang::as_function(.p, env = rlang::global_env()) + map_lgl(.x, .p, ...) + } +} + +compact <- function(.x) { + Filter(length, .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 <- rlang::set_names(inner_names) + .l <- map(.l, function(x) { + if (is.null(names(x))) { + rlang::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 <- rlang::as_function(.p, env = rlang::global_env()) + + for (i in seq_along(.x)) { + if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) + } + TRUE +} +some <- function(.x, .p, ...) { + .p <- rlang::as_function(.p, env = rlang::global_env()) + + for (i in seq_along(.x)) { + if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) + } + FALSE +} +negate <- function(.p) { + .p <- rlang::as_function(.p, env = rlang::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 = rlang::is_true) { + .p <- rlang::as_function(.p, env = rlang::global_env()) + .f <- rlang::as_function(.f, env = rlang::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 = rlang::is_true) { + .p <- rlang::as_function(.p, env = rlang::global_env()) + .f <- rlang::as_function(.f, env = rlang::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) { + rlang::inject(c(!!!x)) +} + +# nocov end diff --git a/R/toml_serialization.R b/R/toml_serialization.R index 3f664c33..b6211912 100644 --- a/R/toml_serialization.R +++ b/R/toml_serialization.R @@ -41,7 +41,7 @@ to_toml <- function(..., names <- names2(args) # We disallow unnamed top-level atomic arguments - invalid <- which(purrr::map2_lgl(names, args, ~ !nzchar(.x) && is.atomic(.y))) + invalid <- which(map2_lgl(names, args, ~ !nzchar(.x) && is.atomic(.y))) # If such args found, display an error message if (length(invalid) > 0) { @@ -55,7 +55,7 @@ to_toml <- function(..., ) } - tables <- map2_chr(names, args, function(nm, a) { + tables <- map2(names, args, function(nm, a) { header <- make_header(nm, a) body <- format_toml( a, @@ -75,6 +75,7 @@ to_toml <- function(..., # remove them by `c()` first, and then concatenate by "\n" if both exists glue_collapse(c(header, body), "\n") }) + glue_collapse(tables, "\n\n") } @@ -97,7 +98,7 @@ simplify_row <- function(row) { result <- map_if( row, ~ is.list(.x) && all(!nzchar(names2(.x))), - ~ .x[[1]], + ~ .x[1], .else = ~.x ) discard( @@ -134,20 +135,21 @@ format_toml.data.frame <- function(x, if (length(item) == 0L) { result <- character(0) } else { + result <- format_toml( - item, + as.list(item), ..., .top_level = TRUE ) } if (!is_atomic(result)) { - result <- flatten_chr(result) + result <- list_c(result) } c(header, result) } ) - flatten_chr(result) + list_c(result) } # This handles missing args @@ -200,7 +202,7 @@ format_toml_atomic <- function(x, if (len == 0L) { "[ ]" } else { - formatter <- as_function(.formatter) + formatter <- rlang::as_function(.formatter) items <- glue_collapse(formatter(x, ...), ", ") if (len > 1L || !is.null(dims)) { items <- glue("[ {items} ]") @@ -296,7 +298,7 @@ format_toml.list <- function(x, ..., .top_level = FALSE) { result <- glue("{{ {paste0(result, collapse = \", \")} }}") } if (!is_atomic(result)) { - result <- flatten_chr(result) + result <- list_c(result) } # Ensure type-stability as.character(result) diff --git a/R/track_rust_source.R b/R/track_rust_source.R index dd96b333..dca7e967 100644 --- a/R/track_rust_source.R +++ b/R/track_rust_source.R @@ -87,7 +87,7 @@ pretty_rel_single_path <- function(path, search_from = ".") { #' #' @noRd pretty_rel_path <- function(path, search_from = ".") { - purrr::map_chr(path, pretty_rel_single_path, search_from = search_from) + map_chr(path, pretty_rel_single_path, search_from = search_from) } get_library_path <- function(path = ".") { diff --git a/tests/testthat/test-eval.R b/tests/testthat/test-eval.R index bb9dcb20..45bbdc61 100644 --- a/tests/testthat/test-eval.R +++ b/tests/testthat/test-eval.R @@ -20,12 +20,12 @@ test_that("multiple `rust_eval_deferred()` work correctly", { skip_if_cargo_unavailable() provided_values <- seq_len(5) - deferred_handles <- purrr::map( + deferred_handles <- map( provided_values, ~ rust_eval_deferred(glue::glue("{.x}i32")) ) - obtained_values <- purrr::map_int(deferred_handles, ~ (.x)()) + obtained_values <- map_int(deferred_handles, ~ (.x)()) testthat::expect_equal( obtained_values, @@ -48,14 +48,14 @@ test_that("multiple `rust_eval_deferred()` work correctly in reverse order", { provided_values <- seq_len(5) - deferred_handles <- purrr::map( + deferred_handles <- map( provided_values, ~ rust_eval_deferred(glue::glue("{.x}i32")) ) deferred_handles <- rev(deferred_handles) - obtained_values <- purrr::map_int(deferred_handles, ~ (.x)()) + obtained_values <- map_int(deferred_handles, ~ (.x)()) testthat::expect_equal( obtained_values, @@ -99,13 +99,13 @@ test_that("`rust_eval_deferred()` environment cleanup", { dll_path <- attr(handle, "dll_path") testthat::expect_true(exists(fn_name)) - dlls <- purrr::keep(getLoadedDLLs(), ~ .x[["path"]] == dll_path) + dlls <- keep(getLoadedDLLs(), ~ .x[["path"]] == dll_path) testthat::expect_length(dlls, 1L) testthat::expect_equal(handle(), 42L) testthat::expect_false(exists(fn_name)) - dlls <- purrr::keep(getLoadedDLLs(), ~ .x[["path"]] == dll_path) + dlls <- keep(getLoadedDLLs(), ~ .x[["path"]] == dll_path) testthat::expect_length(dlls, 0L) })