R/infrastructure.R

In krlmlr/rextdata: Simple Access to Data Stored in "extdata" Directory

#' Prepare a package for rextdata
#'
#' Adds the \code{rextdata} package to the \code{Imports} section of the
#' \code{DESCRIPTION}, creates a helper file that loads all external data
#' sets via \code{\link{auto_extdata}}, and converts all existing data sets
#' to \code{extdata} files.
#'
#' @param pkg package description, can be path or package name. See
#'   \code{\link[devtools]{as.package}} for more information.
#' @inheritParams use_extdata
#' @export
use_rextdata <- function(compress = "xz", pkg = ".", overwrite = FALSE) {
  require_devtools()

  pkg <- devtools::as.package(pkg)

  inst_extdata <- inst_extdata_path(pkg)
  if (!file.exists(inst_extdata)) {
    dir.create(inst_extdata, recursive = TRUE, showWarnings = FALSE)
    message("* Created directory inst/extdata")
  }

  write_auto_extdata(pkg)

  loaded <- devtools::load_all(pkg)

  use_extdata_(.dots = loaded$data, pkg = pkg, compress = compress,
               overwrite = overwrite, env = loaded$env)

  message("* Removed data directory")
  unlink(file.path(pkg$path, "data"), recursive = TRUE)

  message("Now include additional datasets as .rds files in the inst/extdata directory.")
}

write_auto_extdata <- function(pkg) {
  file_name <- file.path("R", "aaa-rextdata.R")
  file_path <- file.path(pkg$path, file_name)
  if (!file.exists(file_path)) {
    con <- file(file_path, "w")
    on.exit(close(con))

    writeLines(c("# Autogenerated by rextdata::auto_extdata()", ""), con)

    write_fun("auto_extdata", con)
    write_fun("read_rds", con)
    write_fun("extdata_path", con)
    write_fun("extdata_name", con)
    write_fun("name_from_rds", con)
    write_fun("delayed_assign_", con)
    write_fun("delayed_assign_one", con)

    writeLines("auto_extdata()", con)
    message("* Created helper file ", file_name)
  }
}

write_fun <- function(fun_name, con) {
  writeLines(paste0(fun_name, " <-"), con)
  dput(get(fun_name, mode = "function"), con)
  writeLines("", con)
}

#' Use an object as external dataset
#'
#' Call this function to save an object as \code{.rds} file in the
#' \code{inst/extdata} directory for later retrieval via \code{\link{read_rds}}
#' or \code{\link{auto_extdata}}.
#'
#'
#' @param ... objects to save in \code{name} or \code{name = value} format
#' @param .dots named list of objects to save
#' @param compress a logical specifying whether saving to a named file is to use
#'   \code{"gzip"} compression, or one of \code{"gzip"}, \code{"bzip2"} or
#'   \code{"xz"} to indicate the type of compression to be used.
#' @param overwrite overwrite existing files?
#' @param env the environment in which to evaluate the expressions
#' @inheritParams use_rextdata
#' @include lazyforward.R
"use_extdata"

#' @export
#' @rdname use_extdata
use_extdata_ <- function(..., .dots, pkg = ".", compress = "xz",
                         overwrite = FALSE, env = parent.frame())
{
  dots <- lazyeval::all_dots(.dots, ..., all_named = TRUE)

  if (length(dots) == 0L) return()

  require_devtools()

  pkg <- devtools::as.package(pkg)

  inst_extdata <- inst_extdata_path(pkg)

  files <- file.path(inst_extdata, paste0(names(dots), ".rds"))
  if (!overwrite && any(file.exists(files))) {
    stop("At least one of the target files exists. Use overwrite = TRUE to override.",
         call. = FALSE)
  }

  mapply(
    function(dot, file) {
      object <- lazyeval::lazy_eval(dot, env)
      saveRDS(object, file, compress = compress)
    },
    dots, files)

  message("* Saved datasets ", paste(names(dots), collapse = ", "),
          " to ", inst_extdata)
}

#' @export
use_extdata <- lazyforward("use_extdata_")

require_devtools <- function() {
  loadNamespace("devtools")
}