Implemented caching for transitive dependencies.

com.oracle.truffle.r.test.packages/r/install.package.R

@@ -28,6 +28,81 @@
 # args:
 # pkgname, contriburl, lib
 
+log.message <- function(..., level=0) {
+    cat(..., "\n")
+}
+
+ignored.packages <- c("boot", "class", "cluster", "codetools", "foreign", "KernSmooth", "lattice", "MASS", "Matrix", "mgcv", "nlme", "nnet", "rpart", "spatial", "survival", "base", "compiler", "datasets", "grDevices", "graphics", "grid", "methods", "parallel", "splines", "stats", "stats4", "tools", "utils")
+
+package.dependencies <- function(pkg, lib, dependencies = c("Depends", "Imports", "LinkingTo"), pl = available.packages()) {
+    if (!(pkg %in% rownames(pl))) {
+        # TODO: logging
+        cat("Package", pkg, "not on CRAN\n")
+        return (NULL)
+    }
+    fields <- pl[pkg, dependencies]
+    fields <- fields[!is.na(fields)]
+
+    # remove newline artefacts '\n' and split by ','
+    deps <- unlist(strsplit(gsub("\\n", " ", fields), ","))
+
+    # remove version
+    deps <- trimws(sub("\\(.*\\)", "", deps))
+
+    # ignore dependency to "R" and ignore already installed packages
+    installed.packages <- tryCatch({
+        # query base and recommended packages
+        ip <- available.packages(lib.loc=lib)
+        ip[as.logical(match(ip[,"Priority"], c("base", "recommended"), nomatch=0L)),"Package"]
+        installed.pacakges(lib.loc=lib)
+    }, error = function(e) {
+        character(0)
+    }, warning = function(e) {
+        character(0)
+    })
+    setdiff(deps, c("R", installed.packages, ignored.packages))
+}
+
+transitive.dependencies <- function(pkg, lib, pl = available.packages(), deptype=c("Depends", "Imports", "LinkingTo"), suggests=FALSE) {
+    deps <- c()
+    more <- pkg
+
+    # Also add "Suggests" to dependencies but do not recurse
+    if (suggests) {
+        this.suggests <- package.dependencies(pkg, dependencies = "Suggests", pl = pl)
+        if (!is.null(this.suggests)) {
+            more <- c(more, this.suggests)
+        }
+    }
+
+    #  TODO: improve list operations for better performance
+    processed <- character(0)
+
+    # the loop can't have more iterations then available packages
+    max.iterations <- nrow(pl)
+    iteration <- 0L
+    while (length(more) > 0) {
+        if (iteration >= max.iterations) {
+            stop("Maximum number of iterations exceeded")
+        }
+        this <- head(more, 1)
+        more <- tail(more, -1)
+
+        if (!(this %in% processed)) {
+            cat("processing ", this, "\n")
+            processed <- unique(c(processed, this))
+            this.deps <- package.dependencies(this, lib, dependencies = deptype, pl = pl)
+            if (!is.null(this.deps)) {
+                deps <- c(deps, this.deps)
+                more <- c(more, this.deps[!(this.deps %in% processed)])
+            }
+        }
+
+        iteration <- iteration + 1L
+    }
+    unique(deps)
+}
+
 args <- commandArgs(TRUE)
 
 parse.args <- function() {
@@ -35,14 +110,49 @@ parse.args <- function() {
 		pkgname <<- args[[1]]
 		contriburl <<- strsplit(args[[2]], ",")[[1]]
 		lib.install <<- args[[3]]
+
+        pkg.cache <<- as.environment(list(enabled=FALSE, table.file.name="version.table", size=2L))
+        pkg.cache$enabled <- as.logical(args[[4]])
+        cat("system.install, cache enabled: ", pkg.cache$enabled, "\n")
+        if (pkg.cache$enabled) {
+		    pkg.cache$version <- args[[5]]
+		    pkg.cache$dir <- args[[6]]
+        }
 	}
 }
 
+# return code: sucess == 0L, error == 1L
 run <- function() {
     parse.args()
+
     tryCatch({
-        res <- install.packages(pkgname, contriburl=contriburl, type="source", lib=lib.install, INSTALL_opts="--install-tests")
-        if (res == NULL) 0L else 1L
+        # determine available packages
+        pkg.list <- available.packages(contriburl=contriburl)
+
+        # compute transitive dependencies of the package to install
+        cat("Computing transitive package hull for ", pkgname, "\n")
+        transitive.pkg.list <- c(transitive.dependencies(pkgname, lib=lib.install, pl=pkg.list), pkgname)
+        cat("transitive deps: ", transitive.pkg.list, "\n")
+
+        # apply pkg cache to fetch cached packages first
+        cat("Fetching from cache if possible\n")
+        cached.pkgs <- sapply(transitive.pkg.list, function(pkgname) pkg.cache.get(pkg.cache, pkgname, lib.install))
+        cat("Number of cached pkgs: ", length(cached.pkgs), "\n")
+
+        # if there was at least one non-cached package
+        if (any(!cached.pkgs) || length(cached.pkgs) == 0L) {
+            # install the package (and the transitive dependencies implicitly)
+            res <- install.packages(pkgname, contriburl=contriburl, type="source", lib=lib.install, INSTALL_opts="--install-tests")
+            if (res == NULL) {
+                # cache packages that were not in the cache before
+                lapply(transitive.pkg.list[!cached.pkgs], function(pkgname) pkg.cache.insert(pkg.cache, pkgname, lib.install))
+            } else {
+                return (1L)
+            }
+        }
+
+        # if we reach here, installation was a success
+        0L
     }, error = function(e) {
         cat(e$message, "\n")
         return (1L)
@@ -52,6 +162,29 @@ run <- function() {
     })
 }
 
+# Determines the directory of the script assuming that there is a "--file=" argument on the command line.
+getCurrentScriptDir <- function() {
+     cmdArgs <- commandArgs()
+     res <- startsWith(cmdArgs, '--file=')
+     fileArg <- cmdArgs[res]
+     if (length(fileArg) > 0L) {
+         p <- strsplit(fileArg, "=")[[1]][[2]]
+         dirname(p)
+     } else {
+        NULL
+     }
+}
+
+# load package cache code
+curScriptDir <- getCurrentScriptDir()
+if (!is.null(curScriptDir)) {
+    source(file.path(curScriptDir, "install.cache.R"))
+} else {
+    log.message("Cannot use package cache since script directory cannot be determined")
+    pkg.cache.get <<- function(...) FALSE
+    pkg.cache.insert <<- function(...) FALSE
+}
+
 if (!interactive()) {
 	status.code <- run()
     quit(status = status.code)

com.oracle.truffle.r.test.packages/r/install.packages.R

@@ -725,19 +725,30 @@ fastr_error_log_size <- function() {
 install.pkg <- function(pkgname) {
 	error_log_size <- fastr_error_log_size()
 	if (run.mode == "system") {
-        system.install.wrapper <- function() {
-            tryCatch(
-                     system.install(pkgname)
-            , error = function(e) {
-                log.message(e$message)
-                return (1)
-            }, warning = function(e) {
-                log.message(e$message)
-                # According to the documentation of 'system2', a warning will provide a status field.
-                return (e$status)
-            })
-        }
-        pkg.cache.install(pkg.cache, pkgname, lib.install, system.install.wrapper)
+        #system.install.wrapper <- function() {
+            #tryCatch(
+                     #system.install(pkgname)
+            #, error = function(e) {
+                #log.message(e$message)
+                #return (1L)
+            #}, warning = function(e) {
+                #log.message(e$message)
+                ## According to the documentation of 'system2', a warning will provide a status field.
+                #return (e$status)
+            #})
+        #}
+        #pkg.cache.install(pkg.cache, pkgname, lib.install, system.install.wrapper)
+
+        tryCatch(
+                 system.install(pkgname)
+        , error = function(e) {
+            log.message(e$message)
+            1L
+        }, warning = function(e) {
+            log.message(e$message)
+            # According to the documentation of 'system2', a warning will provide a status field.
+            e$status
+        })
 	} else if (run.mode == "internal") {
         internal.install.wrapper <- function() {
             tryCatch(
@@ -788,8 +799,11 @@ system.install <- function(pkgname) {
 	} else {
 		rscript = gnu_rscript()
 	}
-	args <- c(script, pkgname, paste0(contrib.url(getOption("repos"), "source"), collapse=","), lib.install)
-	rc <- system2(rscript, args)
+    args <- c(script, pkgname, paste0(contrib.url(getOption("repos"), "source"), collapse=","), lib.install, as.character(pkg.cache$enabled))
+    if (pkg.cache$enabled) {
+         args <- c(args, pkg.cache$version, pkg.cache$dir)
+    } 	
+    rc <- system2(rscript, args)
 	rc
 }
 
@@ -1055,16 +1069,6 @@ getCurrentScriptDir <- function() {
 
 run <- function() {
     parse.args()
-
-    if (pkg.cache$enabled) {
-        curScriptDir <- getCurrentScriptDir()
-        if (!is.null(curScriptDir)) {
-            source(file.path(curScriptDir, "install.cache.R"))
-        } else {
-            log.message("Cannot use package cache since script directory cannot be determined")
-        }
-    }
-
     if (find.top100) {
         set.repos()
         do.find.top100()
@@ -1074,6 +1078,19 @@ run <- function() {
     }
 }
 
+# load package cache code
+curScriptDir <- getCurrentScriptDir()
+if (!is.null(curScriptDir)) {
+    source(file.path(curScriptDir, "install.cache.R"))
+} else {
+    log.message("Cannot use package cache since script directory cannot be determined")
+
+    # avoid errors
+    pkg.cache.install <<- function(...) FALSE
+    pkg.cache.get <<- function(...) FALSE
+    pkg.cache.insert <<- function(...) FALSE
+}
+
 quiet <- F
 repo.list <- c("CRAN")
 pkg.cache <- as.environment(list(enabled=FALSE, table.file.name="version.table", size=2L))