R/from-monad.R

In arendsee/rmonad: A Monadic Pipeline System

#' Make tabular summary of a pipeline
#'
#' @family from_Rmonad
#' @param m An Rmonad
#' @param code logical Should the code by included?
#' @export
#' @examples
#' data(gff)
#' m <- gff$good_result
#' mtabulate(m)
mtabulate <- function(m, code=FALSE){
  data.frame(
    code        = get_code(m) %>% vapply(FUN.VALUE=character(1), paste0, collapse="\n"),
    id          = get_id(m) %>% as.numeric,
    OK          = get_OK(m),
    cached      = has_value(m),
    time        = get_time(m) %>% vapply(FUN.VALUE=numeric(1), function(x) { signif(.[1], 2) }),
    space       = get_mem(m),
    is_nested   = get_nest(m)       %>% vapply(FUN.VALUE=integer(1), length),
    ndependents = get_dependents(m) %>% vapply(FUN.VALUE=integer(1), length),
    nnotes      = get_notes(m)      %>% vapply(FUN.VALUE=integer(1), length),
    nwarnings   = get_warnings(m)   %>% vapply(FUN.VALUE=integer(1), length),
    error       = get_error(m)      %>% vapply(FUN.VALUE=integer(1), length),
    doc         = get_doc(m)        %>% vapply(FUN.VALUE=integer(1), length)
  ) %>% {
    if(!code)
      .$code <- NULL
    .
  }
}

#' Tabulates all errors, warnings and notes
#' 
#' @family from_Rmonad
#' @param m An Rmonad
#' @export
#' @examples
#' data(gff)
#' m <- gff$good_result
#' missues(m)
missues <- function(m){

  error_len   <- get_error(m)    %>% vapply(FUN.VALUE=integer(1), length)
  warning_len <- get_warnings(m) %>% vapply(FUN.VALUE=integer(1), length)
  note_len    <- get_notes(m)    %>% vapply(FUN.VALUE=integer(1), length)

  ids <- get_id(m) %>% {c(
    rep(., times=error_len),
    rep(., times=warning_len),
    rep(., times=note_len)
  )}

  error    <- get_error(m)    %>% unlist %>% as.character
  warnings <- get_warnings(m) %>% unlist %>% as.character
  notes    <- get_notes(m)    %>% unlist %>% as.character
  data.frame(
    id = ids,
    type = c(
      rep("error",   length(error)),
      rep("warning", length(warnings)),
      rep("note",    length(notes))
    ),
    issue = c(error, warnings, notes)
  )
}

#' Returns the value a monad holds
#'
#' If the monad is in the passing state, return the wrapped value. Otherwise,
#' raise an appropriate error.
#'
#' Regardless of pass/fail status, \code{esc} raises all collected warnings and
#' prints all messages. Terminating a monadic sequence with \code{esc} should
#' obtain a result very close to running the same code outside the monad. The
#' main difference is that Rmonad appends the toplevel code that generated the
#' error.
#'
#' @family from_Rmonad
#' @param m An Rmonad
#' @param quiet If TRUE, print the exact messages that are raised, without
#'        extra context. 
#' @export 
#' @examples
#' library(magrittr)
#' 256 %>>% sqrt %>% esc
esc <- function(m, quiet=FALSE){

  .quiet_warning <- function(code, msg) warning(msg, call.=FALSE)
  .quiet_note    <- function(code, msg) message(msg)
  .quiet_error   <- function(code, msg) stop(msg, call.=FALSE)
  .unquiet_warning <- function(code, msg) {
    warning("in '", code, "': ", msg, call.=FALSE)
  }
  .unquiet_note <- function(code, msg) {
    message(msg)
  }
  .unquiet_error <- function(code, msg) {
    stop(paste0('in "', code, '":\n  ', msg), call.=FALSE)
  }

  mtab <- mtabulate(m, code=TRUE)

  issues <- missues(m) %>%
    { merge(mtab, .)[, c("code", "type", "issue")] }

  if(quiet){
    fw <- .quiet_warning
    fn <- .quiet_note
    fe <- .quiet_error
  } else {
    fw <- .unquiet_warning
    fn <- .unquiet_note
    fe <- .unquiet_error
  }

  for(i in seq_len(nrow(issues))){
    # raise warnings, with contextual information
    if(issues[i, "type"] == "warning"){
      fw(issues[i, "code"], issues[i, "issue"])
    }
    # pass messages verbatim
    if(issues[i, "type"] == "note"){
      fn(issues[i, "code"], issues[i, "issue"])
    }
  }
  if(! .single_OK(m)){
    fe(.single_code(m), .single_error(m))
  }

  .single_value(m)
}

#' Convert a pipeline to Rmarkdown
#'
#' Plots an rmonad workflow, summarizes the nodes, lists issues, and lists
#' details for each node. This function is likely to change extensively in the
#' future. It should be seen as one example of the kind of report that can be
#' generated by rmonad, rather than THE report.
#'
#' @family from_Rmonad
#' @param m An Rmonad
#' @param prefix A file prefix for the generated report
#' @export
#' @examples
#' \dontrun{
#' report(-1:2 %>>% log %>>% sqrt %__% "asdf" %>>% sqrt)
#' }
report <- function(
  m,
  prefix='report'
){

  dir <- tempdir()
  m_path <- file.path(dir, 'rmonad.Rd')
  r_path <- file.path(dir, 'report.Rmd')
  md_path <- file.path(dir, paste0(prefix, ".md"))

  saveRDS(m, m_path) 

  tostr <- function(x, prefix){
    if(.is_not_empty_string(x)){
      paste0(prefix, x, "\n", collapse="\n")
    } else {
      ""
    }
  }

  strsummary <- function(m, i){
    summaries <- .single_summary(m, index=i)
    headers <- if(!is.null(names(summaries))){
      names(summaries)
    } else {
      paste('summary', letters[seq_along(summaries)])
    }
    vapply(FUN.VALUE=character(1),
      seq_along(summaries),
      function(j)
        glue::glue(.open='{{', .close='}}',
          "
          ### {{headers[[j]]}}

          ```{r, echo=FALSE}
          get_summary(m)[[{{i}}]][[{{j}}]]
          ```
          "
        )
    ) %>% paste(collapse="\n")
  }

  entries <- get_id(m) %>% vapply(FUN.VALUE=character(1), function(i)
    glue::glue(.open='{{', .close='}}',
      "
      ## {{id}}

      OK={{ok}} | parents={{parents}} | cached={{cached}} | time={{time}} | memory={{mem}}

      {{doc}}

      ```{r, eval=FALSE}
      {{code}}
      ```

      {{error}}
      {{warnings}}
      {{notes}}
      {{summary}}
      ",
      id       = i,
      ok       = .single_OK(m, index=i),
      parents  = paste0("[", paste(.single_parents(m, index=i), collapse=", "), "]"),
      cached   = has_value(m, index=i),
      time     = .single_time(m, index=i),
      mem      = .single_mem(m, index=i),
      doc      = tostr(.single_doc(m, index=i)),
      code     = paste0(.single_code(m, index=i), collapse="\n"),
      error    = tostr(.single_error(m, index=i), "ERROR: "),
      warnings = tostr(.single_warnings(m, index=i), "WARNING: "),
      notes    = tostr(.single_notes(m, index=i), "NOTE: "),
      summary  = strsummary(m, i)
    )) %>% paste0(collapse="\n")

  rmd_str <- glue::glue(.open='{{', .close='}}',
    "
    ```{r, echo=FALSE}
    m <- readRDS('rmonad.Rd')
    ```

    ```{r, echo=FALSE}
    library(rmonad)
    library(knitr)
    ```

    ```{r, echo=FALSE}
    plot(m)
    ```

    ```{r, results='asis', echo=FALSE}
    kable(mtabulate(m))
    ```

    ```{r, results='asis', echo=FALSE}
    kable(missues(m))
    ```

    ```{r, echo=FALSE}
    print(m)
    ```

    {{entries}}
    ",
    entries=entries
  )

  write(rmd_str, file=r_path)

  knitr::knit(input=r_path, output=md_path)
  out_path <- knitr::pandoc(input=md_path, format='latex', ext='pdf')
  file.copy(out_path, getwd(), overwrite=TRUE)
}