R/install.R

In jalgos/jsroot: Basic toolset to start a Jalgos project

#' Templating filenames
#'
#' Tool to templatize filenames. Useful when needing a ressource that depends on the local configuration
#' @param fn Template filename
#' @aliases replace.variables
#' @param subs named list that associates template variable and their values
#' @examples transform.filename("$wd/$dperl/my.script.$scnum.pl", c("$wd" = ".", "$dperl" = "perl", "$scnum" = "10"))
#' @details The names in subs are regex patterns. Any matching regex patterns will be replaced by the value. To avoid replacing parts of words it is advised to start the template variable by a character that is not found in the string to replace. '$%' can be used for example. \cr
#' replace.variables is an alias.
#' @export transform.filename
transform.filename <- function(fn, subs = base.sub.list)
{
    if(is.null(subs)) return(fn)
    subs[sapply(subs, is.null)] <- ""

    NM <- sort(names(subs), decreasing = TRUE)
    for(nm in NM)
    {
        pat <- gsub(x = nm, pattern = "\\$", replacement = "\\\\$")
        fn <- as.vector(sapply(fn, {function(fn, repls) sapply(repls, function(repl) gsub(x = fn, pattern = pat, replacement = repl))}, repls = subs[[nm]]))
    }
    return(fn)
}

#' @rdname transform.filename
#' @export
replace.variables <- transform.filename

make.jalgos.url <- function(name,
                            group,
                            remote.pattern = 'git@www.datasaiyan.com:%s/%s.git',
                            ...)
{
    sprintf('git@www.datasaiyan.com:%s/%s.git', group, name)
}
                            
git.command <- function(url,
                        package.loc,
                        branch = version,
                        version = NULL,
                        ...)
{
    subl <- list('%url' = url,
                 '%loc' = package.loc)
    if(is.null(branch) && is.null(version))
    {
        command <- "git clone %url %loc"
    }
    else
    {
        command <- "git clone -b %branch %url %loc"
        subl <- c(subl, list('%branch' = branch))
    }
    replace.variables(command, subl)
}

#' Installing C++ Jalgos Library
#'
#' Will fetch git project located at url `url` into location in `pkg.loc` and will compile and install the project. Removes `pkg.loc` at the end of the process
#' @param url url of the package to compile and install
#' @param pkg.loc Temporary location where to checkout the package
#' @export
install.jslib <- function(url,
                          pkg.loc = make.tmp.pkg.loc(),
                          ...)
{
    command <- git.command(url,
                           pkg.loc,
                           ...)
    cur.loc <- getwd()
    on.exit({ setwd(cur.loc); system(sprintf("rm -Rf %s", pkg.loc))})
    system(command)
    setwd(pkg.loc)
    system("mkdir build")
    setwd("build")
    system("cmake ..")
    system("cmake --build . --parallel -j")
    system("cmake --install .")
}

#' Install C++ Jalgos Library
#'
#' Install the C++ libraries that are required for R packages to run.
#' @param name Name of the project
#' @param group Group to which the project belong in remote repo
#' @param lib.name Name of the library generated by the project
#' @param url url of the remote project
#' @param lib.var Name of the environment variable containing the directory to which libraries must be installed
#' @param include.var Name of the environment variable containing the directory to which include files must be installed
#' @param force Force reinstallation even if libraries already exist
#' @export
install.jalgos.lib <- function(name,
                               group,
                               lib.name = name,
                               url = make.jalgos.url(name, group, ...),
                               lib.var = "JALGOS_LIB",
                               include.var = "JALGOS_INCLUDE",
                               force = FALSE,
                               ...)
{
    lib.dir <- Sys.getenv(lib.var)
    if(lib.dir == "")
        stop(sprintf("Lib var variable %s is not defined in the environment variables", lib.var))

    include.dir <- Sys.getenv(include.var)
    if(include.dir == "")
        stop(sprintf("Include var variable %s is not defined in the environment variables", include.var))

    full.lib.name <- sprintf("lib%s.so", lib.name)
    expected.lib.loc <- paste(lib.dir, full.lib.name, sep = "/")

    reinst <- FALSE
    if(!force && file.exists(expected.lib.loc))
    {
        cat("Library:", expected.lib.loc, "already exists\n")
    }
    else
    {
        reinst <- TRUE
    }

    expected.include.dir <- paste(include.dir, lib.name, sep = "/")
    if(!force && dir.exists(expected.include.dir))
    {
        cat("Include directory:", expected.include.dir, "already exists\n")
    }
    else
    {
        reinst <- TRUE
    }

    if(!reinst)
    {
        message(sprintf("Library: %s is already installed", lib.name))
        return()
    }

    install.jslib(url,
                  ...)
}

make.tmp.pkg.loc <- function()
{
    puid <- uuid::UUIDgenerate()
    sprintf("/tmp/RPackage.%s", puid)
}

#' Install Git
#'
#' Installing Jalgos packages with git without using git2r package.
#' @param name Name of the package
#' @param group Gitlab group to which the package belongs
#' @param url Remote url of the package
#' @param install.fun Function to use to install the packages
#' @param branch specify a branch to checkout
#' @export
install.git <- function(name,
                        group,
                        url = make.jalgos.url(name, group, ...),
                        install.fun = function(ploc, ...) install.packages(ploc, repos = NULL, ..., type = 'source'),
                        ...)
{
    puid <- uuid::UUIDgenerate()
    package.loc <- make.tmp.pkg.loc()

    command <- git.command(url,
                           package.loc,
                           ...)
    on.exit(system(sprintf("rm -Rf %s", package.loc)))
    system(command)
    tryCatch(install.fun(package.loc, ...),
             error = function(cond) {
        if(!interactive())
        {
            cat("An error occured while installing package", name, "error message:", cond$message, "quitting with status 1\n")
            quit("no", status = 1L)
        }
        else
            stop(sprintf("An error occured while installing package %s at url: %s, message: %s. Cleaning up before leaving.", name, url, cond$message))
    })
    
}

#' Install From Jalgos Repos
#'
#' Wrapper around install_git to install packages from Jalgos repos (uses git2r)
#' @export
install.jalgos <- function(url,
                           lib.loc = "lib",
                           ...)
{
    withr::with_libpaths(new = lib.loc, remotes::install_git(url))
}

#' @title Install Missing Package
#' @name require.or.install
NULL

#' @describeIn require.or.install Install specified package in case call to \code{require} fails.
#' @param name Name of the package
#' @param install.fun Package installation function to use
#' @param ... to be forwarded to install.fun
#' @param load.fun how should the package be attached 'library' or 'require'
#' @param force force install
#' @param install.missing should we install missing packages
#' @export
require.or.install <- function(name,
                               ...,
                               install.fun = install.git,
                               load.fun = require,
                               require.name = name,
                               force = FALSE,
                               install.missing = TRUE,
                               version = branch,
                               branch = NULL,
                               libpath = 'lib')
{
    if(!is.null(version) && !is.na(numeric_version(version, strict = FALSE)))
    {
        if(suppressWarnings(require(require.name, character = TRUE, lib.loc = libpath)))
        {
            if(packageVersion(require.name, lib.loc = libpath) == version)
                return(TRUE)
        }
        force <- TRUE 
    }
    
    if(install.missing && force ||
       !suppressWarnings(require(require.name, character = TRUE, lib.loc = libpath)))
        do.call(install.fun, list(name, version = version, ...))

    load.fun(require.name, character = TRUE, lib.loc = libpath)
}

file.package.pattern <- "/home/sebastien/Dev/util/jalgos-packages/%s"

#' @describeIn require.or.install For development use. Installs package directly from directory not from remote repo
#' @export
require.or.install.dev <- function(name,
                                   url.pattern = file.package.pattern,
                                   ...)
{
    require.or.install(name,
                       url = sprintf(file.package.pattern, name),
                       ...,
                       install.fun = devtools::install)
}

jsroot.env <- new.env()
jsroot.env$reinstall.cran <- FALSE
jsroot.env$reinstall.github <- FALSE
jsroot.env$reinstall.jalgos <- FALSE
jsroot.env$reinstall.jslib <- FALSE

#' @name force.reinstall
#' @title Force Reinstall
NULL

#' @describeIn force.reinstall When this function is called all the dependencies package will be reinstall when dependencies is called again
#' @export
reinstall.next <- function()
{
    reinstall.cran.next()
    reinstall.jalgos.next()
    reinstall.jslib.next()
    reinstall.github.next()
}

#' @describeIn force.reinstall Will reinstall only the cran packages the next time dependencies is called
#' @export
reinstall.cran.next <- function()
{
    jsroot.env$reinstall.cran <- TRUE
}

#' @describeIn force.reinstall Will reinstall only the jalgos packages the next time dependencies is called
#' @export
reinstall.jalgos.next <- function()
{
    jsroot.env$reinstall.jalgos <- TRUE    
}

#' @describeIn force.reinstall Will reinstall only the jalgos libraires the next time dependencies is called
#' @export
reinstall.jslib.next <- function()
{
    jsroot.env$reinstall.jslib <- TRUE    
}

#' @describeIn force.reinstall Will reinstall only the github packages the next time dependencies is called
#' @export
reinstall.github.next <- function()
{
    jsroot.env$reinstall.github <- TRUE    
}

#' Installing Jalgos Library
#'
#' Will use remotes::install_gitlab to install jalgos librairies with token authentification. Defaults to the GITLAB_PAT environment variable
#' @param name Name of the project
#' @param group Group to which the project belong in remote repo
#' @param version Version of the project to install
#' @param branch Branch of the project to install
#' @param host GitLab API host to use
#' @export
install.gitlab <- function(name,
                           group,
                           version = branch,
                           branch = NULL,
                           host = "datasaiyan.com",
                           ...)
{
    repo <- paste(group, name, sep = "/")
    if(!is.null(version))
        repo <- paste(repo, version, sep = "@")
    remotes::install_gitlab(host = host,
                            repo = repo,
                            ...)
}

#' Dealing With Dependencies
#'
#' Elegantly deals with package dependencies of a project
#' @param libpath Folder in which
#' @param jspackages Jalgos packages. Must have this layout:\cr
#' list(group1 = list(c("jspack1", \cr
#'                                  [branch = "aaa"],\cr
#'                                   ...)),\cr
#'           group2 = ...)
#' @param cran.packages CRAN packages
#' @param ... To be forwarded to the require.or.install function
#' @seealso require.or.install install.git
#' @export
dependencies <- function(libpath = 'lib',
                         jspackages = list(),
                         cran.packages = list(),
                         github.packages = list(),
                         jslibs = list(),
                         force.cran = jsroot.env$reinstall.cran,
                         force.github = jsroot.env$reinstall.github,
                         force.jalgos = jsroot.env$reinstall.jalgos,
                         force.jslibs = jsroot.env$reinstall.jslib,
                         force = FALSE,
                         ...,
                         install.jspackages.fun = install.git)
{
    dir.create(libpath, showWarnings = FALSE)
    .libPaths(libpath)
    lapply(cran.packages,
           function(LP) do.call(jsroot::require.or.install,
                                c(LP,
                                  ...,
                                  list(install.fun = remotes::install_version,
                                       force = force.cran || force,
                                       libpath = libpath))))
    jsroot.env$reinstall.cran <- FALSE

    mapply(names(github.packages),
           github.packages,
           FUN = function(author, LPs)
        lapply(LPs,
               function(LP)
        {
            nmlp <- names(LP)
            ref <- "HEAD"
            if(!is.null(nmlp))
            {
                if("package" %in% nmlp)
                    pk <- LP[["package"]]
                else if("" %in% nmlp)
                    pk <- LP[[which(nmlp == "")]]
                else
                    stop("Package not specified")
                if("version" %in% nmlp)
                    ref <- LP[["version"]]
                else if("tag" %in% nmlp)
                    ref <- LP[["tag"]]
                else if("branch" %in% nmlp)
                    ref <- LP[["branch"]]
            }
            else if(length(LP) == 1)
                pk <- LP[1]
            else
                stop("Package specification should be named")
            do.call(jsroot::require.or.install,
                    c(list(name = pk,
                           ref = ref,
                           repo = paste(author, pk, sep = "/"),
                           install.fun = function(name, ..., version = NULL) remotes::install_github(...),
                           force = force.github || force,
                           version = ref,
                           libpath = libpath),
                      ...))
        }))
        
    jsroot.env$reinstall.github <- FALSE
    
    mapply(names(jslibs),
           jslibs,
           FUN = function(group, LPs)
        lapply(LPs,
               function(LP) do.call(jsroot::install.jalgos.lib,
                                    c(LP,
                                      list(group = group,
                                           force = force.jslibs || force)))))
    jsroot.env$reinstall.jslib <- FALSE

    mapply(names(jspackages),
           jspackages,
           FUN = function(group, LPs)
        lapply(LPs,
               function(LP) do.call(jsroot::require.or.install,
                                    c(LP,
                                      list(install.fun = install.jspackages.fun, 
                                           group = group,
                                           force = force.jalgos || force,
                                           libpath = libpath)))))
    jsroot.env$reinstall.jalgos <- FALSE
}