future_cnd_map.R

#' Collect warnings/errors/messages/values from an expression without rerunning it
#'
#' \code{collect_all} wraps expressions and returns the result of the expression along with
#' a list of warnings, errors, and messages signalled from running the expression,
#' without having to run the expression again.
#'
#' I've personally found R's warning and message handling very confusing, and this represents "good enough" code for me.
#' Using \href{http://stackoverflow.com/questions/3903157/}{Aaron's answer to a question on stackexchange},
#' I was able to understand enough of it to make a function that would collect all the warnings and messages
#' raised by an expression and still run the code only once. (All other examples I encountered seemed to need to run
#' the code twice to get both the result and the warnings.) \cr
#' If, say, you're running a lot of models
#' all at once, then having to rerun the code (as most tutorials/answers to warning handling with R suggest)
#' would be a total pain in the butt.
#'
#' @param expr The expression you want to catch warnings and messages for.
#' @param catchErrors A boolean which, if true, will catch error messages just like it catches warnings and messages. It will then return \code{NA} as the value.
#' @param asStrings A boolean which, if true, will convert the conditions into strings.
#' @return A named list with the result of the expression, the warnings, and the messages raised by
#' the expression
#' @examples
#' # Let's say that `run_model_once(x)` fits a randomly generated glmer model with
#' #   a seed of `x`, as one might do in a power simulation
#' \dontrun{results = data.frame(IterationNumber = seq(NUMBER_ITERATIONS))
#' results = results %>%
#'   dplyr::tbl_df() %>%
#'   dplyr::mutate(models = purrr::map(IterationNumber,
#'    collect_all(run_model_once(.))))
#' }
#' @export
collect_all <- function(expr, catchErrors = FALSE, asStrings = TRUE) {
  if (asStrings == TRUE)
    convert <- function(x) Map(as.character, x)
  else convert <- identity
  
  myErrors <- myWarnings <- myMessages <- NULL
  
  wHandler <- function(w) {
    myWarnings <<- c(myWarnings, list(w))
    invokeRestart("muffleWarning")
  }
  mHandler <- function(m) {
    myMessages <<- c(myMessages, list(m))
    invokeRestart("muffleMessage")
  }
  eHandler <- function(e) {
    myErrors <<- c(myErrors, list(e))
    invokeRestart("return_NA")
  }
  
  # Not the prettiest code, I'll give you that
  if (catchErrors) {
    val <- withCallingHandlers(
      withRestarts(expr, return_NA = function(x) NA),
      warning = wHandler, message = mHandler, error = eHandler)
    myWarningList <- convert(myWarnings)
    myMessageList <- convert(myMessages)
    myErrorList  <-  convert(myErrors)
    list(value = val, warnings = myWarningList, messages = myMessageList, errors = myErrorList)
  } else {
    val <- withCallingHandlers(expr, warning = wHandler, message = mHandler)
    myWarningList <- convert(myWarnings)
    myMessageList <- convert(myMessages)
    list(value = val, warnings = myWarningList, messages = myMessageList)
  }
}

#' Immediately output warning conditions
#'
#' The function `base::warning` lets you immediately output warnings with
#' `immediate.=TRUE`, but not if the input is already a condition
#' object (weird, I know). This function is a modified Frankenstein mashup of `warning` and `message` that will immediately output warnings regardless
#' of their input form.
#' @param \dots zero or more objects which can be coerced to character (and which are pasted together with no separator) or a single condition object.
#' @param call. logical, indicating if the call should become part of the warning message.
#' @param noBreaks. logical, indicating as far as possible the message should be output as a single line when `options(warn = 1)`.
#' @param domain see `gettext`. If NA, messages will not be translated, see also the note in `stop`.
#' @export
warn_now <- function (..., call. = TRUE, noBreaks. = FALSE,
                      domain = NULL) {
  args <- list(...)
  if (length(args) == 1L && inherits(args[[1L]], "condition")) {
    cond <- args[[1L]]
    if (nargs() > 1L)
      cat(gettext("additional arguments ignored in warning()"),
          "\n", sep = "", file = stderr())
    message <- conditionMessage(cond)
    call <- conditionCall(cond)
    
    # What I added from `message`
    defaultHandler <- function(c) {
      cat(paste0(trimws(conditionMessage(c), "right"), "\n"), file = stderr(), sep = "")
    }
    withRestarts({
      .Internal(.signalCondition(cond, message, call))
      # and here
      defaultHandler(cond)
      # this is what I cut out
      # .Internal(.dfltWarn(message, call))
    }, muffleWarning = function() NULL)
    invisible(message)
  }
  else .Internal(warning(call., immediate.=TRUE, noBreaks., .makeMessage(...,
                                                                         domain = domain)))
}

# this function is just for adding a newline into outputting pre-existing message conditions
# basically to make things pretty. Not worth exporting, IMO
addLF_message <- function(...) {
  args <- list(...)
  if (length(args) == 1L && inherits(args[[1L]], "condition")) {
    if (nargs() > 1L)
      warning("additional arguments ignored in message()")
    cond <- args[[1L]]
    cond$message <- paste0(
      trimws(cond$message, which="right"),
      "\n")
    message(cond)
  } else {
    message(...)
  }
}

#' Wrap a function with `collect_all`
#'
#' This takes a function, and returns a new one, but makes it so that it goes from f(x) to `collect_all`(f(x)(x)). Basically like a Python decorator.
#'
#' @param f a function
#' @export
collect_decorator <- function(f, indices = 1:4, asStrings = TRUE) {
  f <- purrr::as_mapper(f)
  newfie <- function() x
  formals(newfie) <- formals(f)
  bod <- body(f)
  body(newfie) <- substitute(
    collect_all(
      bod,
      catchErrors = TRUE,
      asStrings = asStrings)[indices])
  return(newfie)
}


#' Make your own versions of the `furrr` `future_map` functions
#'
#' This function is responsible for making the \code{\link{future_cnd_map}} sets of functions. The code used to make it is pretty helpful for understanding \R's meta-programming, and if you need to modify the input function `.f` to the \code{\link[furrr]{future_map}} functions, you can change the `decorator_func` argument to whatever you want.
#'
#' I wanted functions that would behave with all the complexity of `furrr`'s \code{\link[furrr]{future_map}} functions (which, due to this complexity, are mostly a blackbox to me), while modifying the behavior of the specified input function, basically so I wouldn't have to keep on adding `collect_all` to these argument functions, like: `furrr::future_map(c(1:4), ~collect_all(saveRDS(...)))`. I'm inordinately proud of what I did here, making a function that would be able to take \emph{any} of the `future_map` functions and turn them into what I had in mind. Ooooh lawdy, I loved learning this.
#'
#' @param .orig_function the specific `future_map`-like function you want to base yours off of
#' @param \dots additional arguments to pass into `decorator_func`
#' @param decorator_func the function that you want to use to modify the given `.f` argument I use the term "decorator" like this is analogous to Python, but it's not 100\% accurate
#' @seealso \code{\link{collect_decorator}}, \code{\link{warn_about_package}}
#' @rdname future_walk_maker
#' @export
future_map_maker <- function(.orig_function,
                             ...,
                             decorator_func = collect_decorator) {

  new_function <- function() x
  formals(new_function) <- formals(.orig_function)
  orig_bod <- body(.orig_function)
  new_bod <- substitute({ warn_about_packages(); .f <- decorator_func(.f, ...); orig_bod })
  body(new_function) <- new_bod
  environment(new_function) <- asNamespace('furrr')
  return(new_function)
}

#' Evaluate conditions signalled in `future_map` calls
#'
#' These functions let you see the messages, warnings, and errors signalled in `future_map` calls. \cr \cr
#' Currently, the only conditions (here meaning: messages, warnings,
#' and errors) that are kept in non-sequential `future` plans are errors.
#' If you ran some complicated models on remote servers via `future_map`,
#' and some of these models gave you important warnings, no functions outside of the `future_map` call would ever 'know' about them. \cr \cr
#' The `future_cnd_map` functions will collect and preserve these conditions as S3 condition objects as elements in named lists (named "messages", "warnings", and "errors"), as well as the actual results of the map (in the sublist named "value"). \cr \cr
#' `signal_fm_conditions` takes the result of these functions, signals all the conditions for each element (displaying them grouped together sequentially for easier reading), and returns the value of the map. `evaluate_fm_results` does the same thing, but doesn't signal messages and warnings.
#'
#' The `future_cnd_map` functions can be easily expanded with the \code{\link{future_map_maker}} function. You simply need to pick the `future_map` function you want to imitate and add the `asStrings = FALSE` argument.  For example, you could make a `future_cnd_map_chr` function as easily as: `future_cnd_map_chr <- future_map_maker(furrr::future_map_chr, asStrings = FALSE)`.
#'
#' @inheritParams furrr::future_map
#' @inheritParams furrr::future_pmap
#' @inheritParams furrr::future_map2
#' @param future_cnd_map_results the output of one of the `future_cnd_map`-esque functions
#' @param displayErrors whether to display all the errors that happened in the call before signalling them. Helpful in seeing *which* elements went wrong.
#' @param signalErrors whether to signal errors or ignore them. You probably should not ignore errors.
#' @examples
#' future::plan(sequential) # other plans work fine as well
#' res <- future_cnd_map(1:3, function(i) {
#'   message(i)
#'   warning("Uh oh... ", i)
#'   if (i==2)
#'     warning("Additional warning!")
#'   if (i==3)
#'     stop("OH NO!")
#'   i + 3
#' })
#' \dontrun{signal_fm_conditions(res)}
#' @seealso \code{\link{future_map_maker}}
#' @rdname condition_maps
#' @export
future_cnd_map <- future_map_maker(furrr::future_map, asStrings = FALSE)
#' @rdname condition_maps
#' @export
future_cnd_imap <- future_map_maker(furrr::future_imap, asStrings = FALSE)
#' @rdname condition_maps
#' @export
future_cnd_map2 <- future_map_maker(furrr::future_map2, asStrings = FALSE)
#' @rdname condition_maps
#' @export
future_cnd_pmap <- future_map_maker(furrr::future_pmap, asStrings = FALSE)


#' @rdname condition_maps
#' @export
evaluate_fm_results <- function(future_cnd_map_results, signalErrors = TRUE) {
  if (signalErrors == TRUE) {
    future_cnd_map_results %>%
      purrr::walk(
        function(x) {
          if (!purrr::is_empty(x[["errors"]]))
            purrr::walk(x[["errors"]], stop)
        }) %>%
      purrr::map(~.[["value"]])
  } else {
    future_cnd_map_results %>%
      purrr::map(~.[["value"]])
  }
}

#' @rdname condition_maps
#' @export
signal_fm_conditions <- function(future_cnd_map_results, displayErrors = TRUE) {
  # Messages, warnings, and errors (outputted as warnings)
  purrr::iwalk(
    future_cnd_map_results,
    function(x, i) {
      if (length(x$messages) > 0) {
        cat("Messages in .x[", i, "]:\n", file=stderr(), sep="")
        purrr::walk(x$messages, ~addLF_message(.))
      }
      if (length(x$warnings) > 0) {
        cat("Warnings in .x[", i, "]:\n", file=stderr(), sep="")
        purrr::walk(x$warnings, ~warn_now(.))
      }
      if (length(x$errors) > 0 && displayErrors == TRUE) {
        cat("Errors in .x[", i, "]:\n", file=stderr(), sep="")
        purrr::walk(x$errors, ~cat(.$message, file=stderr(), sep=""))
      }
    }) %>%
    evaluate_fm_results()
}