From a90a1f37e007c8d5676332f387600aca4a9966c3 Mon Sep 17 00:00:00 2001
From: Ricardo Wurmus <rekado@elephly.net>
Date: Tue, 9 Feb 2021 12:51:02 +0100
Subject: Initial commit.

---
 README         |  14 ++++++++
 guix-install.R | 104 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 118 insertions(+)
 create mode 100644 README
 create mode 100644 guix-install.R

diff --git a/README b/README
new file mode 100644
index 0000000..a9c9d98
--- /dev/null
+++ b/README
@@ -0,0 +1,14 @@
+This R package provides a single procedure =guix.install=, which
+allows R users to install R packages via Guix right from within their
+running R session.
+
+If the requested R package does not exist in Guix at this time, the
+package and all its missing dependencies will be imported recursively
+and the generated package definitions will be written to
+=~/.Rguix/packages.scm=.  This record of imported packages can be used
+later to reproduce the environment, and to add the packages in
+question to a proper Guix channel (or Guix itself).
+
+=guix.install= not only supports installing packages from CRAN, but
+also from Bioconductor or even arbitrary git or mercurial
+repositories, replacing the need for installation via devtools.
\ No newline at end of file
diff --git a/guix-install.R b/guix-install.R
new file mode 100644
index 0000000..2766aa1
--- /dev/null
+++ b/guix-install.R
@@ -0,0 +1,104 @@
+## TODO:
+## - allow installation of more than one package
+
+guix.install <- function (package, profile = NULL, guix = "guix", archive = NULL)
+{
+    if (is.null (profile)) {
+        ## Use the default profile unless otherwise specified.
+        guix_profile <- Sys.getenv ("GUIX_PROFILE", unset = NA)
+        if (is.na (guix_profile)) {
+            profile <- paste (Sys.getenv ("HOME"), ".guix-profile", sep = "/")
+        } else {
+            profile <- guix_profile
+        }
+    } else {
+        ## Create the parent directory if necessary.
+        parent <- dirname (profile)
+        if (! dir.exists (parent)) {
+            dir.create (parent, recursive = TRUE)
+        }
+    }
+
+    ## Location of on-the-fly generated packages
+    scratch <- paste (Sys.getenv ("HOME"), ".Rguix", "packages.scm", sep = "/")
+
+    ## split package path, put scratch location first
+    package_path <- NULL
+    old_package_path <- Sys.getenv ("GUIX_PACKAGE_PATH")
+    entries <- strsplit (old_package_path, ":")[[1]]
+    package_path <- paste (unique (c(dirname (scratch), entries)), sep = ":")
+    Sys.setenv (GUIX_PACKAGE_PATH=package_path)
+
+    is_url <- length (grep ("^https?://", package)) > 0
+
+    if (!is_url) {
+        ## The normalized name used by Guix packages
+        guix_name <- paste0 ("r-", gsub ("[^a-z0-9]", "-", tolower (package)))
+
+        ## Does the package already exist?
+        error <- system2 (guix, c("show", guix_name),
+                          stdout = NULL, stderr = NULL)
+    }
+    
+    ## Attempt to import the package
+    if (is_url || (error > 0)) {
+        ## Build a scratch module
+        if (! dir.exists (dirname (scratch))) {
+            dir.create (dirname (scratch), recursive = TRUE)
+        }
+        if (! file.exists (scratch)) {
+            cat ("
+(define-module (packages)
+  #:use-module (gnu)
+  #:use-module (guix)
+  #:use-module (guix git-download)
+  #:use-module (guix hg-download)
+  #:use-module (guix build-system r)
+  #:use-module (guix licenses))
+", file = scratch)
+        }
+
+        if (is.null (archive)) {
+            archive <- if (is_url) {
+                           "git" # TODO: what about hg?
+                       } else {
+                           ## The importer will retry importing from CRAN if a
+                           ## package is not found on Bioconductor.
+                           "bioconductor"
+                       }
+        }
+
+        definitions <- suppressWarnings (system2 (guix, c("import", "cran",
+                                                          "--recursive",
+                                                          "--style=specification",
+                                                          paste ("--archive", archive, sep = "="),
+                                                          package),
+                                                  stdout = TRUE))
+
+        ## Abort on error
+        status <- attr (definitions, "status")
+        if (!is.null (status) && (status > 0)) {
+            stop (paste("Failed to import", package))
+        }
+
+        ## Get guix_name from definitions
+        pattern <- "\\(name \"([^\"]+)\"\\)"
+        name <- grep (pattern, definitions, value = TRUE)
+        guix_name <- sub (pattern, "\\1", name)
+
+        ## Store generated package definitions.
+        cat (";; Imported from within R at ", date(), "\n",
+             file = scratch, append = TRUE)
+        cat (definitions, sep = "\n",
+             file = scratch, append = TRUE)
+    }
+
+    ## Install the package.
+    error <- system2 (guix, c("package", paste ("--profile", profile, sep = "="),
+                              "--install", guix_name))
+
+    ## Extend the R load path.
+    if (error == 0) {
+        .libPaths (paste (profile, "site-library", sep = "/"))
+    }
+}
-- 
cgit v1.2.3