Make progress on return_rds()

Only return_fst() and return_keras() remain.

R/cache.R

@@ -582,6 +582,7 @@ cached <- function(
   if (is.null(cache)) {
     return(character(0))
   }
+  cache <- decorate_storr(cache)
   if (is.null(namespace)) {
     namespace <- cache$default_namespace
   }

R/decorated_storr.R

@@ -37,22 +37,27 @@ refclass_decorated_storr <- methods::setRefClass(
   # prevent users from supplying their own true `storr`s.
   methods = list(
     # Custom:
-    file_return_hash = function(hash) {
+    assert_dirs = function() {
       dir_create(.self$path_return)
+      dir_create(.self$path_tmp)
+    },
+    file_return_hash = function(hash) {
       file.path(.self$path_return, hash)
     },
     file_return_key = function(key) {
       hash <- .self$get_hash(key)
       .self$file_return_hash(hash)
     },
     file_tmp = function() {
-      dir_create(.self$path_tmp)
       file.path(.self$path_tmp, basename(tempfile()))
     },
-    gc = function(...) decst_gc(..., .self = .self),
-    get = function(key, ...) decst_get(key = key, ..., .self = .self),
+    gc = function(...) dcst_gc(..., .self = .self),
+    get = function(key, ...) dcst_get(key = key, ..., .self = .self),
+    get_value = function(hash, ...) {
+      dcst_get_value(hash = hash, ..., .self = .self)
+    },
     set = function(key, value, ...) {
-      decst_set(value = value, key = key, ..., .self = .self)
+      dcst_set(value = value, key = key, ..., .self = .self)
     },
     # Delegate to storr:
     archive_export = function(...) .self$storr$archive_export(...),
@@ -69,7 +74,6 @@ refclass_decorated_storr <- methods::setRefClass(
     fill = function(...) .self$storr$fill(...),
     flush_cache = function(...) .self$storr$flush_cache(...),
     get_hash = function(...) .self$storr$get_hash(...),
-    get_value = function(...) .self$storr$get_value(...),
     hash_object = function(...) .self$storr$hash_object(...),
     hash_raw = function(...) .self$storr$hash_raw(...),
     import = function(...) .self$storr$import(...),
@@ -91,54 +95,86 @@ refclass_decorated_storr <- methods::setRefClass(
   )
 )
 
-decst_gc <- function(..., .self) {
+dcst_gc <- function(..., .self) {
+  before <- .self$storr$list_hashes()
   .self$storr$gc(...)
+  after <- .self$storr$list_hashes()
+  removed <- setdiff(before, after)
+  unlink(.self$file_return_hash(removed))
 }
 
-decst_get <- function(key, ..., .self) {
+dcst_get <- function(key, ..., .self) {
   value <- .self$storr$get(key = key, ...)
-  decst_inner_get(value = value, key = key, .self = .self)
+  dcst_get_(value = value, key = key, .self = .self)
 }
 
-decst_inner_get <- function(value, key, .self) {
-  UseMethod("decst_inner_get")
+dcst_get_ <- function(value, key, .self) {
+  UseMethod("dcst_get_")
 }
 
-decst_inner_get.default <- function(value, key, .self) {
+dcst_get_.default <- function(value, key, .self) {
   value
 }
 
-decst_inner_get.return_fst <- function(value, key, .self) {
+dcst_get_.return_fst <- function(value, key, .self) {
   value
 }
 
-decst_inner_get.return_keras <- function(value, key, .self) {
+dcst_get_.return_keras <- function(value, key, .self) {
   value
 }
 
-decst_inner_get.return_rds <- function(value, key, .self) {
+dcst_get_.return_rds <- function(value, key, .self) {
   readRDS(.self$file_return_key(key))
 }
 
-decst_set <- function(value, key, ..., .self) {
-  UseMethod("decst_set")
+dcst_get_value <- function(hash, ..., .self) {
+  value <- .self$storr$get_value(hash = hash, ...)
+  dcst_get_value_(value = value, hash = hash, .self = .self)
+}
+
+dcst_get_value_ <- function(value, hash, .self) {
+  UseMethod("dcst_get_value_")
+}
+
+dcst_get_value_.default <- function(value, hash, .self) {
+  value
+}
+
+dcst_get_value_.return_fst <- function(value, hash, .self) {
+  value
+}
+
+dcst_get_value_.return_keras <- function(value, hash, .self) {
+  value
+}
+
+dcst_get_value_.return_rds <- function(value, hash, .self) {
+  readRDS(.self$file_return_hash(hash))
+}
+
+dcst_set <- function(value, key, ..., .self) {
+  UseMethod("dcst_set")
 }
 
-decst_set.default <- function(value, key, ..., .self) {
+dcst_set.default <- function(value, key, ..., .self) {
   .self$storr$set(key = key, value = value, ...)
 }
 
-decst_set.return_fst <- function(value, key, ..., .self) {
+dcst_set.return_fst <- function(value, key, ..., .self) {
   assert_pkg("fst")
+  .self$assert_dirs()
   .self$storr$set(key = key, value = value, ...)
 }
 
-decst_set.return_keras <- function(value, key, ..., .self) {
+dcst_set.return_keras <- function(value, key, ..., .self) {
   assert_pkg("keras")
+  .self$assert_dirs()
   .self$storr$set(key = key, value = value, ...)
 }
 
-decst_set.return_rds <- function(value, key, ..., .self) {
+dcst_set.return_rds <- function(value, key, ..., .self) {
+  .self$assert_dirs()
   r_version <- paste0(R.version$major, ".", R.version$minor)
   sufficient_r_version <- utils::compareVersion(r_version, "3.5.0") >= 0L
   stopifnot(sufficient_r_version)
@@ -151,10 +187,10 @@ decst_set.return_rds <- function(value, key, ..., .self) {
     compress = TRUE,
     refhook = NULL
   )
-  decst_set_move_tmp(key = key, value = value, tmp = tmp, .self = .self)
+  dcst_set_move_tmp(key = key, value = value, tmp = tmp, .self = .self)
 }
 
-decst_set_move_tmp <- function(key, value, tmp, .self) {
+dcst_set_move_tmp <- function(key, value, tmp, .self) {
   hash_tmp <- digest::digest(
     object = tmp,
     algo = .self$hash_algorithm,

R/deprecated.R

@@ -1233,7 +1233,8 @@ dataset_wildcard <- function() {
   dataset_wildcard_()
 }
 
-#' @title Deprecated. Compute the initial pre-build metadata of a target or import.
+#' @title Deprecated. Compute the initial pre-build metadata
+#'   of a target or import.
 #' @description Deprecated on 2019-01-12.
 #' @details The metadata helps determine if the
 #' target is up to date or outdated. The metadata of imports
@@ -1355,7 +1356,7 @@ in_progress <- function(
     package = "drake",
     msg = "in_progress() in drake is deprecated. Use running() instead."
   )
-  running(path, search, cache, verbose )
+  running(path, search, cache, verbose)
 }
 
 #' @title Deprecated. Load an existing drake files system cache

R/drake_config.R

@@ -58,7 +58,7 @@
 #'
 #' @param parallelism Character scalar, type of parallelism to use.
 #'   For detailed explanations, see the
-#'   [high-performance computing chapter](https://ropenscilabs.github.io/drake-manual/hpc.html)
+#'   [high-performance computing chapter](https://ropenscilabs.github.io/drake-manual/hpc.html) # nolint
 #'   of the user manual.
 #'
 #'   You could also supply your own scheduler function
@@ -748,7 +748,10 @@ force_cache_path <- function(cache = NULL) {
 cache_path_ <- function(cache = NULL) {
   if (is.null(cache)) {
     NULL
-  } else if (inherits(cache, "refclass_decorated_storr")) {
+  }
+  is_cache <- inherits(cache, "refclass_decorated_storr") ||
+    inherits(cache, "storr")
+  if (is_cache) {
     cache$driver$path
   } else {
     NULL

R/drake_meta_.R

@@ -169,7 +169,7 @@ storage_hash <- function(
     new_size = storage_size(file),
     old_size = meta$size
   )
-  ifelse (
+  ifelse(
     should_rehash,
     rehash_storage(target = target, config = config),
     config$cache$get(key = target)

R/drake_plan.R

@@ -8,7 +8,7 @@
 #'
 #' @details Besides `"target"` and `"command"`, [drake_plan()]
 #'   understands a special set of optional columns. For details, visit
-#'   <https://ropenscilabs.github.io/drake-manual/plans.html#special-custom-columns-in-your-plan>
+#'   <https://ropenscilabs.github.io/drake-manual/plans.html#special-custom-columns-in-your-plan> # nolint
 #'
 #' @section Columns:
 #' [drake_plan()] creates a special data frame. At minimum, that data frame

R/package.R

@@ -2,7 +2,8 @@
 #' @docType package
 #' @description drake is a pipeline toolkit
 #' (<https://github.com/pditommaso/awesome-pipeline>)
-#' and a scalable, R-focused solution for reproducibility and high-performance computing.
+#' and a scalable, R-focused solution for reproducibility
+#' and high-performance computing.
 #' @name drake-package
 #' @aliases drake
 #' @author William Michael Landau \email{will.landau@@gmail.com}

R/r_make.R

@@ -29,7 +29,8 @@
 #' @param r_fn A `callr` function such as `callr::r` or `callr::r_bg`.
 #'   Example: `r_make(r_fn = callr::r)`.
 #' @param r_args List of arguments to `r_fn`, not including `func` or `args`.
-#'   Example: `r_make(r_fn = callr::r_bg, r_args = list(stdout = "stdout.log"))`.
+#'   Example:
+#'   `r_make(r_fn = callr::r_bg, r_args = list(stdout = "stdout.log"))`.
 #' @examples
 #' \dontrun{
 #' isolate_example("quarantine side effects", {

R/sankey_drake_graph.R

@@ -22,7 +22,7 @@
 #' if (requireNamespace("networkD3", quietly = TRUE)) {
 #' if (requireNamespace("visNetwork", quietly = TRUE)) {
 #' # Plot the network graph representation of the workflow.
-#' sankey_drake_graph(config, width = '100%') # The width is passed to visNetwork
+#' sankey_drake_graph(config, width = '100%')
 #' # Show the legend separately.
 #' visNetwork::visNetwork(nodes = drake::legend_nodes())
 #' make(my_plan) # Run the project, build the targets.
@@ -135,7 +135,7 @@ sankey_drake_graph <- function(
 #' # You can pass the data frames right to render_sankey_drake_graph()
 #' # (as in sankey_drake_graph()) or you can create
 #' # your own custom visNewtork graph.
-#' render_sankey_drake_graph(graph, width = '100%') # Width is passed to visNetwork.
+#' render_sankey_drake_graph(graph, width = '100%')
 #' }
 #' }
 #' }

R/store_outputs.R

@@ -179,7 +179,7 @@ log_time <- function(target, meta, config) {
   }
   if (requireNamespace("lubridate", quietly = TRUE)) {
     exec <- round(lubridate::dseconds(meta$time_command$elapsed), 3)
-    total <- round(lubridate::dseconds( meta$time_build$elapsed), 3)
+    total <- round(lubridate::dseconds(meta$time_build$elapsed), 3)
     tail <- paste("", exec, "|", total, " (exec | total)")
   } else {
     tail <- " (install lubridate)" # nocov