Add action argument to check_installed()

NEWS.md

@@ -77,8 +77,8 @@
   They also gain `version` and `compare` arguments to supply requirements
   programmatically.
 
-* `check_installed()` gains a `src` argument to specificy pak-style
-  sources.
+* `check_installed()` gains an `action` argument that is called when
+  the user chooses to install and update missing and outdated packages.
 
 * `abort()`, `warn()`, and `inform()` gain a `body` argument to supply
   additional bullets in the error message.

R/session.R

@@ -166,15 +166,21 @@ as_version_info <- function(pkg, call = caller_env()) {
 }
 
 #' @rdname is_installed
+#' @param action An optional function taking `pkg` and `...`
+#'   arguments. It is called by `check_installed()` when the user
+#'   chooses to update outdated packages. The function is passed the
+#'   missing and outdated packages as a character vector of names.
 #' @inheritParams args_error_context
 #' @export
 check_installed <- function(pkg,
                             reason = NULL,
                             ...,
                             version = NULL,
                             compare = NULL,
+                            action = NULL,
                             call = caller_env()) {
   check_dots_empty0(...)
+  check_action(action)
 
   info <- pkg_version_info(pkg, version = version, compare = compare)
   needs_install <- !detect_installed(info)
@@ -236,7 +242,10 @@ check_installed <- function(pkg,
     # Pass condition in case caller sets up an `abort` restart
     invokeRestart("abort", cnd)
   }
-  if (is_installed("pak")) {
+
+  if (!is_null(action)) {
+    action(missing_pkgs)
+  } else if (is_installed("pak")) {
     pkg_install <- env_get(ns_env("pak"), "pkg_install")
     pkg_install(missing_pkgs, ask = FALSE)
   } else {
@@ -281,6 +290,27 @@ check_pkg_version <- function(pkg,
   }
 }
 
+check_action <- function(action, call = caller_env()) {
+  # Take `pkg`, `version`, and `compare`?
+  if (!is_null(action)) {
+    if (!is_closure(action)) {
+      msg <- sprintf(
+        "%s must `NULL` or a function.",
+        format_arg("action")
+      )
+      abort(msg, call = call)
+    }
+    if (!"..." %in% names(formals(action))) {
+      msg <- sprintf(
+        "%s must take a %s argument.",
+        format_arg("action"),
+        format_arg("...")
+      )
+      abort(msg, call = call)
+    }
+  }
+}
+
 new_error_package_not_found <- function(pkg,
                                         version = NULL,
                                         compare = NULL,

tests/testthat/_snaps/session.md

@@ -145,3 +145,16 @@
       <error/rlang_error>
       Error in `caller()`: `compare` must be one of ">", ">=", "<", or "<=".
 
+# `action` is checked
+
+    Code
+      err(check_installed("foo", action = "identity"))
+    Output
+      <error/rlang_error>
+      Error in `check_installed()`: `action` must `NULL` or a function.
+    Code
+      err(check_installed("foo", action = identity))
+    Output
+      <error/rlang_error>
+      Error in `check_installed()`: `action` must take a `...` argument.
+

tests/testthat/test-session.R

@@ -197,3 +197,10 @@ test_that("pkg_version_info() supports `cmp`", {
     err(pkg_version_info("foo", "1.0", "!="))
   })
 })
+
+test_that("`action` is checked", {
+  expect_snapshot({
+    err(check_installed("foo", action = "identity"))
+    err(check_installed("foo", action = identity))
+  })
+})