Add a menu for interactive make()s re #761

NAMESPACE

@@ -205,6 +205,7 @@ importFrom(storr,storr_environment)
 importFrom(storr,storr_rds)
 importFrom(utils,compareVersion)
 importFrom(utils,head)
+importFrom(utils,menu)
 importFrom(utils,packageVersion)
 importFrom(utils,read.csv)
 importFrom(utils,sessionInfo)

R/api-make.R

@@ -9,8 +9,7 @@
 #'   [drake_plan()],
 #'   [drake_config()],
 #'   [vis_drake_graph()],
-#'   [outdated()],
-#'   [triggers()]
+#'   [outdated()]
 #' @export
 #' @return nothing
 #' @inheritParams drake_config
@@ -69,7 +68,7 @@ make <- function(
   cpu = Inf,
   elapsed = Inf,
   retries = 0,
-  force = FALSE,
+  force = NULL,
   graph = NULL,
   trigger = drake::trigger(),
   skip_imports = FALSE,
@@ -151,6 +150,16 @@ make <- function(
   if (!config$skip_imports) {
     process_imports(config)
   }
+  if (is.character(config$parallelism)) {
+    config$schedule <- pretrim_schedule(config)
+  }
+  abort <- FALSE
+  if (check_intv_make(config)) {
+    abort <- abort_intv_make(config) # nocov
+  }
+  if (abort) {
+    return(invisible()) # nocov
+  }
   if (!config$skip_targets) {
     process_targets(config)
   }

R/api-package.R

@@ -49,6 +49,6 @@
 #' @importFrom methods new setRefClass
 #' @importFrom rlang enquo eval_tidy expr quo_squash quos
 #' @importFrom storr storr_environment storr_rds
-#' @importFrom utils compareVersion head packageVersion
+#' @importFrom utils compareVersion head menu packageVersion
 #'   read.csv sessionInfo stack type.convert unzip write.table
 NULL

R/exec-backend.R

@@ -11,7 +11,6 @@ run_native_backend <- function(config) {
     config$parallelism,
     c("loop", "clustermq", "future")
   )
-  config$schedule <- pretrim_schedule(config)
   if (igraph::gorder(config$schedule)) {
     get(
       paste0("backend_", parallelism),

R/exec-session.R

@@ -83,3 +83,26 @@ conclude_session <- function(config) {
   console_final_notes(config)
   invisible()
 }
+
+check_intv_make <- function(config) {
+  force_intv <- config$force %||%
+    getOption("drake_force_interactive") %||%
+    FALSE
+  interactive() &&
+    igraph::gorder(config$schedule) &&
+    !identical(force_intv, TRUE)
+}
+
+abort_intv_make <- function(config) {
+  # nocov start
+  title <- paste(
+    paste(igraph::gorder(config$schedule), "outdated targets:"),
+    multiline_message(igraph::V(config$schedule)$name),
+    "\nReally run make() in interactive mode?",
+    "Considerations: https://github.com/ropensci/drake/issues/761",
+    sep = "\n"
+  )
+  out <- utils::menu(choices = c("yes", "no"), title = title)
+  identical(as.integer(out), 2L)
+  # nocov end
+}

R/preprocess-config.R

@@ -432,7 +432,7 @@ drake_config <- function(
   cpu = Inf,
   elapsed = Inf,
   retries = 0,
-  force = FALSE,
+  force = NULL,
   log_progress = FALSE,
   graph = NULL,
   trigger = drake::trigger(),
@@ -553,7 +553,7 @@ drake_config <- function(
       console_log_file = console_log_file
     )
   }
-  if (force) {
+  if (force %||% FALSE) {
     drake_set_session_info(cache = cache, full = session_info)
   }
   seed <- choose_seed(supplied = seed, cache = cache)
@@ -632,7 +632,8 @@ drake_config <- function(
     template = template,
     sleep = sleep,
     hasty_build = hasty_build,
-    lock_envir = lock_envir
+    lock_envir = lock_envir,
+    force = force
   )
   out <- enforce_compatible_config(out)
   config_checks(out)

R/vis-color.R

@@ -14,6 +14,7 @@ colors <- c(
   launch = "#ff9933",
   load = "#ff9933",
   unload = "#ff7221",
+  interactive = "#ff7221",
   trigger = "maroon",
   skip = "skyblue1",
   store = "skyblue1",

R/vis-console.R

@@ -123,7 +123,25 @@ console_up_to_date <- function(config) {
   }
 }
 
+console_interactive <- function(config) {
+  if (!interactive()) {
+    return()
+  }
+  # nocov start
+  msg <- paste0(
+    "make() in interactive mode requires extra care:\n",
+    "https://github.com/ropensci/drake/issues/761"
+  )
+  out <- color(msg, colors["interactive"])
+  drake_message(out, config = config)
+  # nocov end
+}
+
 console_final_notes <- function(config) {
+  if (config$verbose < 1L) {
+    return()
+  }
+  console_interactive(config)
   if (config$verbose < 2L) {
     return()
   }

tests/testthat/test-always-skipped.R

@@ -81,4 +81,41 @@ test_with_dir("forks + lock_envir = informative error msg", {
   )
 })
 
+test_with_dir("make() in interactive mode", {
+  # Must run this test in an interactive session.
+  # Cannot be fully automated like the other tests.
+  load_mtcars_example()
+  config <- drake_config(my_plan)
+  make(my_plan) # Select 2.
+  expect_equal(cached(), character(0))
+  expect_equal(sort(outdated(config)), sort(my_plan$target))
+  expect_equal(sort(justbuilt(config)), character(0))
+  make(my_plan, console_log_file = "log.txt") # Select 1.
+  expect_equal(cached(), sort(my_plan$target))
+  expect_equal(sort(outdated(config)), character(0))
+  expect_equal(sort(justbuilt(config)), sort(my_plan$target))
+  lines <- readLines("log.txt")
+  expect_true(any(grepl("interactive", lines)))
+  expect_false(any(grepl("up to date", lines)))
+  make(my_plan, console_log_file = "log.txt") # No menu.
+  expect_equal(cached(), sort(my_plan$target))
+  expect_equal(sort(outdated(config)), character(0))
+  expect_equal(sort(justbuilt(config)), character(0))
+  lines <- readLines("log.txt")
+  expect_true(any(grepl("interactive", lines)))
+  expect_true(any(grepl("up to date", lines)))
+  clean()
+  make(my_plan, force = TRUE) # No menu.
+  expect_equal(sort(outdated(config)), character(0))
+  expect_equal(sort(justbuilt(config)), sort(my_plan$target))
+  clean()
+  options(drake_force_interactive = TRUE)
+  make(my_plan, force = FALSE) # Select 2.
+  expect_equal(sort(outdated(config)), sort(my_plan$target))
+  expect_equal(sort(justbuilt(config)), character(0))
+  make(my_plan) # No menu.
+  expect_equal(sort(outdated(config)), character(0))
+  expect_equal(sort(justbuilt(config)), sort(my_plan$target))
+})
+
 }