Fixes and improvements for strategies

R/check.R

@@ -117,12 +117,11 @@ solve_ip.deps_installation_proposal <- function(ip) {
 #' For each direct dependency, resolve that package using PPM snapshot as of release date + 1.
 #' Finally, combine resolutions and run solve.
 #' @keywords internal
-#' @importFrom pkgcache ppm_repo_url
-#' @importFrom pkgdepends new_pkg_deps parse_pkg_ref
 #' @exportS3Method solve_ip min_isolated_deps_installation_proposal
 solve_ip.min_isolated_deps_installation_proposal <- function(ip) { # nolint
   ip$resolve()
   res <- ip$get_resolution()
+  res$parent <- NA_character_
 
   deps <- res[1, "deps"][[1]]
   ## copy op and version to Config\Needs\verdepcheck rows
@@ -137,46 +136,26 @@ solve_ip.min_isolated_deps_installation_proposal <- function(ip) { # nolint
 
   cli_pb_init("min_isolated", total = nrow(deps))
 
-  deps_res <- lapply(
-    seq_len(nrow(deps)),
-    function(i) {
-      i_pkg <- deps[i, "package"]
+  deps_res <- lapply(seq_len(nrow(deps)), function(i) {
+    i_pkg <- deps[i, "package"]
 
-      cli_pb_update(package = i_pkg, n = 4L)
+    cli_pb_update(package = i_pkg, n = 4L)
 
-      if (i_pkg %in% base_pkgs()) {
-        return(NULL)
-      }
+    if (i_pkg %in% base_pkgs()) return(NULL)
 
-      i_op <- deps[i, "op"]
-      i_op_ver <- deps[i, "version"]
-
-      i_ref_str <- deps[i, "ref"]
-      i_ref <- pkgdepends::parse_pkg_ref(i_ref_str)
+    resolve_ppm_snapshot(
+      deps[i, "ref"],
+      deps[i, "op"],
+      deps[i, "version"]
+    )
+  })
 
-      i_ref_minver <- get_ref_min_incl_cran(i_ref, i_op, i_op_ver)
+  new_res <- do.call(rbind, deps_res)
 
-      i_release_date <- get_release_date(i_ref_minver)
+  new_res <- new_res[!duplicated(new_res[, c("ref", "package", "version")]), ]
 
-      if (is.na(i_release_date)) {
-        ppm_repo <- file.path(pkgcache::ppm_repo_url(), "latest")
-      } else {
-        ppm_repo <- parse_ppm_url(get_ppm_snapshot_by_date(i_release_date))
-      }
-
-      i_pkg_deps <- pkgdepends::new_pkg_deps(
-        if (inherits(i_ref_minver, "remote_ref_github")) i_ref_minver$ref else i_ref$ref,
-        config = list(dependencies = "hard", cran_mirror = ppm_repo)
-      )
-      suppressMessages(i_pkg_deps$resolve())
-      i_res <- i_pkg_deps$get_resolution()
-      i_res$direct <- i_res$directpkg <- FALSE
-      i_res
-    }
-  )
-
-  new_res <- rbind(res[1, ], do.call(rbind, deps_res))
-  new_res <- new_res[!duplicated(new_res), ]
+  # Keep res at top
+  new_res <- rbind(res[1, ], new_res)
 
   ip$.__enclos_env__$private$plan$.__enclos_env__$private$resolution$result <- new_res
   ip$solve()
@@ -293,7 +272,13 @@ download_ip <- function(ip) {
 #' @export
 install_ip <- function(ip) {
   ip$install_sysreqs()
-  ip$install()
+  tryCatch(
+    ip$install(),
+    error = function(err) {
+      # Print compilation error when installation fails to help debug
+      print(err)
+      stop(err)
+  })
 
   return(invisible(ip))
 }

R/deps_installation_proposal.R

@@ -101,6 +101,7 @@ new_release_deps_installation_proposal <- function(path, # nolint
   }
   new_refs_str <- vapply(new_refs, `[[`, character(1), "ref")
 
+  d <- desc_remotes_cleanup(d, new_refs)
   d <- desc_cond_set_refs(d, new_refs_str)
 
   res <- desc_to_ip(d, config)
@@ -155,6 +156,7 @@ new_min_cohort_deps_installation_proposal <- function(path, # nolint
     }
   )
   new_refs_str <- vapply(new_refs, `[[`, character(1), "ref")
+  d <- desc_remotes_cleanup(d, new_refs)
   d <- desc_cond_set_refs(d, new_refs_str)
 
   # find PPM snapshot
@@ -260,6 +262,7 @@ new_min_isolated_deps_installation_proposal <- function(path, # nolint
   )
   new_refs_str <- vapply(new_refs, `[[`, character(1), "ref")
 
+  d <- desc_remotes_cleanup(d, new_refs)
   d <- desc_cond_set_refs(d, new_refs_str)
 
   res <- desc_to_ip(d, config)
@@ -299,6 +302,56 @@ get_refs_from_desc <- function(d) {
   res[res_idx]
 }
 
+#' Replace Remotes in the `desc` that have been resolved to a GitHub tag or are
+#' in CRAN
+#'
+#' Replaces any existing Remotes entry with the resolved GitHub tag from the
+#' `new_refs`.
+#'
+#' It keeps all the existing Remotes that have not been resolved in `new_refs`.
+#'
+#' @param d (`desc`) DESCRIPTION object
+#' @param new_refs (`list`) remote references that have been resolved and are
+#' being updated in `Config/Needs/verdepcheck`
+#' @keywords internal
+desc_remotes_cleanup <- function(d, new_refs) {
+  # Parse the remotes to retrieve the package names
+  remotes <- pkgdepends::parse_pkg_refs(d$get_remotes())
+
+  # Get the packages defined in remotes
+  #  (making sure that only packages that are already defined here are modified)
+  remotes_pkg <- vapply(remotes, `[[`, character(1), "package")
+
+  # Find which packages of the new_refs are defined in Remotes
+  new_refs_gh <- vapply(
+    new_refs,
+    function(.x) {
+      isTRUE(.x$package %in% remotes_pkg) && inherits(.x, "remote_ref_github")
+    },
+    logical(1)
+  )
+
+  # New remotes ref to use when replacing
+  new_ref_remote <- vapply(new_refs[new_refs_gh], `[[`, character(1), "ref")
+
+  # Remotes that are not in new_refs are kept, as well as the ones that were
+  #  resolved to be a github repo
+  d$clear_remotes()
+
+  new_ref_pkg <- vapply(new_refs, `[[`, character(1), "package")
+  new_remotes <- c(
+    # Keep remotes
+    d$get_remotes()[!(remotes_pkg %in% new_ref_pkg)],
+    # Modified remotes
+    new_ref_remote
+  )
+
+  # Return clause without Remotes section
+  if (is.null(new_remotes) || length(new_remotes) == 0) return(d)
+  d$set_remotes(new_remotes)
+  d
+}
+
 #' Set `"Config/Needs/verdepcheck"` section into the `desc` object if not empty else clear this section.
 #' @keywords internal
 desc_cond_set_refs <- function(d, refs) {
@@ -329,7 +382,9 @@ desc_to_ip <- function(d, config) {
 cli_pb_init <- function(type, total, ...) {
   cli::cli_progress_bar(
     format = paste(
-      "{cli::pb_spin} Resolving {cli::pb_extra$type} version of {cli::pb_extra$package}",
+      "{cli::pb_spin} Resolving",
+      "{cli::style_bold(cli::col_yellow(cli::pb_extra$type))}",
+      "version of {cli::col_blue(cli::pb_extra$package)}",
       "[{cli::pb_current}/{cli::pb_total}]   ETA:{cli::pb_eta}"
     ),
     format_done = paste0(

R/get_ref.R

@@ -150,8 +150,16 @@ get_ref_min.remote_ref_github <- function(remote_ref, op = "", op_ver = "") {
     }
   }
 
-  new_ref <- sprintf("%s=%s/%s%s", remote_ref$package, remote_ref$username, remote_ref$repo, ref_suffix) # @TODO
-  pkgdepends::parse_pkg_ref(new_ref)
+  new_ref <- sprintf(
+    "%s=%s/%s%s",
+    remote_ref$package,
+    remote_ref$username,
+    remote_ref$repo,
+    ref_suffix
+  )
+  result <- pkgdepends::parse_pkg_ref(new_ref)
+
+  result
 }
 
 # Get list of releases if not empty else get list of tags
@@ -163,6 +171,7 @@ get_gh_refs <- function(org, repo) {
   }
   get_gh_tags(org, repo)
 }
+
 #' @importFrom gh gh_gql
 #' @keywords internal
 get_gh_releases <- function(org, repo, max_date = Sys.Date() + 1, min_date = as.Date("1900-01-01")) {
@@ -187,6 +196,7 @@ get_gh_releases <- function(org, repo, max_date = Sys.Date() + 1, min_date = as.
   )
   vapply(res, `[[`, character(1), "tagName")
 }
+
 #' @importFrom gh gh_gql
 #' @keywords internal
 get_gh_tags <- function(org, repo, max_date = Sys.Date() + 1, min_date = as.Date("1900-01-01")) {
@@ -316,40 +326,76 @@ cond_parse_pkg_ref_release <- function(remote_ref) {
 get_release_date <- function(remote_ref) {
   UseMethod("get_release_date", remote_ref)
 }
+
+#' Get release date from GitHub references
+#'
+#' @inheritParams get_release_date
+#'
 #' @importFrom gh gh_gql
 #' @export
+#' @examplesIf gh::gh_token() != ""
+#' remote_ref <- pkgdepends::parse_pkg_ref("insightsengineering/[email protected]")
+#' get_release_date.remote_ref_github(remote_ref)
 get_release_date.remote_ref_github <- function(remote_ref) {
   gql_query <- sprintf("{
     repository(owner: \"%s\", name: \"%s\") {
       refs(refPrefix: \"refs/tags/\", query: \"%s\", first: 100) {
-        nodes {
-          target {
-            ... on Commit {
-              committedDate
+        edges {
+        	node {
+          	name
+            target {
+              ... on Commit {
+                committedDate
+              }
             }
-          }
+        	}
         }
       }
     }
   }", remote_ref$username, remote_ref$repo, remote_ref$commitish)
+
   resp <- try(gh::gh_gql(gql_query), silent = TRUE)
   if (inherits(resp, "try-error")) {
     return(character(0))
   }
-  vapply(resp$data$repository$refs$nodes, function(x) x$target$committedDate, character(1))
+
+  result <- vapply(
+    resp$data$repository$refs$edges,
+    function(x) {
+      if (x$node$name != remote_ref$commitish) return(NA_character_)
+      x$node$target$committedDate
+    },
+    character(1)
+  )
+
+  if (length(result) <= 1) {
+    return(result %||% NA_character_)
+  }
+
+  max(result, na.rm = TRUE)
 }
+
+#' Get release date from GitHub references
+#'
+#' @inheritParams get_release_date
+#'
 #' @export
+#' @examplesIf Sys.getenv("R_USER_CACHE_DIR", "") != ""
+#' remote_ref <- pkgdepends::parse_pkg_ref("[email protected]")
+#' get_release_date.remote_ref_cran(remote_ref)
 get_release_date.remote_ref_cran <- function(remote_ref) {
   subset(
     get_cran_data(remote_ref$package),
     package_version(version, strict = FALSE) == package_version(remote_ref$version, strict = FALSE),
     mtime
   )[[1]][1]
 }
+
 #' @export
 get_release_date.remote_ref_standard <- function(remote_ref) {
   get_release_date.remote_ref_cran(remote_ref)
 }
+
 #' @export
 get_release_date.remote_ref <- function(remote_ref) {
   NA

R/utils.R

@@ -22,7 +22,10 @@ base_pkgs <- function() {
 #' @importFrom pkgcache ppm_snapshots
 get_ppm_snapshot_by_date <- function(date) {
   snaps <- pkgcache::ppm_snapshots()
-  res <- as.character(as.Date(head(snaps[as.Date(snaps$date) > as.Date(date), "date"], 1)))
+  res <- as.character(as.Date(head(
+    snaps[as.Date(snaps$date) > as.Date(date), "date"],
+    1
+  )))
   if (length(res) == 0) stop(sprintf("Cannot find PPM snapshot for date after %s.", as.character(date)))
   res
 }
@@ -31,3 +34,38 @@ get_ppm_snapshot_by_date <- function(date) {
 parse_ppm_url <- function(snapshot) {
   file.path(pkgcache::ppm_repo_url(), snapshot)
 }
+
+#' Resolve the dependencies of package based on the release date + 1
+#'
+#' @keywords internal
+#' @importFrom pkgcache ppm_repo_url
+#' @importFrom pkgdepends new_pkg_deps parse_pkg_ref
+resolve_ppm_snapshot <- function(pkg_ref_str, operator, pkg_version) {
+
+  i_ref <- pkgdepends::parse_pkg_ref(pkg_ref_str)
+
+  i_ref_minver <- get_ref_min_incl_cran(i_ref, operator, pkg_version)
+
+  i_release_date <- get_release_date(i_ref_minver)
+
+  if (all(is.na(i_release_date))) {
+    ppm_repo <- file.path(pkgcache::ppm_repo_url(), "latest")
+  } else {
+    ppm_repo <- parse_ppm_url(get_ppm_snapshot_by_date(i_release_date))
+  }
+
+  i_pkg_deps <- pkgdepends::new_pkg_deps(
+    ifelse(
+      inherits(i_ref_minver, "remote_ref_github"),
+      i_ref_minver$ref,
+      i_ref$ref
+    ),
+    config = list(dependencies = "hard", cran_mirror = ppm_repo)
+  )
+  suppressMessages(i_pkg_deps$resolve())
+
+  i_res <- i_pkg_deps$get_resolution()
+  i_res$direct <- i_res$directpkg <- FALSE
+  i_res$parent <- pkg_ref_str
+  i_res
+}