R/docker.R

In jimbrig/jimstemplates: Collection of templates

#' Use Docker
#'
#' Add or modify the Dockerfile in the current project.
#'
#' @param rver Which r version to use, defaults to current version.
#' @param stack Which stack to use, possible values are `c("r-ver", "rstudio", "tidyverse", "verse", "geospatial")`.
#' @param date Which date should be used for package instalation, defaults to today.
#' @param file Which file to save to
#' @param open Open the newly created file for editing? Happens in RStudio, if applicable, or via utils::file.edit() otherwise.
#' @name docker
#' @export

#' @importFrom glue glue
#' @importFrom usethis use_template
use_docker <- function(dir = getwd(),
                       rver = NULL,
                       stack = "verse",
                       date = Sys.Date(),
                       file = "Dockerfile",
                       open = TRUE) {

  deps_path <- fs::path(dir, "deps.yaml")

  if (!file.exists(deps_path)) {
    usethis::ui_warn("No deps.yaml file found. Creating deps.yaml..")
    create_deps_yaml(dir)
  }

  deps <- yaml::read_yaml(file = deps_path)

  if (is.null(rver)) {
    rver <- glue::glue(R.version$major, ".", R.version$minor)
  }
  usethis::use_template(
    "Dockerfile",
    file,
    data = list(rver = rver,
                stack = stack,
                date = date),
    ignore = FALSE,
    open = open,
    package = "jimstemplates"
  )
}

create_deps_yaml <- function (directory = getwd()) {

  pkg_names <- get_dependent_packages(directory) %>% unique()
  lapply(pkg_names, get_package_details) %>% yaml::as.yaml() %>%
    cat(file = file.path(directory, "deps.yaml"))
}

get_dependent_packages <- function (directory = getwd())
{
  fls <- list.files(path = directory, pattern = "^.*\\.R$|^.*\\.Rmd$",
                    full.names = TRUE, recursive = TRUE)
  pkg_names <- unlist(sapply(fls, parse_packages))
  pkg_names <- unique(pkg_names)
  if (length(pkg_names) == 0) {
    message("warning: no packages found in specified directory")
    return(invisible(NULL))
  }
  return(unname(pkg_names))
}

get_lines <- function (file_name) {
  if (grepl(".Rmd", file_name, fixed = TRUE)) {
    tmp.file <- tempfile()
    knitr::purl(input = file_name, output = tmp.file, quiet = TRUE)
    file_name <- tmp.file
  }
  lns <- tryCatch(formatR::tidy_source(file_name, comment = FALSE,
                                       blank = FALSE, arrow = TRUE, brace.newline = TRUE, output = FALSE)$text.mask,
                  error = function(e) {
                    message(paste("Could not parse R code in:",
                                  file_name))
                    message("   Make sure you are specifying the right file name")
                    message("   and check for syntax errors")
                    stop("", call. = FALSE)
                  })
  if (is.null(lns))
    stop("No parsed text available", call. = FALSE)
  return(lns)
}

finder <- function (rgx, lns) {
  regmatches(lns, gregexpr(rgx, lns, perl = TRUE)) %>% unlist()
}

parse_packages <- function (fl) {
  lns <- get_lines(fl)
  rgxs <- list(library = "(?<=(library\\()|(library\\([\"']{1}))[[:alnum:]|.]+",
               require = "(?<=(require\\()|(require\\([\"']{1}))[[:alnum:]|.]+",
               colon = "[[:alnum:]|.]*(?=:{2,3})")
  found_pkgs <- purrr::map(rgxs, finder, lns = lns) %>% unlist() %>%
    unique()
  found_pkgs <- found_pkgs[!found_pkgs %in% c("", " ")]
  return(found_pkgs)
}

get_package_details <- function(pkg_name) {
  pkg_d <- packageDescription(pkg_name)
  is.cran <- !is.null(pkg_d$Repository) && pkg_d$Repository ==
    "CRAN"
  is.github <- !is.null(pkg_d$GithubRepo)
  is.base <- !is.null(pkg_d$Priority) && pkg_d$Priority ==
    "base"
  if (!is.cran & !is.github & !is.base)
    stop("CRAN or GitHub info for ", pkg_name, " not found. Other packages repos are not supported.",
         call. = FALSE)
  if (is.cran)
    return(pkg_d[c("Package", "Repository", "Version")])
  if (is.github)
    return(pkg_d[c("Package", "GithubUsername",
                   "GithubRepo", "GithubRef", "GithubSHA1")])
}

#' Add dependencies to Dockerfile
#'
#' Adds package dependencies as a new RUN statement to Dockerfile.
#' Sorts packages first into source (cran & github) and then alphabetically.
#'
#' @param packages Which packages to add.
#' @param github Are there github packages?
#' @param strict Defaults to TRUE, force a specific version for github packages.
#' @param file Where is the 'Dockerfile'?
#' @param write Should the 'Dockerfile' be modified?
#' @param open Should the file be opened?
#' @param append Should the return value be appended to the 'Dockerfile'?
#' @export
#' @importFrom stringr str_detect
#' @importFrom usethis ui_warn ui_code ui_stop
use_docker_packages <- function(packages,
                                github = NULL,
                                strict = TRUE,
                                file = "Dockerfile",
                                write = TRUE,
                                open = write,
                                append = TRUE) {

  # github stuff has these symbols
  on_github <- packages[stringr::str_detect(packages, "[/|@]")]
  # everything else is assumed to be on cran
  on_cran <- packages[!(packages %in% on_github)]
  if (!isTRUE(github) & (length(on_github) > 0)) {
    usethis::ui_warn("Some packages seem to come from GitHub.
            Set {usethis::ui_code('github = TRUE')} to silence this warning.")
  }
  if (isTRUE(strict) & any(!stringr::str_detect(on_github, "@"))) {
    usethis::ui_stop("Some github packages are without fixed version. Use the following scheme:
            {usethis::ui_code('author/package@version')}
            version can be a git tag or hash or
            set {usethis::ui_code('strict = FALSE')} on your own risk.")
  }

  # sort alphabetically and remove duplicates
  on_github <- unique(on_github)
  on_github <- sort(on_github)
  on_cran <- unique(on_cran)
  on_cran <- sort(on_cran)

  # construct Dockerfile entries
  # and write them appended to Dockerfile
  to_write <- character()

  if (length(on_cran) > 0) {
    cran_entry <- docker_entry_install(on_cran,
                                       "install2.r",
                                       "--error --skipinstalled")
    to_write <- c(to_write, cran_entry)
  }
  if (length(on_github) > 0) {
    github_entry <- docker_entry_install(on_github, "installGithub.r")
    to_write <- c(to_write, github_entry)
  }
  docker_entry(to_write, file, write, open, append, quiet = TRUE)
}

#' @importFrom stringr str_c
use_docker_apt <- function(apt, update = TRUE, file = "Dockerfile", write = TRUE, open = write, append = TRUE){
  if(length(apt) == 0L)return(NULL)
  to_write <- "RUN "
  if(update)to_write <- stringr::str_c(to_write, "apt-get update -y && ")
  to_write <- stringr::str_c(to_write, "apt-get install -y ")
  to_write <- stringr::str_c(to_write, stringr::str_c(apt, collapse = " "))
  docker_entry(to_write, file, write, open, append, quiet = TRUE)
}

#' @importFrom fs file_exists
#' @importFrom glue glue
#' @importFrom usethis ui_oops ui_path ui_todo ui_code proj_path ui_done ui_value edit_file
#' @importFrom xfun read_utf8 write_utf8
docker_entry <- function(entry, file = "Dockerfile", write, open, append, quiet = FALSE) {
  if (!fs::file_exists(file)) {
    usethis::ui_oops(glue::glue("There is no {usethis::ui_path(file)}!"))
    usethis::ui_todo(
      glue::glue(
        "Run {usethis::ui_code('use_docker()')} to create {usethis::ui_path(file)}."
      )
    )
    return(invisible(NULL))
  }
  # read dockerfile
  path <- usethis::proj_path(file)
  dockerfile <- xfun::read_utf8(path)
  if (!quiet) {
    usethis::ui_done("Adding {usethis::ui_value(entry)} to {usethis::ui_path(file)}")
  }
  if (append) entry <- c(dockerfile, entry)
  if (write) {
    xfun::write_utf8(entry, path)
    if (open) {
      usethis::edit_file(path)
    }
    return(invisible(entry))
  } else {
    return(entry)
  }
}

#' @importFrom stringr str_c
docker_entry_install <- function(packages, cmd, flags = NULL){
  entry <- stringr::str_c("RUN", cmd, flags, "\\\ ", sep = " ")
  if (length(packages) == 1L){
    entry <- c(entry, stringr::str_c("  ", packages))
  } else {
    entry <- c(entry,
               stringr::str_c("  ", packages[-length(packages)], " \\\ "),
               stringr::str_c("  ", packages[length(packages)]))
  }
  entry
}

#' @importFrom stringr str_detect
docker_get_install <- function(dockerfile){
  starts <- stringr::str_detect(dockerfile, "^(RUN install)(.*)(\\.)[Rr](.*)$")
  possible_range <- c(rep(which(starts), each = 2L)[-1], length(dockerfile))
  possible_list <- apply(matrix(possible_range, ncol = 2L), 1, function(x)list(x))
  possible_pos <- lapply(possible_list, function(x)seq(x[[1]][1], x[[1]][2]))
  possible <- lapply(possible_pos, function(x)dockerfile[x])
  pos_raw <- lapply(possible, function(x)which(stringr::str_detect(x, "^(  )")))
  out <- vector("list", length(pos_raw))
  for (i in seq_along(pos_raw)) {
    out[[i]] <- c(possible[[i]][1], possible[[i]][pos_raw[[i]]])
  }
  return(out)
}

#' @importFrom fs file_exists
#' @importFrom glue glue
#' @importFrom stringr str_detect str_extract
#' @importFrom usethis ui_oops ui_path ui_todo ui_code
docker_get_packages <- function(file = "Dockerfile") {
  if (!fs::file_exists(file)) {
    usethis::ui_oops(glue::glue("There is no {usethis::ui_path(file)}!"))
    usethis::ui_todo(
      glue::glue(
        "Run {usethis::ui_code('use_docker()')} to create {usethis::ui_path(file)}."
      )
    )
    return(invisible(NULL))
  }else{
    dockerfile <- readLines(file)
  }
  entry <- docker_get_install(dockerfile)
  packages_raw <- lapply(entry, function(x)x[stringr::str_detect(x, "^(  )")])
  packages <- lapply(packages_raw, function(x)stringr::str_extract(x, "[a-zA-z]+"))
  packages_sorted <- sort(unique(unlist(packages)))
  return(packages_sorted)
}

#' @importFrom stringr str_extract_all str_c str_to_lower str_remove
dir2imagename <- function(dir){
  dir <- basename(dir)
  stopifnot(length(dir) == 1L)
  dir <- stringr::str_extract_all(dir, "[A-z0-9]")[[1]]
  dir <- stringr::str_c(dir, collapse = "")
  dir <- stringr::str_to_lower(dir)
  dir <- stringr::str_remove(dir, "^[0-9]")
  dir
}