Merge pull request #477 from r-dbi/b-hms

chore: Use `check_suggested()` standalone for hms package

DESCRIPTION

@@ -38,7 +38,8 @@ Imports:
     DBI (>= 1.1.0),
     memoise,
     methods,
-    pkgconfig
+    pkgconfig,
+    rlang
 Suggests: 
     callr,
     DBItest (>= 1.7.2.9001),
@@ -47,7 +48,6 @@ Suggests:
     hms,
     knitr,
     magrittr,
-    rlang,
     rmarkdown,
     rvest,
     testthat (>= 3.0.0),
@@ -119,6 +119,8 @@ Collate:
     'deprecated.R'
     'export.R'
     'fetch_SQLiteResult.R'
+    'import-standalone-check_suggested.R'
+    'import-standalone-purrr.R'
     'initExtension.R'
     'initRegExp.R'
     'isSQLKeyword_SQLiteConnection_character.R'

NAMESPACE

@@ -73,6 +73,7 @@ exportMethods(show)
 exportMethods(sqlData)
 import(DBI)
 import(methods)
+import(rlang)
 importFrom(bit64,integer64)
 importFrom(bit64,is.integer64)
 importFrom(blob,blob)

R/dbConnect_SQLiteDriver.R

@@ -106,9 +106,7 @@ dbConnect_SQLiteDriver <- function(drv, dbname = "", ..., loadable.extensions =
 
   extended_types <- isTRUE(extended_types)
   if (extended_types) {
-    if (!requireNamespace("hms", quietly = TRUE)) {
-      stopc("Install the hms package for `extended_types = TRUE`.")
-    }
+    check_suggested("hms", "dbConnect")
   }
   conn <- new("SQLiteConnection",
     ptr = connection_connect(dbname, loadable.extensions, flags, vfs, extended_types),

R/import-standalone-check_suggested.R

@@ -0,0 +1,79 @@
+# Standalone file: do not edit by hand
+# Source: <https://https://github.com/cynkra/dm/blob/HEAD/R/standalone-check_suggested.R>
+# 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, cli, glue
+# ---
+#
+# 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 <- rlang::is_interactive()
+  }
+
+  if (!use) {
+    return(FALSE)
+  }
+
+  # Check installation status if `use` was not `FALSE`
+  installed <- map_lgl(packages, rlang::is_installed)
+
+  if (all(installed)) {
+    return(TRUE)
+  }
+
+  if (only_msg) {
+    stopc("NYI")
+  }
+
+  # 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 <- "{.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
+  rlang::check_installed(packages, reason = paste0("to use `", top_level_fun, "()`."))
+
+  # If check_installed() returns, all packages are installed
+  TRUE
+}
+
+# nocov end

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