From b51273e82d86f12613de77e22b0611e7121fc3dd Mon Sep 17 00:00:00 2001
From: Craig Williams <craig@avsdev.uk>
Date: Mon, 4 Jul 2022 16:38:47 +0100
Subject: [PATCH] Building of a snapshot completed and included

---
 R/compile_imports.R          | 162 +++++++++++++++++++++++++++++++++++
 R/fetch_available_archives.R |  44 ++++++----
 R/install_package_source.R   |  42 +++++++++
 R/snapshot.R                 |  23 +++++
 R/snapshot_create.R          |  42 +++++++++
 R/snapshot_history.R         |  12 +++
 R/snapshot_latest.R          |  13 +++
 R/utils.R                    |  45 ++++++++++
 8 files changed, 367 insertions(+), 16 deletions(-)
 create mode 100644 R/compile_imports.R
 create mode 100644 R/install_package_source.R
 create mode 100644 R/snapshot.R
 create mode 100644 R/snapshot_create.R
 create mode 100644 R/snapshot_history.R
 create mode 100644 R/snapshot_latest.R

diff --git a/R/compile_imports.R b/R/compile_imports.R
new file mode 100644
index 0000000..71f6e85
--- /dev/null
+++ b/R/compile_imports.R
@@ -0,0 +1,162 @@
+# Requires utils.R
+# Requires request_package_source.R
+# Requires list_imports.R
+# Requires list_depends.R
+# Requires fetch_available_packages.R
+# Requires fetch_available_archives.R
+
+.solve_missing_imports <- function(missingImports, installOpts = list(Ncpus = parallel::detectCores())) {
+  importsFormat <- data.frame(list(
+    package_name = unlist(lapply(missingImports$package, format_str, width = 35)),
+    req_ver = unlist(lapply(missingImports$req_version, format_str, width = 12)),
+    cran_ver = unlist(lapply(missingImports$cran_version, format_str, width = 12))
+  ))
+
+  cat("\n")
+  cat("There are", nrow(missingImports), "package versions that could not be found on CRAN:\n")
+  cat("| Package                             | Req'd Version | CRAN Version |\n")
+  cat("|=====================================|===============|==============|\n")
+  cat(
+    paste("|", importsFormat$package_name, "|", importsFormat$req_ver, " |", importsFormat$cran_ver, "|\n"),
+    sep = ""
+  )
+  cat("\n")
+  cat("What would you like to do?\n")
+  repeat {
+    actions <- select_menu(c("Specify package sources [default]", "Update to latest CRAN version", "Cancel"))
+    if (length(actions) == 1 || length(actions) == nrow(missingImports)) {
+      break
+    }
+    cat("Number of actions must equal 1 or number of missing packages.\n")
+  }
+
+  if ("Cancel" %in% actions) {
+    stop_quietly()
+  }
+
+  if ("Update to latest CRAN version" %in% actions) {
+    newPackages <- which("Update to latest CRAN version" == actions)
+    newPackages <- unique(missingImports[newPackages,"package"])
+    do.call(install.packages, c(list(newPackages), installOpts))
+    cat("\n")
+    cat("One or more new packages were installed. Please re-run the command.\n")
+    stop_quietly()
+  }
+
+  fixedImports <- list()
+  for (row in 1:nrow(missingImports)) {
+    cat("\n")
+    cat("=========================================\n")
+    cat("Package:", missingImports$package[[row]], "\n")
+    source <- request_package_source(missingImports$package[[row]])
+
+    if (is.null(source)) {
+      # Cancelled
+      return(invisible(NULL))
+    }
+
+    fixedImports <- c(fixedImports, list(c(
+      list(
+        package = missingImports$package[[row]],
+        version = missingImports$req_version[[row]]
+      ),
+      source
+    )))
+  }
+
+  do.call(rbind, fixedImports)
+}
+
+#' Compile a structure containing the current state of the imports for the
+#' project.
+#'
+#' @param custom_sources datatable A table containing any previously known
+#'    custom data sources
+#' @param installOpts list Installer options for use when installing CRAN
+#'    packages
+#'
+#' @return A list containing R base imports, directly imported/used packages,
+#'    indirectly imported/used packages (aka dependencies) and any custom
+#'    import sources.
+#' @export
+compile_imports <- function(custom_sources = empty_sources(), installOpts = list(Ncpus = parallel::detectCores())) {
+  CORE_PACKAGES <- c(
+    "base", "compiler", "datasets", "graphics", "grDevices", "grid", "methods",
+    "parallel", "splines", "stats", "stats4", "tcltk", "tools", "utils"
+  )
+
+  imports <- list_imports()
+  depends <- list_depends(unique(imports$package))
+
+  cranPackages <- fetch_available_packages()
+  archivePackages <- fetch_available_archives()
+
+  dependsSources <- depends
+  dependsSources <- merge(
+    dependsSources,
+    c(cranPackages, in_CRAN = TRUE),
+    by = c("package", "version"),
+    all.x = TRUE
+  )
+  dependsSources <- merge(
+    dependsSources,
+    c(archivePackages, in_archive = TRUE),
+    by = c("package", "version"),
+    all.x = TRUE
+  )
+  if (nrow(custom_sources) > 0) {
+    dependsSources <- merge(
+      dependsSources,
+      c(custom_sources[,c("package", "version")], in_custom = TRUE),
+      by = c("package", "version"),
+      all.x = TRUE
+    )
+  } else {
+    dependsSources$in_custom <- NA
+  }
+
+  dependsSources$is_direct <- dependsSources$package %in% imports$package
+  dependsSources$in_core <- dependsSources$package %in% CORE_PACKAGES
+  dependsSources$in_CRAN <- !is.na(dependsSources$in_CRAN)
+  dependsSources$in_archive <- !is.na(dependsSources$in_archive)
+  dependsSources$in_custom <- !is.na(dependsSources$in_custom)
+
+  missingImports <- !(
+    dependsSources$in_core |
+    dependsSources$in_CRAN |
+    dependsSources$in_archive |
+    dependsSources$in_custom
+  )
+
+  customImports <- merge(
+    dependsSources[dependsSources$in_custom, c("package", "version")],
+    custom_sources,
+    by = c("package", "version")
+  )
+  if (sum(missingImports) > 0) {
+    extraImports <- merge(
+      dependsSources[missingImports,c("package", "version")],
+      cranPackages,
+      by = "package",
+      all.x = TRUE
+    )
+    colnames(extraImports) <- c("package", "req_version", "cran_version")
+    extraImports <- .solve_missing_imports(extraImports, installOpts = installOpts)
+    if (is.null(extraImports)) {
+      # Cancelled
+      return(invisible(NULL))
+    }
+    customImports <- rbind(customImports, extraImports)
+  }
+
+  coreDeps <- dependsSources[dependsSources$in_core,]
+  directDeps <- dependsSources[dependsSources$is_direct & !dependsSources$in_core & !missingImports,]
+  indirectDeps <- dependsSources[!dependsSources$is_direct & !dependsSources$in_core & !missingImports,]
+
+  return(list(
+    core_depends = coreDeps[,c("package", "version")],
+    direct_depends = directDeps[,c("package", "version")],
+    indirect_depends = indirectDeps[,c("package", "version")],
+    custom_sources = customImports
+  ))
+}
\ No newline at end of file
diff --git a/R/fetch_available_archives.R b/R/fetch_available_archives.R
index 2d4eac9..181b2d5 100644
--- a/R/fetch_available_archives.R
+++ b/R/fetch_available_archives.R
@@ -1,21 +1,10 @@
 # Requires utils.R
 
-.fetch_available_archives <- function(refetch) {
-  check_pacman_dir()
-  fn <- ".pacman/archive.rds"
-  if (file.exists(fn)) {
-    ts <- as.POSIXct("1970-01-01 00:00:00", tz = "GMT") + as.numeric(Sys.Date() + 1) * 86400
-    if (refetch || (ts < file.mtime(fn))) {
-      unlink(fn)
-    }
-  }
-  if (!file.exists(fn)) {
-    download.file(sprintf("%s/src/contrib/Meta/archive.rds", get_cran_repo()), fn)
-  }
-  con <- gzfile(fn, "rb")
-  on.exit(close(con), add = TRUE)
-  archive <- readRDS(con)
-  archive <-lapply(archive, function(pkg) {
+.process_dist_archive <- function(dist_fn, fn) {
+  dist_con <- gzfile(dist_fn, "rb")
+  on.exit(close(dist_con), add = TRUE)
+  archive <- readRDS(dist_con)
+  archive <- lapply(archive, function(pkg) {
     packageVersions <- gsub("^([^/]+)/[^_]+_(.+).tar.gz", "\\1%%\\2", rownames(pkg))
     packageVersions <- strsplit(packageVersions, "%%")
     packageVersions <- do.call(rbind, packageVersions)
@@ -25,6 +14,29 @@
   })
   archive <- do.call(rbind, archive)
   rownames(archive) <- 1:nrow(archive)
+  write_con <- gzfile(fn, "wb")
+  saveRDS(archive, write_con)
+  close(write_con)
+}
+
+.fetch_available_archives <- function(refetch) {
+  check_pacman_dir()
+  fn <- ".pacman/archive.rds"
+  dist_fn <- ".pacman/archive_dist.rds"
+  if (file.exists(dist_fn)) {
+    ts <- as.POSIXct("1970-01-01 00:00:00", tz = "GMT") + as.numeric(Sys.Date() + 1) * 86400
+    if (refetch || (ts < file.mtime(dist_fn))) {
+      unlink(dist_fn)
+      unlink(fn)
+    }
+  }
+  if (!file.exists(dist_fn)) {
+    download.file(sprintf("%s/src/contrib/Meta/archive.rds", get_cran_repo()), dist_fn)
+    .process_dist_archive(dist_fn, fn)
+  }
+  con <- gzfile(fn, "rb")
+  on.exit(close(con), add = TRUE)
+  archive <- readRDS(con)
   return(archive)
 }
 
diff --git a/R/install_package_source.R b/R/install_package_source.R
new file mode 100644
index 0000000..44123c7
--- /dev/null
+++ b/R/install_package_source.R
@@ -0,0 +1,42 @@
+
+#' Installs a package from a custom source
+#'
+#' @param packageSource The custom source information for a package
+#' @param installOpts list Installer options for use when installing CRAN
+#'    packages
+#'
+#' @return invisible return of the current snapshot
+#' @export
+install_package_source <- function(packageSource, installOpts = list(Ncpus = parallel::detectCores())) {
+  packageRemote <- switch(
+    packageSource$type,
+    git_url      = remotes:::git_remote(packageSource$src, ref = packageSource$ref),
+    github       = remotes:::github_remote(packageSource$src, ref = packageSource$ref),
+    gitlab       = remotes:::gitlab_remote(packageSource$src),
+    svn          = remotes:::svn_remote(packageSource$src, revision = packageSource$ref),
+    bitbucket    = remotes:::bitbucket_remote(packageSource$src, ref = packageSource$ef),
+    Bioconductor = remotes:::bio_remote(packageSource$src)
+  )
+
+  print(dput(c(list(packageRemote), dependencies = NA, upgrade = "default",
+    force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual",
+    "--no-build-vignettes"),
+    build_manual = FALSE, build_vignettes = FALSE,
+    repos = getOption("repos"), type = getOption("pkgType"), installOpts)))
+
+  remotes:::install_remote(packageRemote, dependencies = NA, upgrade = "default",
+    force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual",
+    "--no-build-vignettes"),
+    build_manual = FALSE, build_vignettes = FALSE,
+    repos = getOption("repos"), type = getOption("pkgType"), installOpts)
+
+  allPackages <- installed.packages()
+  allPackages <- as.data.frame(allPackages)
+  allPackages <- allPackages[allPackages$Package %in% packageSource$package,]
+  package <- data.frame(
+    package = allPackages$Package,
+    version = allPackages$Version
+  )
+
+  return(package)
+}
\ No newline at end of file
diff --git a/R/snapshot.R b/R/snapshot.R
new file mode 100644
index 0000000..b2a2cff
--- /dev/null
+++ b/R/snapshot.R
@@ -0,0 +1,23 @@
+# Requires snapshot_create.R
+# Requires snapshot_history.R
+
+#' Save the current state of the project into the lock file as a snapshot
+#'
+#' @param installOpts list Installer options for use when installing CRAN
+#'    packages
+#'
+#' @return invisible return of the current snapshot
+#' @export
+snapshot_save <- function(installOpts = list(Ncpus = parallel::detectCores()), snapshot = NULL) {
+  if (is.null(snapshot)) {
+    snapshot <- snapshot_create(installOpts)
+  }
+  history <- snapshot_history()
+  history <- c(list(snapshot), history)
+  snapshot$history <- history
+  jsonlite::write_json(snapshot, "pacman.lock")
+  snapshot$history <- NULL
+  return(snapshot)
+}
+
+
diff --git a/R/snapshot_create.R b/R/snapshot_create.R
new file mode 100644
index 0000000..181e075
--- /dev/null
+++ b/R/snapshot_create.R
@@ -0,0 +1,42 @@
+# Requires snapshot_latest.R
+# Requires utils.R
+# Requires compile_imports.R
+
+#' Create a snapshot of the project packages. Does not save the snapshot (see snapshot_save)
+#'
+#' @param installOpts list Installer options for use when installing CRAN
+#'    packages
+#'
+#' @return A list containing the current state of the project packages
+#' @export
+snapshot_create <- function(installOpts = list(Ncpus = parallel::detectCores())) {
+  lastSnapshot <- snapshot_latest()
+  customSources <- empty_sources()
+  if (!is.null(lastSnapshot) && "custom" %in% names(lastSnapshot$packages)) {
+    customSources <- rbind(customSources, lastSnapshot$packages$custom)
+  }
+  packages <- compile_imports(customSources, installOpts)
+  names(packages) <- c("core", "direct", "indirect", "custom")
+  if (nrow(packages$core) == 0) {
+    packages$core <- NULL
+  }
+  if (nrow(packages$direct) == 0) {
+    packages$direct <- NULL
+  }
+  if (nrow(packages$indirect) == 0) {
+    packages$indirect <- NULL
+  }
+  if (nrow(packages$custom) == 0) {
+    packages$custom <- NULL
+  }
+  description <- trimws(readline("Please provide a description for the snapshot (optional): "))
+  if (nchar(description) == 0) {
+    description <- NULL
+  }
+  return(list(
+    timestamp = Sys.time(),
+    description = description,
+    R_version = paste(R.version$major, R.version$minor, sep = "."),
+    packages = packages
+  ))
+}
\ No newline at end of file
diff --git a/R/snapshot_history.R b/R/snapshot_history.R
new file mode 100644
index 0000000..f9dc767
--- /dev/null
+++ b/R/snapshot_history.R
@@ -0,0 +1,12 @@
+
+#' Load the existing snapshot history of the project
+#'
+#' @return A list containing the previous snapshots
+#' @export
+snapshot_history <- function() {
+  if (!file.exists("pacman.lock")) {
+    return(list())
+  }
+  state <- jsonlite::read_json("pacman.lock")
+  return(state$history)
+}
\ No newline at end of file
diff --git a/R/snapshot_latest.R b/R/snapshot_latest.R
new file mode 100644
index 0000000..25cec55
--- /dev/null
+++ b/R/snapshot_latest.R
@@ -0,0 +1,13 @@
+
+#' Load the latest snapshot state from the lock file
+#'
+#' @return A list containing the last saved snapshot of the project state
+#' @export
+snapshot_latest <- function() {
+  if (!file.exists("pacman.lock")) {
+    return(NULL)
+  }
+  state <- jsonlite::read_json("pacman.lock")
+  state$history <- NULL
+  return(state)
+}
\ No newline at end of file
diff --git a/R/utils.R b/R/utils.R
index 23aa992..10670ce 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -13,6 +13,13 @@ check_pacman_dir <- function() {
       return(invisible(FALSE))
     }
   }
+  if (file.exists(".gitignore")) {
+    if (length(grep(".pacman/", ".gitignore")) == 0) {
+      con <- file(".gitignore", "a")
+      writeLines("\n# pacman - package management folder\n.pacman/", con)
+      close(con)
+    }
+  }
   invisible(TRUE)
 }
 
@@ -57,4 +64,42 @@ select_menu <- function(choices, title = NULL, msg = "Enter a number from the me
       return(choices[as.integer(answer)])
     }
   }
+}
+
+#' Structure of the imports data table
+#'
+#' @return datatable Empty table with the imports column structure
+empty_sources <- function() {
+  data.frame(
+    package = character(0),
+    version = character(0),
+    type = character(0),
+    src = character(0),
+    ref = character(0)
+  )
+}
+
+#' Re-formats a string to fix the width by padding with spaces
+#'
+#' @param str A character vector of strings to format
+#' @param width An optional width of the string to pad to
+#' @param justify "left" or "right" justification
+#'
+#' @return A formatted (padded) character vector
+format_str <- function (str, width = NULL, justify = "left", ...) {
+  x <- format(str, justify = justify, width = width, ...)
+  if (!is.null(width)) {
+    str_width <- nchar(str, "width")
+    too_wide <- str_width > width
+    if (any(too_wide)) {
+      x[too_wide] <- paste0(substr(x[too_wide], 1, width - 3), "...")
+    }
+  }
+  return(x)
+}
+
+#' Calls stop() returning to the top level but masks the message
+stop_quietly <- function(...) {
+  blankMsg <- sprintf("\r%s\r", paste(rep(" ", getOption("width") - 1L), collapse = " "))
+  stop(simpleError(blankMsg))
 }
\ No newline at end of file