Implement local:: in resolve()

R/as_pkgrefs.R

@@ -35,10 +35,10 @@ as_pkgrefs.default <- function(x, ...) {
 #' @rdname as_pkgrefs
 #' @export
 as_pkgrefs.character <- function(x, bioc_version = NULL, ...) {
-    if(.is_renv_lockfile(x)){
+    if(.is_renv_lockfile(x)) {
       return(.extract_pkgrefs_renv_lockfile(path = x))
     }
-    if(.is_directory(x)){
+    if(.is_directory(x)) {
       return(.extract_pkgrefs_dir(x,bioc_version))
     }
     return(.normalize_pkgs(pkgs = x, bioc_version = bioc_version))
@@ -50,22 +50,25 @@ as_pkgrefs.sessionInfo <- function(x, ...) {
     vapply(X = x$otherPkgs, FUN = .extract_pkgref_packageDescription, FUN.VALUE = character(1), USE.NAMES = FALSE)
 }
 
-.extract_pkgrefs_renv_lockfile <- function(path){
+.extract_pkgrefs_renv_lockfile <- function(path) {
     lockfile <- .parse_renv_lockfile(path)
     sources <- vapply(lockfile[["Packages"]],`[[`,character(1),"Source",USE.NAMES = FALSE)
     pkgs <- c()
-    if("Repository"%in%sources){
-      pkgs <- c(pkgs, paste0("cran::",vapply(lockfile[["Packages"]][sources=="Repository"],`[[`,character(1),"Package",USE.NAMES = FALSE)))
+    if("Repository" %in% sources) {
+        pkgs <- c(pkgs, paste0("cran::",vapply(lockfile[["Packages"]][sources=="Repository"],`[[`,character(1),"Package",USE.NAMES = FALSE)))
     }
-    if("Bioconductor"%in%sources){
-      pkgs <- c(pkgs,paste0("bioc::",vapply(lockfile[["Packages"]][sources=="Bioconductor"],`[[`,character(1),"Package",USE.NAMES = FALSE)))
+    if("Bioconductor" %in% sources) {
+        pkgs <- c(pkgs,paste0("bioc::",vapply(lockfile[["Packages"]][sources=="Bioconductor"],`[[`,character(1),"Package",USE.NAMES = FALSE)))
     }
-    if("GitHub"%in%sources){
-      pkgs <- c(pkgs,
-                paste0("github::",
-                       vapply(lockfile[["Packages"]][sources=="GitHub"],`[[`,character(1), "RemoteUsername", USE.NAMES = FALSE),"/",
-                       vapply(lockfile[["Packages"]][sources=="GitHub"],`[[`,character(1), "Package", USE.NAMES = FALSE))
-      )
+    if("GitHub" %in% sources) {
+        pkgs <- c(pkgs,
+                  paste0("github::",
+                         vapply(lockfile[["Packages"]][sources=="GitHub"],`[[`,character(1), "RemoteUsername", USE.NAMES = FALSE),"/",
+                         vapply(lockfile[["Packages"]][sources=="GitHub"],`[[`,character(1), "Package", USE.NAMES = FALSE))
+                  )
+    }
+    if ("Local" %in% sources) {
+        pkgs <- c(pkgs, paste0("local::", vapply(lockfile[["Packages"]][sources=="Local"],`[[`,character(1),"RemoteUrl",USE.NAMES = FALSE)))
     }
     return(pkgs)
 }
@@ -78,23 +81,19 @@ as_pkgrefs.sessionInfo <- function(x, ...) {
     if (grepl("bioconductor", packageDescription[["URL"]])) {
       return(paste0("bioc::",handle))
     }
-    ## uncomment this when #57 is implemented
-    ##if (basename(attr(packageDescription, "file")) == "DESCRIPTION") {
+    if (basename(attr(packageDescription, "file")) == "DESCRIPTION") {
         ## probably load via devtools::load_all
-    ##    return(paste0("local::", dirname(attr(packageDescription, "file"))))
-    ##}
-    ## TODO bioc
-    ## if (basename(attr(packageDescription, "file")) == "package.rds") {
+        return(paste0("local::", dirname(attr(packageDescription, "file"))))
+    }
     return(paste0("cran::", handle))
-    ## }
 }
 
-.is_renv_lockfile <- function(path){
+.is_renv_lockfile <- function(path) {
     # assuming all renv lockfiles are called renv.lock and path is only length 1
-    if(length(path)!=1){
+    if(length(path)!=1) {
       return(FALSE)
     }
-    if(isFALSE(file.exists(path))){
+    if(isFALSE(file.exists(path))) {
       return(FALSE)
     }
     if (isFALSE(basename(path) == "renv.lock")) {
@@ -103,24 +102,24 @@ as_pkgrefs.sessionInfo <- function(x, ...) {
     TRUE
 }
 
-.parse_renv_lockfile <- function(path){
+.parse_renv_lockfile <- function(path) {
     lockfile <- jsonlite::fromJSON(path, simplifyVector = FALSE)
     # class(lockfile) <- "renv_lockfile"
     lockfile
 }
 
-.is_directory <- function(path){
-    if(length(path)!=1){
+.is_directory <- function(path) {
+    if(length(path)!=1) {
       return(FALSE)
     }
-    if(isFALSE(dir.exists(path))){
+    if(isFALSE(dir.exists(path))) {
       return(FALSE)
     }
     TRUE
 }
 
-.extract_pkgrefs_dir <- function(path, bioc_version = NULL){
+.extract_pkgrefs_dir <- function(path, bioc_version = NULL) {
     pkgs <- suppressMessages(unique(renv::dependencies(path,progress = FALSE)$Package))
     warning("scanning directories for R packages cannot detect github packages.",call. = FALSE)
     return(.normalize_pkgs(pkgs = pkgs, bioc_version = bioc_version))
-}
+}

R/installation.R

@@ -40,23 +40,23 @@
     }
     ## installation simulation
     installed_pkgrefs <- c()
-    github_pkgrefs <- c()
+    noncranlike_pkgrefs <- c() ## github and local are noncran-like
     needed_pkgrefs <- dep$keys()
     ## install all terminal nodes
     for (pkgref in needed_pkgrefs) {
-        if (.is_github(pkgref)) {
-          github_pkgrefs <- c(github_pkgrefs, pkgref)
-          next()
+        if (.parse_pkgref(pkgref, return_handle = FALSE) %in% c("github", "local")) {
+            noncranlike_pkgrefs <- c(noncranlike_pkgrefs, pkgref)
+            next()
         }
         if (is.null(dep$get(pkgref))) {
             installed_pkgrefs <- c(installed_pkgrefs, pkgref)
         }
     }
     loop_counter <- 0
-    while(length(setdiff(needed_pkgrefs, c(installed_pkgrefs, github_pkgrefs))) != 0) {
+    while(length(setdiff(needed_pkgrefs, c(installed_pkgrefs, noncranlike_pkgrefs))) != 0) {
         unfulfilled_pkgrefs <- c()
         for (pkgref in needed_pkgrefs) {
-            if (!pkgref %in% installed_pkgrefs && !pkgref %in% github_pkgrefs) {
+            if (!pkgref %in% installed_pkgrefs && !pkgref %in% noncranlike_pkgrefs) {
                 ## check requirement
                 requirement_fulfilled <- length(setdiff(dep$get(pkgref), installed_pkgrefs)) == 0
                 if (requirement_fulfilled) {
@@ -71,7 +71,7 @@
             stop("Can't determine installation order. Please report the to the developers:\n", paste0(unfulfilled_pkgrefs, collapse = ","), call. = FALSE)
         }
     }
-    ordered_pkgrefs <- c(installed_pkgrefs, github_pkgrefs)
+    ordered_pkgrefs <- c(installed_pkgrefs, noncranlike_pkgrefs)
     ordered_x <- vapply(ordered_pkgrefs, function(x) pkgname$get(x), character(1), USE.NAMES = FALSE)
     ordered_version <- vapply(ordered_pkgrefs, function(x) version$get(x), character(1), USE.NAMES = FALSE)
     ordered_source <- vapply(ordered_pkgrefs, function(x) .parse_pkgref(x, return_handle = FALSE), character(1), USE.NAMES = FALSE)
@@ -129,7 +129,11 @@
 }
 
 .write_rang_as_comment <- function(rang, con, path, verbose, lib,
-                                       cran_mirror, check_cran_mirror, bioc_mirror) {
+                                   cran_mirror, check_cran_mirror, bioc_mirror) {
+    if (isTRUE(any(grepl("^local::", .extract_pkgrefs(rang))))) {
+        cat("## ## WARNING:", file = con)
+        cat("## ## Local packages found. The following instructions are not reproducible.", file = con)
+    }
     cat("## ## To reconstruct this file, please install version",
         as.character(utils::packageVersion("rang")), "of `rang` and run:\n", file = con)
     cat("## rang <- \n", file = con)
@@ -181,6 +185,15 @@
     }
 }
 
+.check_tarball_path <- function(tarball_path, x, dir = FALSE) {
+    ## raise error when tarball_path doesn't exist
+    if ((isFALSE(dir) && isFALSE(file.exists(tarball_path))) ||
+        (isTRUE(dir) && isFALSE(dir.exists(tarball_path)))) {
+        stop(x, " can't be cached.", call. = FALSE)
+    }
+    invisible()
+}
+
 .cache_pkg_cran <- function(x, version, cache_dir, cran_mirror, verbose) {
     url <- paste(cran_mirror, "src/contrib/Archive/", x, "/", x, "_", version, ".tar.gz", sep = "")
     tarball_path <- file.path(cache_dir, paste(x, "_", version, ".tar.gz", sep = ""))
@@ -191,27 +204,38 @@
         url <- paste(cran_mirror, "src/contrib/", x, "_", version, ".tar.gz", sep = "")
         utils::download.file(url, destfile = tarball_path, quiet = !verbose)
     })
-    if (!file.exists(tarball_path)) {
-        warning(names(x), "(", x,") can't be cache.")
-    }
+    .check_tarball_path(tarball_path, x)
 }
 
 .cache_pkg_bioc <- function(x, version, cache_dir, bioc_mirror, bioc_version, verbose, uid) {
     url <- paste(bioc_mirror, bioc_version, "/", uid, "/src/contrib/", x, "_", version, ".tar.gz", sep = "")
     tarball_path <- file.path(cache_dir, paste(x, "_", version, ".tar.gz", sep = ""))
     suppressWarnings(utils::download.file(url, destfile = tarball_path, quiet = !verbose))
-    if (!file.exists(tarball_path)) {
-      warning(names(x), "(", x,") can't be cache.")
-    }
+    .check_tarball_path(tarball_path, x)
 }
 
 .cache_pkg_github <- function(x, version, handle, source, uid, cache_dir, verbose) {
     sha <- uid
     tarball_path <- file.path(cache_dir, paste("raw_", x, "_", version, ".tar.gz", sep = ""))
     utils::download.file(paste("https://api.github.com/repos/", handle, "/tarball/", sha, sep = ""), destfile = tarball_path,
                          quiet = !verbose)
-    if (!file.exists(tarball_path)) {
-        warning(names(x), "(", x,") can't be cache.")
+    .check_tarball_path(tarball_path, x)
+}
+
+.cache_pkg_local <- function(x, version, cache_dir, uid) {
+    local_path <- uid
+    tarball_path <- file.path(cache_dir, paste("raw_", x, "_", version, ".tar.gz", sep = ""))
+    if (isTRUE(grepl("\\.tar.gz$|\\.tgz$", local_path))) {
+        ## it could be a valid source package, but don't trust it blindly, mark it as raw_
+        ## similar to github packages
+        file.copy(local_path, tarball_path)
+        return(.check_tarball_path(tarball_path, x))
+    }
+    if (.is_directory(local_path)) {
+        dir_pkg_path <- file.path(cache_dir, paste("dir_", x, "_", version, sep = ""))
+        res <- file.copy(from = local_path, to = cache_dir, recursive = TRUE, overwrite = TRUE)
+        res <- file.rename(from = file.path(cache_dir, x), to = dir_pkg_path)
+        return(.check_tarball_path(dir_pkg_path, x, dir = TRUE))
     }
 }
 
@@ -239,9 +263,14 @@
         }
         if(source == "bioc") {
             .cache_pkg_bioc(x = x, version = version, cache_dir = cache_dir,
-                            bioc_mirror = bioc_mirror,bioc_version = rang$bioc_version, verbose = verbose,
+                            bioc_mirror = bioc_mirror, bioc_version = rang$bioc_version, verbose = verbose,
                             uid = uid)
         }
+        if(source == "local") {
+            ## please note that these cached packages are not built
+            .cache_pkg_local(x = x, version = version, cache_dir = cache_dir, uid = uid)
+        }
+
     }
     ## For #14, cache R source in the future here
     invisible(output_dir)
@@ -390,8 +419,8 @@ export_rang <- function(rang, path, rang_as_comment = TRUE, verbose = TRUE, lib
 #' @param output_dir character, where to put the Docker file and associated content
 #' @param materials_dir character, path to the directory containing additional resources (e.g. analysis scripts) to be copied into `output_dir` and in turn into the Docker container
 #' @param image character, which versioned Rocker image to use. Can only be "r-ver", "rstudio", "tidyverse", "verse", "geospatial"
-#' This applies only to R version <= 3.1
-#' @param cache logical, whether to cache the packages now. Please note that the system requirements are not cached. For query with non-CRAN packages, this option is strongly recommended. For R version < 3.1, this must be TRUE if there is any non-CRAN packages.
+#' This applies only to R version >= 3.1
+#' @param cache logical, whether to cache the packages now. Please note that the system requirements are not cached. For query with non-CRAN packages, this option is strongly recommended. For query with local packages, this must be TRUE regardless of R version. For R version < 3.1, this must be also TRUE if there is any non-CRAN packages.
 #' @param no_rocker logical, whether to skip using Rocker images even when an appropriate version is available. Please keep this as `TRUE` unless you know what you are doing
 #' @param debian_version, when Rocker images are not used, which EOL version of Debian to use. Can only be "lenny", "etch", "squeeze", "wheezy", "jessie", "stretch". Please keep this as default "lenny" unless you know what you are doing
 #' @param ... arguments to be passed to `dockerize`
@@ -436,9 +465,10 @@ dockerize <- function(rang, output_dir, materials_dir = NULL, image = c("r-ver",
     need_cache <- (isTRUE(any(grepl("^github::", .extract_pkgrefs(rang)))) &&
                    utils::compareVersion(rang$r_version, "3.1") == -1) ||
         (isTRUE(any(grepl("^bioc::", .extract_pkgrefs(rang)))) &&
-         utils::compareVersion(rang$r_version, "3.3") == -1)
+         utils::compareVersion(rang$r_version, "3.3") == -1) ||
+        (isTRUE(any(grepl("^local::", .extract_pkgrefs(rang)))))
     if (isTRUE(need_cache) && isFALSE(cache)) {
-        stop("Non-CRAN packages must be cached for this R version: ", rang$r_version, ". Please set `cache` = TRUE.", call. = FALSE)
+        stop("Packages must be cached. Please set `cache` = TRUE.", call. = FALSE)
     }
     image <- match.arg(image)
     debian_version <- match.arg(debian_version)

R/pkgref.R

@@ -52,23 +52,34 @@
     return(source)
 }
 
-.is_github <- function(pkg){
-    ## For now, this is sufficient.
-    ## If "local" and "url" are supported, this is not
-    grepl("/", pkg)
+.is_github <- function(pkg) {
+    if (grepl("github\\.com", pkg)) {
+        return(TRUE)
+    }
+    grepl("/", pkg) && isFALSE(grepl("^[\\.~]?/", pkg)) &&
+        isFALSE(grepl("/$", pkg)) &&
+        length(strsplit(pkg, split = "/")[[1]]) == 2
 }
 
-.is_bioc <- function(pkg,bioc_version){
+.is_bioc <- function(pkg, bioc_version) {
+    if (is.null(bioc_version)) {
+        return(FALSE)
+    }
     bioc_pkgs <- .memo_search_bioc(bioc_version)
-    pkg%in%bioc_pkgs$Package
+    pkg %in% bioc_pkgs$Package
 }
 
-.is_pkgref <- function(pkg) {
-    grepl("::", pkg)
+
+.is_local <- function(pkg) {
+    ## according to the standard, it must be started by ".", "~", "/"
+    grepl("^[\\.~/]", pkg)
 }
 
 ## TBI: .is_valid_pkgref
 ## pkgref is only valid if: exactly one "::", source %in% c("cran", "github"), if "github", .is_github is TRUE
+.is_pkgref <- function(pkg) {
+    grepl("^github::|^cran::|^local::|^bioc::", pkg)
+}
 
 .extract_github_handle <- function(url) {
     url <- gsub("^github::", "", url)
@@ -83,24 +94,6 @@
     return(paste0(path_components[1], "/", path_components[2]))
 }
 
-## to normalize a pkg to pkgref
-# .normalize_pkg <- function(pkg) {
-#     if (pkg == "" || is.na(pkg)) {
-#         stop("Invalid `pkg`.", call. = FALSE)
-#     }
-#     if (isTRUE(.is_github(pkg))) {
-#         if (isTRUE(grepl("github\\.com", pkg))) {
-#             pkg <- .extract_github_handle(pkg)
-#         }
-#     }
-#     if (isTRUE(.is_pkgref(pkg))) {
-#         return(.clean_suffixes(pkg))
-#     }
-#     if (isTRUE(.is_github(pkg))) {
-#         return(paste0("github::", .clean_suffixes(pkg)))
-#     }
-#     return(paste0("cran::", .clean_suffixes(pkg)))
-# }
 .normalize_pkg <- function(pkg,bioc_version=NULL) {
     if (pkg == "" || is.na(pkg)) {
         stop("Invalid `pkg`.", call. = FALSE)
@@ -116,16 +109,15 @@
     if (isTRUE(.is_github(pkg))) {
         return(paste0("github::", .clean_suffixes(pkg)))
     }
-    if(is.null(bioc_version)){
-        return(paste0("cran::", .clean_suffixes(pkg)))
-    } else{
-        if(isTRUE(.is_bioc(pkg,bioc_version))){
-            return(paste0("bioc::", .clean_suffixes(pkg)))
-        } else{
-            return(paste0("cran::", .clean_suffixes(pkg)))
-        }
+    if (isTRUE(.is_local(pkg))) {
+        return(paste0("local::", .clean_suffixes(pkg)))
     }
+    if (isTRUE(.is_bioc(pkg, bioc_version))) {
+        return(paste0("bioc::", .clean_suffixes(pkg)))
+    }
+    paste0("cran::", .clean_suffixes(pkg))
 }
+
 ## vectorize
 .normalize_pkgs <- function(pkgs,bioc_version = NULL) {
     vapply(X = pkgs, bioc_version = bioc_version ,FUN = .normalize_pkg, FUN.VALUE = character(1), USE.NAMES = FALSE)