Optionally avoid scratch

DESCRIPTION

@@ -32,5 +32,5 @@ Suggests:
     rbenchmark,
     testthat (>= 1.0.0)
 VignetteBuilder: knitr
-RoxygenNote: 6.1.1
+RoxygenNote: 7.0.0
 Encoding: UTF-8

NEWS.md

@@ -1,6 +1,7 @@
 ## storr 1.2.2 (2018-??-??)
 
 * Speed up the `$get_hash()` method of RDS drivers using C code and traits (#96, #98, @wlandau).
+* Add a new `use_scratch_keys` argument to `driver_rds()` and `storr_rds()`. Allows users to bypass the `scratch` directory for keys. Speeds up processing on some file systems (#116, @wlandau).
 
 ## storr 1.2.1 (2018-10-18)
 

R/driver_rds.R

@@ -74,6 +74,11 @@
 ##'   \code{\link{digest}}.  If not given, then we will default to
 ##'   "md5".
 ##'
+##' @param use_scratch_keys Logical, whether to create key files
+##'   in a scratch directory before moving them to their final destinations.
+##'   Set to \code{TRUE} to ensure atomic reads and writes for keys, or set to
+##'   \code{FALSE} to increase speed on some platforms (namely Windows).
+##'
 ##' @param default_namespace Default namespace (see
 ##'   \code{\link{storr}}).
 ##' @export
@@ -110,16 +115,17 @@
 ##' st2$destroy()
 storr_rds <- function(path, compress = NULL, mangle_key = NULL,
                       mangle_key_pad = NULL, hash_algorithm = NULL,
-                      default_namespace = "objects") {
-  storr(driver_rds(path, compress, mangle_key, mangle_key_pad, hash_algorithm),
+                      default_namespace = "objects", use_scratch_keys = TRUE) {
+  storr(driver_rds(path, compress, mangle_key, mangle_key_pad, hash_algorithm, use_scratch_keys),
         default_namespace)
 }
 
 ##' @export
 ##' @rdname storr_rds
 driver_rds <- function(path, compress = NULL, mangle_key = NULL,
-                       mangle_key_pad = NULL, hash_algorithm = NULL) {
-  R6_driver_rds$new(path, compress, mangle_key, mangle_key_pad, hash_algorithm)
+                       mangle_key_pad = NULL, hash_algorithm = NULL,
+                       use_scratch_keys = TRUE) {
+  R6_driver_rds$new(path, compress, mangle_key, mangle_key_pad, hash_algorithm, use_scratch_keys)
 }
 
 R6_driver_rds <- R6::R6Class(
@@ -129,6 +135,7 @@ R6_driver_rds <- R6::R6Class(
     ## This needs sorting before anyone writes their own driver!
     path = NULL,
     path_scratch = NULL,
+    use_scratch_keys = NULL,
     compress = NULL,
     mangle_key = NULL,
     mangle_key_pad = NULL,
@@ -137,16 +144,16 @@ R6_driver_rds <- R6::R6Class(
     traits = list(accept = "raw", throw_missing = TRUE),
 
     initialize = function(path, compress, mangle_key, mangle_key_pad,
-                          hash_algorithm) {
+                          hash_algorithm, use_scratch_keys) {
       is_new <- !file.exists(file.path(path, "config"))
       dir_create(path)
       dir_create(file.path(path, "data"))
       dir_create(file.path(path, "keys"))
       dir_create(file.path(path, "config"))
       self$path <- normalizePath(path, mustWork = TRUE)
-
       self$path_scratch <- file.path(self$path, "scratch")
       dir_create(self$path_scratch)
+      self$use_scratch_keys <- use_scratch_keys
 
       ## This is a bit of complicated dancing around to mantain
       ## backward compatibility while allowing better defaults in
@@ -187,7 +194,7 @@ R6_driver_rds <- R6::R6Class(
       }
       self$hash_algorithm <- driver_rds_config(path, "hash_algorithm",
                                                hash_algorithm, "md5", TRUE)
-      
+
       self$hash_length <- nchar(
         digest::digest(as.raw(0x00), self$hash_algorithm, serialize = FALSE))
     },
@@ -207,7 +214,7 @@ R6_driver_rds <- R6::R6Class(
     set_hash = function(key, namespace, hash) {
       dir_create(self$name_key("", namespace))
       write_lines(hash, self$name_key(key, namespace),
-                  scratch_dir = self$path_scratch)
+                  scratch_dir = self$path_scratch, use_scratch_keys = self$use_scratch_keys)
     },
 
     get_object = function(hash) {

R/hash.R

@@ -85,8 +85,8 @@ write_serialized_rds <- function(value, filename, compress,
 ## delete the file *after* that.
 try_write_serialized_rds <- function(value, filename, compress,
                                      scratch_dir = NULL, long = 2^31 - 2) {
-  tmp <- tempfile(tmpdir = scratch_dir %||% tempdir())
 
+  tmp <- tempfile(tmpdir = scratch_dir %||% tempdir())
   con <- (if (compress) gzfile else file)(tmp, "wb")
   needs_close <- TRUE
   on.exit(if (needs_close) close(con), add = TRUE)
@@ -106,20 +106,24 @@ try_write_serialized_rds <- function(value, filename, compress,
 ## Same pattern for write_lines.  The difference is that this will
 ## delete the key on a failed write (otherwise there's a copy
 ## involved)
-write_lines <- function(text, filename, ..., scratch_dir = NULL) {
+write_lines <- function(text, filename, ...,
+                        scratch_dir = NULL, use_scratch_keys = TRUE) {
   withCallingHandlers(
-    try_write_lines(text, filename, ..., scratch_dir = scratch_dir),
+    try_write_lines(text, filename, ..., scratch_dir = scratch_dir,
+                    use_scratch_keys = use_scratch_keys),
     error = function(e) unlink(filename))
 }
 
 
 ## This implements write-then-move for writeLines, which gives us
 ## atomic writes and rewrites.  If 'scratch' is on the same filesystem
 ## as dirname(filename), then the os's rename is atomic
-try_write_lines <- function(text, filename, ..., scratch_dir) {
-  tmp <- tempfile(tmpdir = scratch_dir %||% tempdir())
+try_write_lines <- function(text, filename, ..., scratch_dir, use_scratch_keys) {
+  tmp <- ifelse(use_scratch_keys, tempfile(tmpdir = scratch_dir %||% tempdir()), filename)
   writeLines(text, tmp, ...)
   ## Not 100% necessary and strictly makes this nonatomic
-  unlink(filename)
-  file.rename(tmp, filename)
+  if (use_scratch_keys) {
+    unlink(filename)
+    file.rename(tmp, filename)
+  }
 }

tests/testthat/test-driver-rds.R

@@ -381,3 +381,10 @@ test_that("avoid race condition when writing in parallel", {
   ok <- vlapply(1:10, function(i) racy_write())
   expect_true(all(ok))
 })
+
+test_that("use_scratch_keys = FALSE (#116)", {
+  st <- storr_rds(tempfile(), use_scratch_keys = FALSE)
+  st$set("a", "a")
+  expect_equal(st$get("a"), "a")
+  expect_false(st$driver$use_scratch_keys)
+})