Detect and alert on default graphics device being used

Author: HenrikBengtsson

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: future
-Version: 1.49.0-9014
+Version: 1.49.0-9015
 Title: Unified Parallel and Distributed Processing in R for Everyone
 Depends:
     R (>= 3.2.0)

NAMESPACE

@@ -127,6 +127,9 @@ export(ClusterFutureBackend)
 export(ConnectionMisuseFutureCondition)
 export(ConnectionMisuseFutureError)
 export(ConnectionMisuseFutureWarning)
+export(DefaultDeviceMisuseFutureCondition)
+export(DefaultDeviceMisuseFutureError)
+export(DefaultDeviceMisuseFutureWarning)
 export(DeviceMisuseFutureCondition)
 export(DeviceMisuseFutureError)
 export(DeviceMisuseFutureWarning)

NEWS.md

@@ -1,5 +1,18 @@
 # Version (development version)
 
+## New Features
+
+ * Now futures produce a warning when they detect that the _default_
+   graphics device, as defined by R option `"device"`, is opened by,
+   for instance, a `plot()` call without explicitly opening a graphics
+   device. The reason for this check is that we rarely want to plot to
+   the _default_ graphics device in parallel processing, which
+   typically ends up plotting to a `Rplots.pdf` file that is local to
+   the parallel worker. If that is truly wanted, please open a
+   graphics devices explicitly (e.g. `pdf()` or `png()`) before
+   plotting. Alternatively, explicitly set R option `device` inside
+   the future expression.
+
 ## Bug Fixes
 
  * The `multicore` backend did not relay `immediateCondition`:s in a

R/backend_api-evalFuture.R

@@ -914,6 +914,7 @@ evalFutureInternal <- function(data) {
 
 
   checkDevices <- getOption("future.devices.onMisuse")
+  ...future.option.defaultDevice <- 0L
   if (is.null(checkDevices)) {
     checkDevices <- TRUE
   } else {
@@ -922,6 +923,25 @@ evalFutureInternal <- function(data) {
   if (checkDevices) {
     ## IMPORTANT: Need to use as.list() - if not, it's a reference variable/alias (sic!)
     ...future.devices <- as.list(base::.Devices)
+    ## Detect attempts to open the default graphics device
+    device <- getOption("device")
+    if (!is.null(device)) {
+      if (is.character(device)) {
+        if (exists(device, mode = "function")) {
+          device <- get(device, mode = "function")
+        } else {
+          device <- NULL
+        }
+      }
+      if (!is.null(device)) {
+        ...future.option.device <- device
+        options(device = function(...) {
+          ...future.option.defaultDevice <<- ...future.option.defaultDevice + 1L
+          ## Call the default graphics device
+          ...future.option.device(...)
+        })
+      }
+    }
   }
 
 
@@ -949,6 +969,7 @@ evalFutureInternal <- function(data) {
           misuseGlobalEnv = if (checkGlobalenv) list(added = diff_globalenv(...future.globalenv.names)) else NULL,
           misuseConnections = if (checkConnections) diff_connections(get_connections(details = isTRUE(attr(checkConnections, "details", exact = TRUE))), ...future.connections) else NULL,
           misuseDevices = if (checkDevices) diff_devices(...future.devices, base::.Devices) else NULL,
+          misuseDefaultDevice = ...future.option.defaultDevice,
           started = ...future.startTime
         )
       }, condition = function(cond) {
@@ -1049,6 +1070,7 @@ evalFutureInternal <- function(data) {
       misuseGlobalEnv = if (checkGlobalenv) list(added = diff_globalenv(...future.globalenv.names)) else NULL,
       misuseConnections = diff_connections(get_connections(details = isTRUE(attr(checkConnections, "details", exact = TRUE))), ...future.connections),
       misuseDevices = if (checkDevices) diff_devices(base::.Devices, ...future.devices) else NULL,
+      misuseDefaultDevice = ...future.option.defaultDevice,
       started = ...future.startTime
     )
   }, error = function(ex) {
@@ -1059,6 +1081,7 @@ evalFutureInternal <- function(data) {
       misuseGlobalEnv = if (checkGlobalenv) list(added = diff_globalenv(...future.globalenv.names)) else NULL,
       misuseConnections = diff_connections(get_connections(details = isTRUE(attr(checkConnections, "details", exact = TRUE))), ...future.connections),
       misuseDevices = if (checkDevices) diff_devices(base::.Devices, ...future.devices) else NULL,
+      misuseDefaultDevice = ...future.option.defaultDevice,
       started = ...future.startTime
     )
   }) ## output tryCatch()

R/core_api-value.R

@@ -239,6 +239,44 @@ value.Future <- function(future, stdout = TRUE, signal = TRUE, drop = FALSE, ...
     }
   }
 
+  ## ------------------------------------------------------------------
+  ## Report on misuse of the default devices
+  ## ------------------------------------------------------------------
+  if (!is.null(result[["misuseDefaultDevice"]]) &&
+      result[["misuseDefaultDevice"]] > 0L) {
+    onMisuse <- getOption("future.defaultDevice.onMisuse")
+    if (is.null(onMisuse)) onMisuse <- "warning"
+    if (onMisuse != "ignore") {
+      if (onMisuse == "error") {
+        cond <- DefaultDeviceMisuseFutureError(times = result[["misuseDefaultDevice"]], future = future)
+      } else if (onMisuse == "warning") {
+        cond <- DefaultDeviceMisuseFutureWarning(times = result[["misuseDefaultDevice"]], future = future)
+      } else {
+        cond <- NULL
+        warnf("Unknown value on option 'future.defaultDevice.onMisuse': %s",
+              sQuote(onMisuse))
+      }
+
+      if (!is.null(cond)) {
+        ## FutureCondition to stack of captured conditions
+        new <- list(condition = cond, signaled = FALSE)
+        conditions <- result[["conditions"]]
+        n <- length(conditions)
+      
+        ## An existing run-time error takes precedence
+        if (n > 0L && inherits(conditions[[n]][["condition"]], "error")) {
+          conditions[[n + 1L]] <- conditions[[n]]
+          conditions[[n]] <- new
+        } else {
+          conditions[[n + 1L]] <- new
+        }
+        
+        result[["conditions"]] <- conditions
+        future[["result"]] <- result
+      }
+    }
+  }
+
 
   ## ------------------------------------------------------------------
   ## Report on misuse of the RNG

R/protected_api-FutureCondition-class.R

@@ -194,6 +194,7 @@ GlobalEnvMisuseFutureCondition <- function(message = NULL, call = NULL, differen
   if (is.null(message)) {
     label <- sQuoteLabel(future[["label"]])
     message <- sprintf("%s (%s) added variables to the global environment. A future expression should never assign variables to the global environment - neither by assign() nor by <<-: [n=%d] %s", class(future)[1], label, length(differences[["added"]]), commaq(differences[["added"]]))
+    message <- sprintf("%s. See also help(\"future.options\", package = \"future\")", message)
   }
   cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
   cond[["differences"]] <- differences
@@ -244,6 +245,7 @@ ConnectionMisuseFutureCondition <- function(message = NULL, call = NULL, differe
       details <- paste(details, collapse = ", ")
       message <- sprintf("%s. Details: %s", message, details)
     }
+    message <- sprintf("%s. See also help(\"future.options\", package = \"future\")", message)
   }
   cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
   cond[["differences"]] <- differences
@@ -288,6 +290,7 @@ DeviceMisuseFutureCondition <- function(message = NULL, call = NULL, differences
       details <- sprintf("%d devices differ: %s", length(details), paste(details, collapse = "; "))
       message <- sprintf("%s. Details: %s", message, details)
     }
+    message <- sprintf("%s. See also help(\"future.options\", package = \"future\")", message)
   }
   cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
   cond[["differences"]] <- differences
@@ -316,6 +319,40 @@ DeviceMisuseFutureError <- function(...) {
 
 
 
+#' @rdname FutureCondition
+#' @export
+DefaultDeviceMisuseFutureCondition <- function(message = NULL, times = 0L, call = NULL, uuid = future[["uuid"]], future = NULL) {
+  if (is.null(message)) {
+    label <- sQuoteLabel(future[["label"]])
+    message <- sprintf("%s (%s) opened the default graphics device %d times. This happens for instance if plot() is called without explicitly opening a graphics device before. Using default graphics devices in parallel processing will typically leave behind a 'Rplots.pdf' file on the parallel worker. If the intention is to plot to file, please open a graphics device explicitly (e.g. pdf() or png()), the plot, and make sure to close it at the end (i.e. dev.off())", class(future)[1], label, times)
+    message <- sprintf("%s. See also help(\"future.options\", package = \"future\")", message)
+  }
+  cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
+  class <- c("DefaultDeviceMisuseFutureCondition", "MisuseFutureCondition", class(cond))
+  class(cond) <- class[!duplicated(class, fromLast = TRUE)]
+  cond
+}
+
+#' @rdname FutureCondition
+#' @export
+DefaultDeviceMisuseFutureWarning <- function(...) {
+  cond <- DefaultDeviceMisuseFutureCondition(...)
+  class <- c("DefaultDeviceMisuseFutureWarning", "MisuseFutureWarning", "FutureWarning", "warning", class(cond))
+  class(cond) <- class[!duplicated(class, fromLast = TRUE)]
+  cond
+}
+
+#' @rdname FutureCondition
+#' @export
+DefaultDeviceMisuseFutureError <- function(...) {
+  cond <- DefaultDeviceMisuseFutureCondition(...)
+  class <- c("DefaultDeviceMisuseFutureError", "MisuseFutureError", "FutureError", "error", class(cond))
+  class(cond) <- class[!duplicated(class, fromLast = TRUE)]
+  cond
+}
+
+
+
 #' @rdname FutureCondition
 #' @export
 FutureLaunchError <- function(..., future = NULL) {

R/utils-options.R

@@ -94,6 +94,17 @@
 #'    (Default: `"warning"`)
 #'  }
 #'
+#'  \item{\option{future.defaultDevice.onMisuse}:}{(character string)
+#'    A future must open graphics devices explicitly, if it creates new
+#'    plots. It should not rely on the default graphics device that
+#'    is given by R option `"default"`, because that rarely does what
+#'    is intended.
+#'    If such misuse is detected and this option is set to `"error"`,
+#'    then an informative error is produced. If it is set to `"warning"`,
+#'    a warning is produced. If`"ignore"`, no check is performed.
+#'    (Default: `"warning"`)
+#'  }
+#'
 #'  \item{\option{future.devices.onMisuse}:}{(character string)
 #'    A future must close any graphics devices it opens and must not close
 #'    devices it did not open itself.
@@ -111,7 +122,7 @@
 #'    when variables are added to the global environment.
 #'    If this is detected, and this option is set to `"error"`, then an
 #'    informative error is produced. If `"warning"`, then a warning is
-#'    iproduced. If `"ignore"`, no check is performed.
+#'    produced. If `"ignore"`, no check is performed.
 #'    (Default: `"ignore"`)
 #'  }
 #'