Update pacage installation process

R/checker.R

@@ -82,6 +82,11 @@ checker <- R6::R6Class(
     #' @param restore `logical` value, whether output directory should be
     #'   unlinked before running checks. If `FALSE`, an attempt will me made to
     #'   restore previous progress from the same `output`.
+    #' @param dependencies A vector of length one or a named list.
+    #'  Compatible with [`as_pkg_dependencies`].
+    #' @param upgrade `logical` value, whether packages should be upgraded
+    #'  if more recent version is discovered in available sources. Remotes
+    #'  packages, if allowed to be used, are always installed and prioritized.
     #' @param ... Additional arguments unused
     #'
     #' @return [checker].
@@ -95,6 +100,8 @@ checker <- R6::R6Class(
       lib.loc = .libPaths(),
       repos = getOption("repos"),
       restore = options::opt("restore"),
+      dependencies = TRUE,
+      upgrade = FALSE,
       ...
     ) {
       check_past_output(output, restore, ask = interactive())
@@ -110,8 +117,9 @@ checker <- R6::R6Class(
         lib.loc
       )
       private$repos <- repos
+      private$upgrade <- upgrade
 
-      self$graph <- task_graph(self$plan, repos)
+      self$graph <- task_graph(self$plan, repos, dependencies = dependencies)
       private$restore_complete_checks()
     },
 
@@ -183,7 +191,8 @@ checker <- R6::R6Class(
           node = next_node,
           g = self$graph,
           output = self$output,
-          lib.loc = private$lib.loc
+          lib.loc = private$lib.loc,
+          upgrade = private$upgrade
         )
 
         if (is.null(process)) {
@@ -239,6 +248,9 @@ checker <- R6::R6Class(
 
     # task loop counter
     gc_needed = FALSE,
+
+    # upgrade flag
+    upgrade = FALSE,
 
     start_node = function(node) {
       task_graph_package_status(self$graph, node) <- STATUS$`in progress`

R/install.R

@@ -12,7 +12,8 @@ install_process <- R6::R6Class(
       lib = .libPaths()[[1]],
       libpaths = .libPaths(),
       available_packages_filters = getOption("available_packages_filters"),
-      log = NULL
+      log = NULL,
+      env = callr::rcmd_safe_env()
     ) {
       if (!dir.exists(lib)) dir.create(lib, recursive = TRUE)
       private$package <- pkgs
@@ -21,7 +22,7 @@ install_process <- R6::R6Class(
         function(..., escalate_warning, available_packages_filters) {
           options(available_packages_filters = available_packages_filters)
           withCallingHandlers(
-            utils::install.packages(...),
+            utils::install.packages(..., quiet = FALSE, verbose = TRUE),
             warning = function(w) {
               if (escalate_warning(w)) {
                 print(w$message)
@@ -43,7 +44,9 @@ install_process <- R6::R6Class(
         libpath = libpaths,
         stdout = self$log,
         stderr = "2>&1",
-        system_profile = TRUE
+        system_profile = options::opt("install_system_profile"),
+        user_profile = options::opt("install_user_profile"),
+        env = env
       )
     },
     get_duration = function() {

R/next_task.R

@@ -62,36 +62,44 @@ start_task.install_task <- function(
   g,
   output,
   lib.loc,
+  upgrade,
   ...
 ) {
   task <- node$task[[1]]
+
+  if (package(task) == "DALEX") browser()
+
   libpaths <- unique(c(
     task_graph_libpaths(g, node, lib.loc = lib.loc, output = output),
     lib.loc
   ))
   install_parameters <- install_params(task$origin)
 
-  if (any(inherits(task$origin, c("pkg_origin_base", "pkg_origin_unknown")))) {
-    return(NULL)
-  }
+  is_base <- any(
+    inherits(task$origin, c("pkg_origin_base", "pkg_origin_unknown"))
+  )
+  if (is_base) return(NULL)
 
   # install_parameters$package is a valid package name only for
   # pkg_origin_repo. Otherwise it's a path to the source package in which case
   # is_package_installed returns FALSE (as it should)
-  if (is_package_installed(install_parameters$package, libpaths)) {
-    return(NULL)
-  }
+  is_installed <- is_package_installed(
+    install_parameters$package,
+    libpaths,
+    upgrade %nif% task$origin$version
+  )
+  if (is_installed) return(NULL)
 
   install_process$new(
     install_parameters$package,
     lib = lib(task, lib.loc = lib.loc, lib.root = path_libs(output)),
     libpaths = libpaths,
-    repos = task$origin$repos,
+    repos = install_parameters$repos,
     dependencies = FALSE,
     type = task$type,
-    INSTALL_opts = c(), # TODO
-    log = path_install_log(output, node$name[[1]]),
-    env = c() # TODO
+    INSTALL_opts = task$INSTALL_opts,
+    log = path_install_log(output, package(task), node$name[[1]]),
+    env = task$env
   )
 }
 

R/options.R

@@ -67,7 +67,19 @@ options::define_options(
   envvar_fn = structure(
     function(raw, ...) trimws(strsplit(raw, " ")[[1]]),
     desc = "space-separated R CMD check flags"
-  )
+  ),
+
+  "named `character` vector of environment variables to use during
+   the package installation.",
+  install_envvars = callr::rcmd_safe_env(),
+
+  "`logical` used as `sytem_profile` parameter passed to the `callr::r_bg()`
+   function used to install packages",
+  install_system_profile = FALSE,
+
+  "value used as `user_profile` parameter passed to the `callr::r_bg()`
+   function used to install packages",
+  install_user_profile = "project"
 )
 
 #' @eval options::as_roxygen_docs()

R/pkg_origin.R

@@ -57,16 +57,13 @@ pkg_origin_repo <- function(package, repos, ...) {
   ap_pkg <- available_packages(repos = repos)[package, ]
 
   version <- package_version(ap_pkg["Version"])
-  source <- strip_src_contrib(ap_pkg["Repository"])
-  if (any(which <- startsWith(repos, source))) {
-    source <- repos[which][1]
-  }
+  repo <- strip_src_contrib(ap_pkg["Repository"], repos = repos)
 
   pkg_origin(
     package = package,
     version = version,
-    source = source,
-    repos = repos,
+    source = repo,
+    repos = repo,
     ...,
     .class = "pkg_origin_repo"
   )
@@ -204,7 +201,7 @@ pkg_deps.pkg_origin_local <- function(
 
   indirect_deps <- pkg_dependencies(
     packages = direct_deps$name,
-    dependencies = dependencies,
+    dependencies = "hard",
     db = db
   )
   indirect_deps$depth <- rep.int("indirect", NROW(indirect_deps))

R/plan.R

@@ -7,12 +7,16 @@
 #'
 #' @param path path to the package source.
 #' @param repos repository used to identify reverse dependencies.
+#' @param remotes_dependencies A vector of length one or a named list.
+#'  Compatible with [`as_pkg_dependencies`]. Used to filter out remotes
+#'  dependencies.
 #'
 #' @family plan
 #' @export
 plan_rev_dep_checks <- function(
   path,
-  repos = getOption("repos")
+  repos = getOption("repos"),
+  remotes_dependencies = TRUE
 ) {
   path <- check_path_is_pkg_source(path)
   ap <- available_packages(repos = repos)
@@ -75,7 +79,7 @@ plan_rev_dep_checks <- function(
   g <- task_graph_class(g)
 
   if (remotes_permitted()) {
-    remotes_graph(g)
+    remotes_graph(g, dependencies = remotes_dependencies)
   } else {
     g
   }
@@ -131,6 +135,9 @@ plan_rev_dep_release_check <- function(origin, revdep, repos) {
 #' @param package A path to either package, directory with packages or name
 #'  of the package (details)
 #' @param repos repository used to identify packages when name is provided.
+#' @param remotes_dependencies A vector of length one or a named list.
+#'  Compatible with [`as_pkg_dependencies`]. Used to filter out remotes
+#'  dependencies.
 #'
 #' @details
 #' `package` parameter has two different allowed values:
@@ -145,7 +152,8 @@ plan_rev_dep_release_check <- function(origin, revdep, repos) {
 #' @export
 plan_local_checks <- function(
   package,
-  repos = getOption("repos")
+  repos = getOption("repos"),
+  remotes_dependencies = TRUE
 ) {
 
   task <- meta_task(
@@ -179,7 +187,7 @@ plan_local_checks <- function(
   star_plan_template(c(
     list(task),
     local_checks_tasks
-  ))
+  ), remotes_dependencies)
 }
 
 
@@ -189,11 +197,18 @@ plan_local_checks <- function(
 #'
 #' @param package A path to package source.
 #' @param repos repository used to identify packages when name is provided.
+#' @param remotes_dependencies A vector of length one or a named list.
+#'  Compatible with [`as_pkg_dependencies`]. Used to filter out remotes
+#'  dependencies.
+#' @param INSTALL_opts Options to set while the root package is being installed.
+#'  Check [`utils::install.packages`] for details.
 #'
 #' @family plan
 plan_local_install <- function(
   package,
-  repos = getOption("repos")
+  repos = getOption("repos"),
+  remotes_dependencies = TRUE,
+  INSTALL_opts = c()
 ) {
 
   m_task <- meta_task(
@@ -202,16 +217,17 @@ plan_local_install <- function(
   )
 
   i_task <- install_task(
-    origin = pkg_origin_local(package)
+    origin = pkg_origin_local(package),
+    INSTALL_opts = INSTALL_opts
   )
 
   star_plan_template(list(
     m_task,
     i_task
-  ))
+  ), remotes_dependencies)
 }
 
-star_plan_template <- function(tasks) {
+star_plan_template <- function(tasks, remotes_dependencies) {
   g <- star_graph(
     task = tasks
   )
@@ -220,8 +236,8 @@ star_plan_template <- function(tasks) {
 
   g <- task_graph_class(g)
 
-  if (remotes_permitted()) {
-    remotes_graph(g)
+  if (remotes_permitted() && !isFALSE(remotes_dependencies)) {
+    remotes_graph(g, dependencies = remotes_dependencies)
   } else {
     g
   }

R/remotes.R

@@ -3,9 +3,14 @@ remotes_graph <- function(x, ...) {
 }
 
 #' @export
-remotes_graph.task_graph <- function(x, ...) {
+remotes_graph.task_graph <- function(x, ..., dependencies = TRUE) {
   vs <- V(x)
-  remotes_subgraphs <- lapply(vs, remotes_graph, vs = vs)
+  remotes_subgraphs <- lapply(
+    vs,
+    remotes_graph,
+    vs = vs,
+    dependencies = dependencies
+  )
 
   task_graph_class(
     suppressWarningsRegex(
@@ -23,13 +28,13 @@ remotes_graph.task_graph <- function(x, ...) {
 
 #' @export
 remotes_graph.integer <- function(x, ..., vs) {
-  remotes_graph(vs[[x]])
+  remotes_graph(vs[[x]], ...)
 }
 
 #' @export
 #' @method remotes_graph igraph.vs
 remotes_graph.igraph.vs <- function(x, ...) {
-  remotes_graph(x$task)
+  remotes_graph(x$task, ...)
 }
 
 #' @export
@@ -40,16 +45,24 @@ remotes_graph.task <- function(x, ...) {
 }
 
 #' @export
-remotes_graph.install_task <- function(x, ...) {
+remotes_graph.install_task <- function(x, ..., dependencies = TRUE) {
   remote_tasks <- get_remote_tasks(x)
   if (length(remote_tasks) == 0) return(igraph::make_empty_graph())
   remote_tasks_names <- vcapply(remote_tasks, package)
 
+  dependencies <- as_pkg_dependencies(dependencies)$direct
   x_deps <- pkg_deps(x$origin)
-  x_remote_deps <- x_deps[
-    x_deps$package == package(x) & x_deps$name %in% remote_tasks_names,
-  ]
-
+  x_remote_deps <- x_deps[x_deps$package == package(x) &
+                            x_deps$name %in% remote_tasks_names &
+                            x_deps$type %in% dependencies, ]
+
+  if (NROW(x_remote_deps) == 0) return(igraph::make_empty_graph())
+
+  # Filter out deps out of scopr
+  remote_tasks <- remote_tasks[remote_tasks_names %in% x_remote_deps$name]
+  remote_tasks_names <-
+    remote_tasks_names[remote_tasks_names %in% x_remote_deps$name]
+
   # Sort tasks according to same key
   remote_tasks <- remote_tasks[order(remote_tasks_names)]
   remote_tasks_types <- x_remote_deps[order(x_remote_deps$name), ]$type

R/task.R

@@ -53,6 +53,7 @@ print.task <- function(x, ...) {
 #' @param lib Any object that can be passed to [lib()] to generate a library
 #'   path.
 #' @inheritParams utils::install.packages
+#' @inheritParams callr::r_bg
 #'
 #' @family tasks
 #' @export
@@ -61,13 +62,15 @@ install_task <- function(
   type = package_install_type(origin),
   INSTALL_opts = NULL,
   lib = lib_path(origin),
+  env = options::opt("install_envvars"),
   ...
 ) {
   task(
     origin = origin,
     type = type,
     INSTALL_opts = INSTALL_opts,
     lib = lib,
+    env = env,
     ...,
     .subclass = "install"
   )