From dd35867acdba23bdc335f609ac9848a59e832615 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Sun, 5 Nov 2023 06:19:22 +0100 Subject: [PATCH] chore: Use `check_suggested()` --- R/helper-read.R | 2 + R/import-standalone-check_suggested.R | 83 +++++++++ R/import-standalone-purrr.R | 239 ++++++++++++++++++++++++++ man/munch-package.Rd | 2 +- 4 files changed, 325 insertions(+), 1 deletion(-) create mode 100644 R/import-standalone-check_suggested.R create mode 100644 R/import-standalone-purrr.R diff --git a/R/helper-read.R b/R/helper-read.R index d0c0a5b..3dca9d3 100644 --- a/R/helper-read.R +++ b/R/helper-read.R @@ -2,6 +2,8 @@ #' #' @export swc_read_data <- function() { + check_suggested(c("rvest", "xml2"), "swc_read_data") + bfs_nr <- "dz-b-00.04-hgv-01" bfs_home <- "https://www.bfs.admin.ch" diff --git a/R/import-standalone-check_suggested.R b/R/import-standalone-check_suggested.R new file mode 100644 index 0000000..254c461 --- /dev/null +++ b/R/import-standalone-check_suggested.R @@ -0,0 +1,83 @@ +# Standalone file: do not edit by hand +# Source: +# Generated by `usethis::use_standalone("cynkra/dm", "standalone-check_suggested.R", "HEAD", "https://github.com")` +# ---------------------------------------------------------------------- +# +# --- +# repo: cynkra/dm +# file: standalone-check_suggested.R +# last-updated: 2023-02-23 +# license: https://unlicense.org +# imports: rlang +# --- +# +# This file provides a wrapper around `rlang::check_installed()` that skips tests +# and supports optional usage. +# +# Needs functions from rlang, and purrr or standalone-purrr.R. +# +# ## Changelog +# +# 2023-10-19: +# * Initial + +# nocov start + +#' Check if suggested package is installed +#' +#' @param packages Vector of package names to check. Can supply a version +#' between parenthesis. (See examples). +#' @param top_level_fun the name of the top level function called. +#' @param use whether to trigger the check, `NA` means `TRUE` if `is_interactive()` +#' and `FALSE` otherwise +#' @return whether check was triggered and all packages are installed +#' @noRd +#' @examples +#' check_suggested(c("testthat (>= 3.2.0)", "xxx"), "foo") +check_suggested <- function(packages, top_level_fun, use = TRUE) { + # If NA, inform that package isn't installed, but only in interactive mode + only_msg <- is.na(use) + if (only_msg) { + use <- is_interactive() + } + + if (!use) { + return(FALSE) + } + + # Check installation status if `use` was not `FALSE` + installed <- map_lgl(packages, is_installed) + + if (all(installed)) { + return(TRUE) + } + + if (only_msg) { + pkgs_not_installed <- packages[!installed] + message <- "{.fn {top_level_fun}} is improved by the {.pkg {.val {pkgs_not_installed}}} package{?s}. Consider installing {?it/them}." + cli::cli_inform(message) + + return(FALSE) + } + + # Skip if some packages are not installed when testing + # And say which package was not installed. + if (identical(Sys.getenv("TESTTHAT"), "true")) { + pkgs_not_installed <- packages[!installed] + message <- cli::format_inline("{.fn {top_level_fun}} needs the {.pkg {.val {pkgs_not_installed}}} package{?s}.") + testthat::skip(message) + } + + # If in interactive session, a prompt will ask user if they want + # to install the package. + # check_installed() uses pak for installation + # if it's installed on the user system. + + # Which message to display in the prompt + check_installed(packages, reason = glue("to use `{top_level_fun}()`.")) + + # If check_installed() returns, all packages are installed + TRUE +} + +# nocov end diff --git a/R/import-standalone-purrr.R b/R/import-standalone-purrr.R new file mode 100644 index 0000000..33b0fc5 --- /dev/null +++ b/R/import-standalone-purrr.R @@ -0,0 +1,239 @@ +# Standalone file: do not edit by hand +# ---------------------------------------------------------------------- +# +# --- +# 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) { + 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 <- 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/man/munch-package.Rd b/man/munch-package.Rd index 34eec70..b59a670 100644 --- a/man/munch-package.Rd +++ b/man/munch-package.Rd @@ -45,7 +45,7 @@ URL: \url{https://github.com/cynkra/munch} Issue tracker: \url{https://github.com/cynkra/munch/issues} -\strong{Maintainer}: Kirill Müller \email{krlmlr+r@mailbox.org} +\strong{Maintainer}: Kirill Müller \email{kirill@cynkra.com} Authors: \itemize{