Add conditionMessage() for FutureCondition. Include more metadata

Author: HenrikBengtsson

DESCRIPTION

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

NAMESPACE

@@ -18,6 +18,7 @@ S3method(cancel,default)
 S3method(cancel,environment)
 S3method(cancel,list)
 S3method(cancel,listenv)
+S3method(conditionMessage,FutureCondition)
 S3method(futures,environment)
 S3method(futures,list)
 S3method(futures,listenv)

NEWS.md

@@ -1,5 +1,14 @@
 # Version (development version)
 
+## New Features
+
+ * Add `conditionMessage()` for `FutureCondition`, which appends
+   meta-data information to the original message.
+
+ * Add more metadata to `FutureCondition` objects by default, e.g. in
+   which session (including UUID, hostname, and PID) and when the
+   condition was created.
+
 ## Bug Fixes
 
  * `plan(..., interrupts = ...)` would produce a warning on "Detected

R/backend_api-11.ClusterFutureBackend-class.R

@@ -1518,7 +1518,7 @@ handleInterruptedFuture <- local({
     } else {
       event <- sprintf("was %s", state)
     }
-    msg <- sprintf("Future (%s) of class %s %s, while running on %s", label, class(future)[1], event, sQuote(host))
+    msg <- sprintf("Future (%s) of class %s %s", label, class(future)[1], event)
     if (inherits(node, "RichSOCKnode")) {
       pid <- node[["session_info"]][["process"]][["pid"]]
       if (!is.null(pid)) msg <- sprintf("%s (pid %s)", msg, pid)

R/protected_api-FutureCondition-class.R

@@ -8,12 +8,19 @@
 #' 
 #' @param message A message condition.
 #' 
-#' @param call The call stack that led up to the condition.
+#' @param call (optional) The call stack that led up to the condition.
 #' 
-#' @param uuid A universally unique identifier for the future associated with
-#' this FutureCondition.
+#' @param by (optional) A session UUID object.
 #' 
-#' @param future The [Future] involved.
+#' @param when (optional) A [POSIXct] timestamp for when the condition was
+#' created.
+#' 
+#' @param label (optional) A future label.
+#' 
+#' @param uuid (optional) A universally unique identifier for the future
+#' associated with this FutureCondition.
+#' 
+#' @param future (optional) The [Future] involved.
 #' 
 #' @return An object of class FutureCondition which inherits from class
 #' \link[base:conditions]{condition} and FutureMessage, FutureWarning,
@@ -24,7 +31,7 @@
 #'
 #' @export
 #' @keywords internal
-FutureCondition <- function(message, call = NULL, uuid = future[["uuid"]], future = NULL) {
+FutureCondition <- function(message, call = NULL, by = session_uuid(), when = NULL, uuid = future[["uuid"]], label = future[["label"]], future = NULL) {
   ## Support different types of input
   if (inherits(message, "condition")) {
     cond <- message
@@ -57,46 +64,104 @@ FutureCondition <- function(message, call = NULL, uuid = future[["uuid"]], futur
   class <- c("FutureCondition", class)
   structure(list(message = message, call = call), 
             class = class[!duplicated(class, fromLast = TRUE)],
-            uuid = uuid, future = future)
+            by = by, when = when,
+            label = label, uuid = uuid, future = future)
 }
 
 
-#' @importFrom utils tail
+#' @importFrom utils tail capture.output
 #' @export
 print.FutureCondition <- function(x, ...) {
   NextMethod()
 
+  lines <- character(0L)
+  
+  by <- attr(x, "by", exact = TRUE)
+  when <- attr(x, "when", exact = TRUE)
+  if (!is.null(by)) {
+    source <- attr(by, "source", exact = TRUE)
+    host <- source[["host"]]
+    pid <- source[["pid"]]
+    info <- c(host, sprintf("pid %d", pid), as.character(when))
+    info <- paste(info, collapse = "; ")
+    lines <- c(lines, sprintf("Occurred on: %s [%s]", by, info))
+  } else if (!is.null(when)) {
+    lines <- c(lines, sprintf("Occurred at: %s", when))
+  }
+
   uuid <- attr(x, "uuid", exact = TRUE)
-  if (is.null(uuid)) {
-    uuid <- "<NA>"
+  label <- attr(x, "label", exact = TRUE)
+  label <- if (is.null(label)) {
+    sprintf("<%s>", paste(c("unnamed", tail(uuid, 1L)), collapse = "-"))
   } else {
-    uuid <- paste(uuid, collapse = "-")
+    label <- sQuote(label)
   }
-  cat(sprintf("\n\nFuture UUID: %s\n", uuid))
+  uuid <- if (is.null(uuid)) "<NA>" else paste(uuid, collapse = "-")
+  lines <- c(lines, sprintf("Future: %s (%s)", uuid, label))
 
-  future <- attr(x, "future", exact = TRUE)
 
+  future <- attr(x, "future", exact = TRUE)
   if (!is.null(future)) {
-    cat("\n\nDEBUG: BEGIN TROUBLESHOOTING HELP\n")
-
-    if (!is.null(future)) {
-      cat("Future involved:\n")
-      print(future)
-      cat("\n")
-    }
-
-    cat("DEBUG: END TROUBLESHOOTING HELP\n")
+    lines <- c(lines, "", "DEBUG: BEGIN TROUBLESHOOTING HELP")
+    lines <- c(lines, capture.output(print(future)))
+    lines <- c(lines, "DEBUG: END TROUBLESHOOTING HELP")
   }
 
+  if (length(lines) > 0) {
+    lines <- c("", lines)
+    writeLines(lines)
+  }
+  
   invisible(x)
 } ## print()
 
 
+#' @export
+conditionMessage.FutureCondition <- function(c) {
+  msg <- NextMethod()
+
+  meta <- character()
+  
+  uuid <- attr(c, "uuid", exact = TRUE)
+  label <- attr(c, "label", exact = TRUE)
+  label <- if (is.null(label)) {
+    sprintf("<%s>", paste(c("unnamed", tail(uuid, 1L)), collapse = "-"))
+  } else {
+    label <- sQuote(label)
+  }
+  if (!is.null(uuid)) {
+    uuid <- if (is.null(uuid)) "<NA>" else paste(uuid, collapse = "-")
+    meta <- c(meta, sprintf("future %s (%s)", label, uuid))
+  } else {
+    meta <- c(meta, sprintf("future %s", label))
+  }
+
+  when <- attr(c, "when", exact = TRUE)
+  by <- attr(c, "by", exact = TRUE)
+  if (!is.null(by)) {
+    source <- attr(by, "source", exact = TRUE)
+    host <- source[["host"]]
+    pid <- source[["pid"]]
+    info <- sprintf("on %s@%s<%d>", by, host, pid)
+    if (!is.null(when)) info <- sprintf("%s at %s", info, when)
+    meta <- c(meta, info)
+  } else if (!is.null(when)) {
+    meta <- c(meta, sprintf("at %s", when))
+  }
+
+  if (length(meta) > 0) {
+    meta <- paste(meta, collapse = "; ")
+    msg <- sprintf("%s [%s]", msg, meta)
+  }
+  
+  msg
+}
+
 
 #' @rdname FutureCondition
 #' @export
-FutureMessage <- function(message, call = NULL, uuid = future[["uuid"]], future = NULL) {
-  cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
+FutureMessage <- function(message, call = NULL, ..., uuid = future[["uuid"]], future = NULL) {
+  cond <- FutureCondition(message = message, call = call, ..., uuid = uuid, future = future)
   class <- c("FutureMessage", "message", class(cond))
   class(cond) <- class[!duplicated(class, fromLast = TRUE)]
   cond
@@ -105,8 +170,8 @@ FutureMessage <- function(message, call = NULL, uuid = future[["uuid"]], future
 
 #' @rdname FutureCondition
 #' @export
-FutureWarning <- function(message, call = NULL, uuid = future[["uuid"]], future = NULL) {
-  cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
+FutureWarning <- function(message, call = NULL, ..., uuid = future[["uuid"]], future = NULL) {
+  cond <- FutureCondition(message = message, call = call, ..., uuid = uuid, future = future)
   class <- c("FutureWarning", "warning", class(cond))
   class(cond) <- class[!duplicated(class, fromLast = TRUE)]
   cond
@@ -115,8 +180,8 @@ FutureWarning <- function(message, call = NULL, uuid = future[["uuid"]], future
 
 #' @rdname FutureCondition
 #' @export
-FutureError <- function(message, call = NULL, uuid = future[["uuid"]], future = NULL) {
-  cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
+FutureError <- function(message, call = NULL, ..., uuid = future[["uuid"]], future = NULL) {
+  cond <- FutureCondition(message = message, call = call, ..., uuid = uuid, future = future)
   class <- c("FutureError", "error", class(cond))
   class(cond) <- class[!duplicated(class, fromLast = TRUE)]
   cond
@@ -125,12 +190,12 @@ FutureError <- function(message, call = NULL, uuid = future[["uuid"]], future =
 
 #' @rdname FutureCondition
 #' @export
-RngFutureCondition <- function(message = NULL, call = NULL, uuid = future[["uuid"]], future = NULL) {
+RngFutureCondition <- function(message = NULL, call = NULL, ..., uuid = future[["uuid"]], future = NULL) {
   if (is.null(message)) {
     label <- sQuoteLabel(future)
     message <- sprintf("UNRELIABLE VALUE: Future (%s) unexpectedly generated random numbers without specifying argument 'seed'. There is a risk that those random numbers are not statistically sound and the overall results might be invalid. To fix this, specify 'seed=TRUE'. This ensures that proper, parallel-safe random numbers are produced. To disable this check, use 'seed=NULL', or set option 'future.rng.onMisuse' to \"ignore\".", label)
   }
-  cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
+  cond <- FutureCondition(message = message, call = call, ..., uuid = uuid, future = future)
   class <- c("RngFutureCondition", class(cond))
   class(cond) <- class[!duplicated(class, fromLast = TRUE)]
   cond
@@ -190,13 +255,13 @@ UnexpectedFutureResultError <- function(future, hint = NULL) {
 
 #' @rdname FutureCondition
 #' @export
-GlobalEnvMisuseFutureCondition <- function(message = NULL, call = NULL, differences = NULL, uuid = future[["uuid"]], future = NULL) {
+GlobalEnvMisuseFutureCondition <- function(message = NULL, call = NULL, ..., differences = NULL, uuid = future[["uuid"]], future = NULL) {
   if (is.null(message)) {
     label <- sQuoteLabel(future)
     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 <- FutureCondition(message = message, call = call, ..., uuid = uuid, future = future)
   cond[["differences"]] <- differences
   class <- c("GlobalEnvMisuseFutureCondition", class(cond))
   class(cond) <- class[!duplicated(class, fromLast = TRUE)]
@@ -224,7 +289,7 @@ GlobalEnvMisuseFutureError <- function(...) {
 
 #' @rdname FutureCondition
 #' @export
-ConnectionMisuseFutureCondition <- function(message = NULL, call = NULL, differences = NULL, uuid = future[["uuid"]], future = NULL) {
+ConnectionMisuseFutureCondition <- function(message = NULL, call = NULL, ..., differences = NULL, uuid = future[["uuid"]], future = NULL) {
   if (is.null(message)) {
     label <- sQuoteLabel(future)
     message <- sprintf("%s (%s) added, removed, or modified connections. A future expression must close any opened connections and must not close connections it did not open", class(future)[1], label)
@@ -247,7 +312,7 @@ ConnectionMisuseFutureCondition <- function(message = NULL, call = NULL, differe
     }
     message <- sprintf("%s. See also help(\"future.options\", package = \"future\")", message)
   }
-  cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
+  cond <- FutureCondition(message = message, call = call, ..., uuid = uuid, future = future)
   cond[["differences"]] <- differences
   class <- c("ConnectionMisuseFutureCondition", "MisuseFutureCondition", class(cond))
   class(cond) <- class[!duplicated(class, fromLast = TRUE)]
@@ -276,7 +341,7 @@ ConnectionMisuseFutureError <- function(...) {
 
 #' @rdname FutureCondition
 #' @export
-DeviceMisuseFutureCondition <- function(message = NULL, call = NULL, differences = NULL, uuid = future[["uuid"]], future = NULL) {
+DeviceMisuseFutureCondition <- function(message = NULL, call = NULL, ..., differences = NULL, uuid = future[["uuid"]], future = NULL) {
   if (is.null(message)) {
     label <- sQuoteLabel(future)
     message <- sprintf("%s (%s) added, removed, or modified devices. A future expression must close any opened devices and must not close devices it did not open", class(future)[1], label)
@@ -292,7 +357,7 @@ DeviceMisuseFutureCondition <- function(message = NULL, call = NULL, differences
     }
     message <- sprintf("%s. See also help(\"future.options\", package = \"future\")", message)
   }
-  cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
+  cond <- FutureCondition(message = message, call = call, ..., uuid = uuid, future = future)
   cond[["differences"]] <- differences
   class <- c("DeviceMisuseFutureCondition", "MisuseFutureCondition", class(cond))
   class(cond) <- class[!duplicated(class, fromLast = TRUE)]
@@ -321,7 +386,7 @@ DeviceMisuseFutureError <- function(...) {
 
 #' @rdname FutureCondition
 #' @export
-DefaultDeviceMisuseFutureCondition <- function(message = NULL, incidents = NULL, call = NULL, uuid = future[["uuid"]], future = NULL) {
+DefaultDeviceMisuseFutureCondition <- function(message = NULL, call = NULL, ..., incidents = NULL, uuid = future[["uuid"]], future = NULL) {
   if (is.null(message)) {
     label <- sQuoteLabel(future)
     message <- sprintf("%s (%s) opened the default graphics device", class(future)[1], label)
@@ -340,7 +405,7 @@ DefaultDeviceMisuseFutureCondition <- function(message = NULL, incidents = NULL,
     message <- sprintf("%s. 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 an '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()) [recommended], or set your preferred `options(default = ...)` [not recommended], then plot, and make sure to close it at the end (i.e. dev.off())", message)
     message <- sprintf("%s. See also help(\"future.options\", package = \"future\")", message)
   }
-  cond <- FutureCondition(message = message, call = call, uuid = uuid, future = future)
+  cond <- FutureCondition(message = message, call = call, ..., uuid = uuid, future = future)
   class <- c("DefaultDeviceMisuseFutureCondition", "MisuseFutureCondition", class(cond))
   class(cond) <- class[!duplicated(class, fromLast = TRUE)]
   cond
@@ -377,8 +442,8 @@ FutureLaunchError <- function(..., future = NULL) {
 
 #' @rdname FutureCondition
 #' @export
-FutureInterruptError <- function(..., future = NULL) {
-  cond <- FutureError(..., future = future)
+FutureInterruptError <- function(..., when = Sys.time(), future = NULL) {
+  cond <- FutureError(..., when = when, future = future)
   class <- c("FutureInterruptError", class(cond))
   class(cond) <- class[!duplicated(class, fromLast = TRUE)]
   cond
@@ -387,7 +452,7 @@ FutureInterruptError <- function(..., future = NULL) {
 #' @rdname FutureCondition
 #' @export
 FutureCanceledError <- function(..., future = NULL) {
-  cond <- FutureError(..., future = future)
+  cond <- FutureInterruptError(..., future = future)
   class <- c("FutureCanceledError", class(cond))
   class(cond) <- class[!duplicated(class, fromLast = TRUE)]
   cond