#' 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)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.