rpm: An R6-based package manager

rpm.R

library("R6")

rpm <- R6Class("rpm",
  public = list(
    initialize = function() {
      self$update_available()
      self$update_installed()
    },
    use = function(pkgs, quietly = TRUE, ...) {
      self$install(pkgs[!self$installed(pkgs)], quiet = quietly, ...)
      if(quietly) {
        suppressPackageStartupMessages(require(pkgs, character.only = TRUE))
      } else {
        require(pkgs, character.only = TRUE)
      }
    },
    use_temp = function(pkgs, ...) {
      temp <- self$newlib()
      .libPaths(union(.libPaths(), temp))
      self$use(pkgs, lib = temp, ...)
    },
    set_repos = function(repos, add = FALSE, ...) {
      if(missing(repos)) {
        setRepositories(...)
      } else {
        if(add)
          options(repos = c(repos, getOption(repos, NULL)))
        else
          options(repos = repos)
      }
    },
    is_available = function(pkgs) {
      setNames(pkgs %in% dimnames(private$p_available)[[1]], pkgs)
    },
    is_installed = function(pkgs) {
      setNames(pkgs %in% dimnames(private$p_available)[[1]], pkgs)
    },
    loaded = function() {
      loadedNamespaces()
    },
    attached = function() {
      s = search()
      g <- grepl("package:", s, fixed = TRUE)
      gsub("package:", "", s[g], fixed = TRUE)
    },
    install = function(pkgs, version, as, quietly = TRUE, ...) {
      if(!missing(as)) {
        dir <- tempdir()
        if(missing(version)) {
          d <- download.packages(pkgs, destdir = dir, type = "source", quiet = quietly)
          d <- cbind(d, as)
        } else {
          pkgs <- paste0(getOption("repos"), "/src/contrib/Archive/", pkgs, "/", pkgs, "_", version, ".tar.gz")
          d <- download.packages(contriburl = pkgs, destdir = dir, quiet = quietly)
          d <- cbind(d, d[,1])
        }
        apply(d, 1, function(x) {
          tmp <- tempdir()
          untar(x[,2], exdir = tmp)
          dcf <- read.dcf(paste0(tmp, "/", x[,1], "/DESCRIPTION"))
          dcf[,"Package"] <- x[,3]
          write.dcf(x = dcf, file = paste0(tmp(), "/", x[,1]))
          file.rename(paste0(tmp, "/", x[,1]), paste0(tmp, "/", x[,3]))
          install.packages(paste0(tmp, "/", x[,3]), repos = NULL, type = "source", quiet = quietly, ...)
        })
      } else {
        if(missing(version)) {
          self$detach(pkgs, unload = TRUE)
          install.packages(pkgs = pkgs, quiet = quietly, ...)
        } else {
          self$detach(pkgs, unload = TRUE)
          pkgs <- paste0(getOption("repos"), "/src/contrib/Archive/", pkgs, "/", pkgs, "_", version, ".tar.gz")
          sapply(pkgs, install.packages, repos = NULL, type = "source", quiet = quietly, ...)
        }
      }
      self$update_installed()
    },
    install_github = function(pkgs, ...){
      d <- self$describe(pkgs)
      # can build a github URL if d `RemoteType` is "github"
      # RemoteUsername
      # RemoteRef
      # devtools::install_github
    },
    update = function(pkgs = NULL, ask = TRUE, ...) {
      update.packages(oldPkgs = pkgs, ask = ask, ...)
    },
    update_github = function(pkgs, ...) {
      dtupdate::github_update(...)
      # need to send patch to allow passing of `pkgs` arguments
      # https://github.com/hrbrmstr/dtupdate/blob/master/R/dtupdate.R
    },
    uninstall = function(pkgs, ...) {
      # need to deal with dependencies:
      # http://stackoverflow.com/questions/26573368/uninstall-remove-r-package-with-dependencies/26633042#26633042
      remove.packages(pkgs, ...)
    },
    update_available = function() {
      private$p_available <- available.packages()
    },
    update_installed = function() {
      private$p_installed <- installed.packages()
    },
    loadns = function(pkgs) {
      invisible(sapply(pkgs, loadNamespace))
    }, 
    unloadns = function(pkgs) {
      # this won't work with dependencies
      sapply(pkgs, unloadNamespace)
    }, 
    attachns = function(pkgs) {
      sapply(pkgs, attachNamespace)
    },
    detachns = function(pkgs, unload = FALSE) {
      sapply(paste0("package:",pkgs), detach, character.only = TRUE, unload = unload)
    },
    is_loaded = function(pkgs) {
      setNames(pkgs %in% loadedNamespaces(), pkgs)
    },
    is_attached = function() {
      setNames(paste0("package:",pkgs) %in% search(), pkgs)
    },
    load_as = function(pkgs, names, envir = .GlobalEnv, attach = FALSE, apos = 2L, ...) {
      mapply(function(p, n) {
        s <- self$loadns(p)[[1]]
        assign(n, s, envir = envir, ...)
        if(attach) {
          attach(s, name = n, pos = apos)
        }
      }, pkgs, names)
      return(names)
    },
    
    # dependencies
    depends_on = function(pkgs) {
      tools::package_dependencies(packages = pkgs, private$p_available, reverse = FALSE)
    },
    rev_depends_on = function(pkgs) {
      tools::package_dependencies(packages = pkgs, private$p_available, reverse = TRUE)
    },
    
    # libraries
    libs = function() {
      .libPaths()
    },
    newlib = function(dir) {
      if(missing(dir)) {
        tempdir()
      } else {
        x <- try(dir.create(dir))
        if(inherits(x, "try-error"))
          stop("Could not create directory")
        dir
      }
    },
    
    # package metadata
    describe = function(pkgs, fields = NULL) {
      sapply(pkgs, packageDescription, fields = fields)
    },
    maintainer = function(pkgs) {
      setNames(self$describe(pkgs, fields = "Maintainer"), pkgs)
    },
    version = function(pkgs) {
      setNames(self$describe(pkgs, fields = "Version"), pkgs)
    },
    description = function(pkgs) {
      setNames(self$describe(pkgs, fields = "Description"), pkgs)
    },
    license = function(pkgs) {
      setNames(self$describe(pkgs, fields = "License"), pkgs)
    },
    
    #help = function(pkgs) {
    #  for(i in seq_along(pkgs))
    #    library(help = pkgs[i], character.only = TRUE)
    #},
    
    # find a package by search query
    find = function(pattern, ignore.case = TRUE, ...) {
      g1 <- grep(pattern = pattern, x = dimnames(private$p_installed)[[1]], ignore.case = ignore.case, ...)
      r1 <- private$p_installed[g1,c("Version", "Depends", "Imports", "Suggests", "License"), drop = FALSE]
      
      a <- private$p_available[!dimnames(private$p_available)[[1]] %in% dimnames(private$p_installed)[[1]], ]
      g2 <- grep(pattern = pattern, x = dimnames(a)[[1]], ignore.case = ignore.case, ...)
      r2 <- a[g2,c("Version", "Depends", "Imports", "Suggests", "License"), drop = FALSE]
      list(installed = r1, available = r2)
    },
    
    # something from smbache/imports?
    
    # something to load arbitrary code as a package
    
    # override default R6 print method
    print = function() {
      cat("Attached: ", paste0(self$attached(), collapse = ", "))
      cat("\nLoaded:   ", paste0(self$loaded(), collapse = ", "), "\n")
    }
  ),
  private = list(
    p_available = NA,
    p_installed = NA,
    install_rtools = function() {
      # on Windows, install Rtools if needed to build packages
      # https://github.com/talgalili/installr/blob/b6fef3c2d3dde5f13c144209a3e669a29006bac1/R/install.R#L437
    }
  )
)

pkg <- rpm$new()
pkg