Sketch #1139

DESCRIPTION

@@ -12,7 +12,7 @@ Description: Pipeline tools coordinate the pieces of computationally
   The methodology in this package
   borrows from GNU 'Make' (2015, ISBN:978-9881443519)
   and 'drake' (2018, <doi:10.21105/joss.00550>).
-Version: 1.2.2.9003
+Version: 1.2.2.9004
 License: MIT + file LICENSE
 URL: https://docs.ropensci.org/targets/, https://github.com/ropensci/targets
 BugReports: https://github.com/ropensci/targets/issues

NAMESPACE

@@ -469,6 +469,7 @@ export(tar_resources_network)
 export(tar_resources_parquet)
 export(tar_resources_qs)
 export(tar_resources_url)
+export(tar_restore_random)
 export(tar_runtime_object)
 export(tar_script)
 export(tar_seed)
@@ -525,7 +526,6 @@ importFrom(data.table,fwrite)
 importFrom(data.table,rbindlist)
 importFrom(data.table,set)
 importFrom(digest,digest)
-importFrom(digest,digest2int)
 importFrom(igraph,V)
 importFrom(igraph,adjacent_vertices)
 importFrom(igraph,get.edgelist)

NEWS.md

@@ -1,4 +1,4 @@
-# targets 1.2.2.9003 (development)
+# targets 1.2.2.9004 (development)
 
 ## Invalidating changes
 

R/class_branch.R

@@ -10,7 +10,7 @@ branch_init <- function(
   command <- command_clone(command)
   deps <- union(command$deps, deps)
   command$deps <- setdiff(deps, settings$dimensions)
-  command$seed <- produce_seed(child)
+  command$seed <- produce_seed()
   pedigree <- pedigree_new(settings$name, child, index)
   settings <- settings_clone(settings)
   settings$name <- child

R/class_build.R

@@ -63,12 +63,8 @@ build_new <- function(object = NULL, metrics = NULL) {
 build_run_expr <- function(expr, envir, seed, packages, library) {
   load_packages(packages = packages, library = library)
   if (!anyNA(seed)) {
-    # Borrowed from https://github.com/r-lib/withr/blob/main/R/seed.R
-    # under the MIT license. See the NOTICE file
-    # in the targets package source.
-    old_seed <- .GlobalEnv[[".Random.seed"]]
-    set.seed(seed)
-    on.exit(restore_seed(old_seed), add = TRUE)
+    RNGkind(kind = "L'Ecuyer-CMRG")
+    .GlobalEnv[[".Random.seed"]] <- seed
   }
   build_eval_fce17be7(expr, envir)
 }

R/class_cue.R

@@ -5,8 +5,7 @@ cue_init <- function(
   format = TRUE,
   repository = TRUE,
   iteration = TRUE,
-  file = TRUE,
-  seed = TRUE
+  file = TRUE
 ) {
   cue_new(
     mode = mode,
@@ -15,8 +14,7 @@ cue_init <- function(
     format = format,
     repository = repository,
     iteration = iteration,
-    file = file,
-    seed = seed
+    file = file
   )
 }
 
@@ -27,8 +25,7 @@ cue_new <- function(
   format = NULL,
   repository = NULL,
   iteration = NULL,
-  file = NULL,
-  seed = NULL
+  file = NULL
 ) {
   force(mode)
   force(command)
@@ -37,7 +34,6 @@ cue_new <- function(
   force(repository)
   force(iteration)
   force(file)
-  force(seed)
   enclass(environment(), "tar_cue")
 }
 
@@ -132,15 +128,6 @@ cue_file <- function(cue, target, meta, record) {
   !store_has_correct_hash(target$store)
 }
 
-cue_seed <- function(cue, target, meta, record) {
-  if (!cue$seed) {
-    return(FALSE)
-  }
-  old <- as.integer(record$seed)
-  new <- as.integer(target$command$seed)
-  anyNA(new) || !identical(old, new)
-}
-
 cue_validate <- function(cue) {
   tar_assert_correct_fields(cue, cue_new)
   tar_assert_chr(cue$mode)
@@ -151,15 +138,13 @@ cue_validate <- function(cue) {
   tar_assert_lgl(cue$repository)
   tar_assert_lgl(cue$iteration)
   tar_assert_lgl(cue$file)
-  tar_assert_lgl(cue$seed)
   tar_assert_scalar(cue$mode)
   tar_assert_scalar(cue$command)
   tar_assert_scalar(cue$depend)
   tar_assert_scalar(cue$format)
   tar_assert_scalar(cue$repository)
   tar_assert_scalar(cue$iteration)
   tar_assert_scalar(cue$file)
-  tar_assert_scalar(cue$seed)
 }
 
 #' @export

R/class_meta.R

@@ -160,8 +160,8 @@ database_meta <- function(path_store) {
     path = path_meta(path_store = path_store),
     subkey = file.path(basename(path_meta("")), "meta"),
     header = header_meta(),
-    list_columns = c("path", "children"),
-    list_column_modes = c("character", "character")
+    list_columns = c("seed", "path", "children"),
+    list_column_modes = c("integer", "character", "character")
   )
 }
 

R/class_options.R

@@ -338,7 +338,7 @@ options_class <- R6::R6Class(
       self$workspace_on_error %|||% FALSE
     },
     get_seed = function() {
-      self$seed %|||% 0L
+      .subset2(self, "seed") %|||% 0L
     },
     get_controller = function() {
       self$controller

R/class_pattern.R

@@ -369,14 +369,6 @@ pattern_produce_grid <- function(
   seed,
   methods = dynamic_methods
 ) {
-  if (!anyNA(seed)) {
-    # Borrowed from https://github.com/r-lib/withr/blob/main/R/seed.R
-    # under the MIT license. See the NOTICE file
-    # in the targets package source.
-    old_seed <- .GlobalEnv[[".Random.seed"]]
-    set.seed(seed)
-    on.exit(restore_seed(old_seed))
-  }
   out <- eval(pattern, envir = niblings, enclos = dynamic_methods$self)
   rownames(out) <- NULL
   out

R/class_runtime.R

@@ -10,7 +10,8 @@ runtime_new <- function(
   file_exist = NULL,
   file_info = NULL,
   file_info_exist = NULL,
-  nanonext = NULL
+  nanonext = NULL,
+  seed = NULL
 ) {
   force(target)
   force(frames)
@@ -24,6 +25,7 @@ runtime_new <- function(
   force(file_info)
   force(file_info_exist)
   force(nanonext)
+  force(seed)
   environment()
 }
 
@@ -78,6 +80,9 @@ runtime_validate <- function(x) {
     tar_assert_scalar(x$nanonext)
     tar_assert_lgl(x$nanonext)
   }
+  if (!is.null(x$seed)) {
+    tar_assert_int(x$seed %||NA% 1L)
+  }
 }
 
 #' @title Get the `tar_runtime` object.

R/class_target.R

@@ -19,7 +19,7 @@ target_init <- function(
   retrieval = "main",
   cue = NULL
 ) {
-  seed <- produce_seed(name)
+  seed <- produce_seed()
   command <- command_init(expr, packages, library, seed, deps, string)
   cue <- cue %|||% cue_init()
   if (any(grepl("^aws_", format))) {

R/tar_cue.R

@@ -84,11 +84,10 @@
 #'   [tar_target()] or [tar_option_set()].
 #' @param file Logical, whether to rerun the target if the file(s) with the
 #'   return value changed or at least one is missing.
-#' @param seed Logical, whether to rerun the target if pseudo-random
-#'   number generator seed either changed or is `NA`.
-#'   The reproducible deterministic target-specific
-#'   seeds are controlled by `tar_option_get("seed")` and the target names.
-#'   See [tar_option_set()] for details.
+#' @param seed Deprecated. Because of
+#'   <https://github.com/ropensci/targets/issues/1139>, `targets` can no longer
+#'   watch the pseudo-random number generator seed of a target to
+#'   decide whether to rerun it.
 #' @examples
 #' # The following target will always run when the pipeline runs.
 #' x <- tar_target(x, download_data(), cue = tar_cue(mode = "always"))
@@ -100,30 +99,36 @@ tar_cue <- function(
   repository = TRUE,
   iteration = TRUE,
   file = TRUE,
-  seed = TRUE
+  seed = NULL
 ) {
   tar_assert_lgl(command)
   tar_assert_lgl(depend)
   tar_assert_lgl(format)
   tar_assert_lgl(repository)
   tar_assert_lgl(iteration)
   tar_assert_lgl(file)
-  tar_assert_lgl(seed)
   tar_assert_scalar(command)
   tar_assert_scalar(depend)
   tar_assert_scalar(format)
   tar_assert_scalar(repository)
   tar_assert_scalar(iteration)
   tar_assert_scalar(file)
-  tar_assert_scalar(seed)
+  if (!is.null(seed)) {
+    tar_warn_deprecate(
+      "The seed argument of tar_cue() was deprecated on 2023-09-05 (version ",
+      "1.2.2.9004). Because of ",
+      "https://github.com/ropensci/targets/issues/1139, targets can no ",
+      "longer watch the pseudo-random number generator seed of a target ",
+      "to decide whether to rerun it."
+    )
+  }
   cue_init(
     mode = match.arg(mode),
     command = command,
     depend = depend,
     format = format,
     repository = repository,
     iteration = iteration,
-    file = file,
-    seed = seed
+    file = file
   )
 }

R/tar_package.R

@@ -19,7 +19,7 @@
 #'   num_ansi_colors symbol
 #' @importFrom codetools findGlobals
 #' @importFrom data.table data.table fread fwrite rbindlist set
-#' @importFrom digest digest digest2int
+#' @importFrom digest digest
 #' @importFrom igraph adjacent_vertices get.edgelist gorder
 #'   graph_from_data_frame igraph_opt igraph_options is_dag simplify topo_sort
 #'   V

R/utils_callr.R

@@ -144,6 +144,7 @@ tar_callr_inner_try <- function(
   }
   old_envir <- targets::tar_option_get("envir")
   targets::tar_option_set(envir = envir)
+  old_options <- options(options)
   tar_runtime <- targets::tar_runtime_object()
   tar_runtime$script <- script
   tar_runtime$store <- store
@@ -161,16 +162,25 @@ tar_callr_inner_try <- function(
   names(file_info$size) <- objects
   names(file_info$mtime_numeric) <- objects
   tar_runtime$file_info <- file_info
+  old_seed <- .GlobalEnv[[".Random.seed"]]
+  old_algorithm <- RNGkind()[1L]
+  pipeline_seed <- tar_options$get_seed()
+  if (!anyNA(pipeline_seed)) {
+    set.seed(seed = pipeline_seed, kind = "L'Ecuyer-CMRG")
+    tar_runtime$seed <- .GlobalEnv[[".Random.seed"]]
+  }
   on.exit(targets::tar_option_set(envir = old_envir))
+  on.exit(options(old_options), add = TRUE)
   on.exit(tar_runtime$script <- NULL, add = TRUE)
   on.exit(tar_runtime$store <- NULL, add = TRUE)
   on.exit(tar_runtime$working_directory <- NULL, add = TRUE)
   on.exit(tar_runtime$fun <- NULL, add = TRUE)
   on.exit(tar_runtime$file_exist <- NULL, add = TRUE)
   on.exit(tar_runtime$file_info <- NULL, add = TRUE)
   on.exit(tar_runtime$file_info_exist <- NULL, add = TRUE)
-  old <- options(options)
-  on.exit(options(old), add = TRUE)
+  if (!anyNA(pipeline_seed)) {
+    on.exit(targets::tar_restore_random(old_seed, old_algorithm), add = TRUE)
+  }
   targets <- eval(parse(file = script, keep.source = TRUE), envir = envir)
   targets_arguments$pipeline <- targets::tar_as_pipeline(targets)
   targets::tar_pipeline_validate_lite(targets_arguments$pipeline)

R/utils_digest.R

@@ -32,13 +32,4 @@ digest_obj64 <- function(object, ...) {
   vdigest64(list(object), serialize = TRUE, serializeVersion = 3L, ...)
 }
 
-produce_seed <- function(scalar) {
-  seed <- tar_options$get_seed()
-  if_any(
-    anyNA(seed),
-    NA_integer_,
-    digest::digest2int(as.character(scalar), seed = seed)
-  )
-}
-
 null64 <- digest_obj64(NULL)

R/utils_random.R

@@ -0,0 +1,37 @@
+# Borrowed from https://github.com/r-lib/withr/blob/main/R/seed.R
+# under the MIT license. See the NOTICE file in the targets package source.
+#' @title Resore random number generator state
+#' @export
+#' @keywords internal
+#' @description Not a user-side function.
+#' @return `NULL` (invisibly). Called for its side effects.
+#' @param old_seed Old seed.
+#' @param old_algorithm Old RNG algorithm.
+tar_restore_random <- function(old_seed, old_algorithm) {
+  RNGkind(kind = old_algorithm)
+  if_any(
+    is.null(old_seed), {
+      set.seed(seed = NULL)
+      rm(list = ".Random.seed", envir = .GlobalEnv)
+    },
+    assign(x = ".Random.seed", value = old_seed, envir = .GlobalEnv)
+  )
+}
+
+produce_seed <- function() {
+  seed_pipeline <- .subset2(tar_options, "get_seed")()
+  if (anyNA(seed_pipeline)) {
+    return(NA_integer_)
+  }
+  seed_runtime <- .subset2(tar_runtime, "seed")
+  algorithm <- .subset(RNGkind(), 1L)
+  if (is.null(seed_runtime)) {
+    set.seed(seed = seed_pipeline, kind = "L'Ecuyer-CMRG")
+  } else if (algorithm != "L'Ecuyer-CMRG") {
+    RNGkind(kind = "L'Ecuyer-CMRG")
+    .GlobalEnv[[".Random.seed"]] <- seed_runtime
+  }
+  seed_next <- parallel::nextRNGStream(seed = seed_runtime)
+  tar_runtime$seed <- seed_next
+  seed_next
+}