brew.R

#' Brew in pandoc format
#'
#' This function behaves just like \code{brew} except for the \code{<\%=...\%>} tags, where \code{Pandoc.brew} first translate the R object found between the tags to Pandoc's markdown before passing to the \code{cat} function.
#'
#' This parser tries to be smart in some ways:
#'
#' \itemize{
#'      \item a block (R commands between the tags) could return any value at any part of the block and there are no restrictions about the number of returned R objects
#'      \item plots and images are grabbed in the document, rendered to a png file and \code{pander} method would result in a Pandoc's markdown formatted image link (so the image would be shown/included in the exported document). The images are put in \code{plots} directory in current \code{getwd()} or to the specified \code{output} file's directory.
#'      \item all warnings/messages and errors are recorded in the blocks and returned in the document as a footnote
#' }
#'
#' Please see my Github page for details (\url{http://rapporter.github.com/pander/#brew-to-pandoc}) and examples (\url{http://rapporter.github.com/pander/#examples}).
#' @param file file path of the brew template. As this is passed to \code{readLines}, \code{file} could be an URL too, but not over SSL (for that latter \code{RCurl} would be needed).
#' @param output (optional) file path of the output file
#' @param convert string: format of required output document (besides Pandoc's markdown). Pandoc is called if set via \code{Pandoc.convert} and the converted document could be also opened automatically (see below).
#' @param open try to open converted document with operating system's default program
#' @param graph.name character string (default to \code{\%t} when \code{output} is set to \code{stdout} and \code{paste0(basename(output), '-\%n')} otherwise) passed to \code{\link{evals}}
#' @param graph.dir character string (default to \code{tempdir()} when \code{output} is set to \code{stdout} and \code{dirname(graph.name)} otherwise) passed to \code{\link{evals}}
#' @param graph.hi.res render high resolution images of plots? Default is \code{FALSE} except for HTML output.
#' @param text character vector (treated as the content of the \code{file}
#' @param envir environment where to \code{brew} the template
#' @note Only one of the input parameters (\code{file} or \code{text}) is to be used at once!
#' @export
#' @return converted file name with full path if \code{convert} is set, none otherwise
#' @references \itemize{
#'      \item Jeffrey Horner (2011). _brew: Templating Framework for Report Generation._ \url{http://CRAN.R-project.org/package=brew}
#'      \item John MacFarlane (2012): _Pandoc User's Guide_. \url{http://johnmacfarlane.net/pandoc/README.html}
#' }
#' @examples \dontrun{
#' text <- paste('# Header', '', 'What a lovely list:\n<%=as.list(runif(10))%>', 'A wide table:\n<%=mtcars[1:3, ]%>', 'And a nice chart:\n\n<%=plot(1:10)%>', sep = '\n')
#' Pandoc.brew(text = text)
#' Pandoc.brew(text = text, output = tempfile(), convert = 'html')
#' Pandoc.brew(text = text, output = tempfile(), convert = 'pdf')
#'
#' ## pi is awesome
#' Pandoc.brew(text='<%for (i in 1:5) {%>\n Pi has a lot (<%=i%>) of power: <%=pi^i%><%}%>')
#'
#' ## package bundled examples
#' Pandoc.brew(system.file('examples/minimal.brew', package='pander'))
#' Pandoc.brew(system.file('examples/minimal.brew', package='pander'), output = tempfile(), convert = 'html')
#' Pandoc.brew(system.file('examples/short-code-long-report.brew', package='pander'))
#' Pandoc.brew(system.file('examples/short-code-long-report.brew', package='pander'), output = tempfile(), convert = 'html')
#'
#' ## brew returning R objects
#' str(Pandoc.brew(text='Pi equals to <%=pi%>.\nAnd here are some random data:\n<%=runif(10)%>'))
#' str(Pandoc.brew(text='# Header <%=1%>\nPi is <%=pi%> which is smaller then <%=2%>.\nfoo\nbar\n <%=3%>\n<%=mtcars[1:2,]%>'))
#' str(Pandoc.brew(text='<%for (i in 1:5) {%>\n Pi has a lot (<%=i%>) of power: <%=pi^i%><%}%>'))
#' }
Pandoc.brew <- function(file = stdin(), output = stdout(), convert = FALSE, open = TRUE, graph.name, graph.dir, graph.hi.res = FALSE, text = NULL, envir = parent.frame()) {

    timer <- proc.time()
    output.stdout <- deparse(substitute(output)) == 'stdout()'

    if (identical(convert, FALSE))
        open <- FALSE
    else
        if (output.stdout)
            stop('A file name should be provided while converting a document.')

    ## in HTML it's cool to have high resolution images too
    if ((missing(graph.hi.res)) & (convert == 'html'))
        graph.hi.res <- TRUE

    if (!output.stdout) {
        basedir    <- dirname(output)
        if (missing(graph.name))
            graph.name <- paste0(basename(output), '-%n')
        if (missing(graph.dir))
            graph.dir  <- file.path(basedir, 'plots')
    } else {
        if (missing(graph.name))
            graph.name <- '%t'
        if (missing(graph.dir))
            graph.dir  <- file.path(tempdir(), 'plots')
    }

    if (is.null(text))
        text <- paste(readLines(file, warn = FALSE), collapse = '\n')

    ## helper fn
    showCode <- function(..., envir = parent.frame(), cache = evalsOptions('cache')) {
        res <- evals(unlist(...), env = envir, graph.dir = graph.dir, graph.name = graph.name, hi.res = graph.hi.res)
        for (r in res) {

            r.pander <- pander.return(r)
            r$output <- r.pander
            cat(paste(r.pander, collapse = '\n'))

            localstorage <- get('.storage', envir = envir)
            localstorage.last <- tail(localstorage, 1)[[1]]
            localstorage.last.text <- ifelse(is.null(localstorage.last$text$eval), '', localstorage.last$text$eval)

            if (('image' %in% r$type) | (length(r.pander) > 1) | grepl('\n$', localstorage.last.text) | is.null(localstorage.last$text$eval))
                type <- 'block'
            else
                type <- 'inline'

            if (type == 'inline') {

                localstorage[[length(localstorage)]]$text <- list(raw = paste0(localstorage.last$text$raw, paste0('<%=', r$src, '%>')), eval = paste0(localstorage.last$text$eval, r.pander))
                localstorage[[length(localstorage)]]$chunks <- list(raw = c(localstorage.last$chunks$raw, paste0('<%=', r$src, '%>')), eval = c(localstorage.last$chunks$eval, ifelse(length(r.pander) == 0, '', r.pander)))
                localstorage[[length(localstorage)]]$msg <- list(messages = c(localstorage.last$msg$messages, r$msg$messages), warnings = c(localstorage.last$msg$warnings, r$msg$warnings), errors = c(localstorage.last$msg$errors, r$msg$errors))

            } else
                localstorage <- c(localstorage, list(list(type = 'block', robject = r)))

            assign('.storage', localstorage, envir = envir)

        }
    }
    assign('showCode', showCode, envir = envir)

    assign('.storage', NULL, envir = envir)
    res <- capture.output(brew(text = text, envir = envir))

    ## remove absolute path from image links
    if (!output.stdout)
        res <- gsub(sprintf(']\\(%s/', basedir), ']\\(', res)

    cat(remove.extra.newlines(paste(res, collapse = '\n')), '\n', file = output)

    if (is.character(convert))
        Pandoc.convert(output, format = convert, open = open, proc.time = as.numeric(proc.time() - timer)[3])

    ## remove trailing line-break text
    #if (tail(get('.storage', envir = envir), 1)[[1]]$text$eval == '\n')
    #    assign('brew', head(get('.storage', envir = envir), -1), envir = envir)

    invisible(get('.storage', envir = envir))

}


######################################################################################
## This is a forked/patched version of `brew` package made by Jeffrey Horner (c) 2007.
## Original sources can be found at: http://cran.r-project.org/web/packages/brew/
######################################################################################

BRTEXT <- 1
BRCODE <- 2
BRCOMMENT <- 3
BRCATCODE <- 4
DELIM <- list()
DELIM[[BRTEXT]] <- c("","")
DELIM[[BRCODE]] <- c("<%","%>")
DELIM[[BRCOMMENT]] <- c("<%#","%>")
DELIM[[BRCATCODE]] <- c("<%=","%>")

#' Patched brew
#'
#' This is a forked/patched version of `brew` package made by Jeffrey Horner (c) 2007. See: \code{References} about the original version.
#'
#' This custom function can do more and also less compared to the original \code{brew} package. First of all the internal caching mechanism (and other, from \code{pander} package POV needless features) of `brew` is removed for some extra profits:
#' \itemize{
#'      \item multiple R expressions can be passed between \code{<\%= ... \%>} tags,
#'      \item the text of the file and also the evaluated R objects are (invisibly) returned in a structured list, which can be really useful while post-processing the results of `brew`.
#' }
#' @param text character vector
#' @param envir environment
#' @return \code{brew}ed document to \code{stdout} and raw results while evaluating the \code{text} in a structured list.
#' @note This function should be never called directly (use \code{brew::brew} instead) as being a helper function of \code{Pandoc.brew}.
#' @seealso \code{\link{Pandoc.brew}}
#' @references Jeffrey Horner (2011). _brew: Templating Framework for Report Generation._ \url{http://CRAN.R-project.org/package=brew}z
#' @keywords internal
`brew` <- function(text = NULL, envir = parent.frame()) {

    if (is.character(text) && nchar(text[1]) > 0)
        icon <- textConnection(text[1])
    else
        stop('Invalid input.')

    if (!is.environment(envir))
        stop('Invalid environment')

    state <- BRTEXT
    text <- code <- tpl <- character(0)
    textLen <- codeLen <- as.integer(0)
    textStart <- as.integer(1)
    line <- ''

    while(TRUE){
        if (!nchar(line)){
            line <- readLines(icon,1)
            if (length(line) != 1) break
            line <- paste(line,"\n",sep='')
        }
        if (state == BRTEXT){

            spl <- strsplit(line,DELIM[[BRCODE]],fixed=TRUE)[[1]]

            # Beginning markup found
            if (length(spl) > 1){

                if (nchar(spl[1])) {
                    text[textLen+1] <- spl[1]
                    textLen <- textLen + 1
                }
                line <- paste(spl[-1],collapse='<%')

                # We know we've found this so far, so go ahead and set up state.
                state <- BRCODE

                # Now let's search for additional markup.
                if (regexpr('^=',spl[2]) > 0){
                    state <- BRCATCODE
                    line <- sub('^=','',line)
                } else if (regexpr('^#',spl[2]) > 0){
                    state <- BRCOMMENT
                }

                if (textStart <= textLen) {
                    code[codeLen+1] <- paste('showText(',textStart,',',textLen,')',sep='')
                    codeLen <- codeLen + 1
                    textStart <- textLen + 1
                }
            } else {
                text[textLen+1] <- line
                textLen <- textLen + 1
                line <- ''
            }
        } else {
            if (regexpr("%>",line,perl=TRUE) > 0){
                spl <- strsplit(line,"%>",fixed=TRUE)[[1]]
                line <- paste(spl[-1],collapse='%>')

                n <- nchar(spl[1])
                # test  for '-' immediately preceding %> will strip trailing newline from line
                if (n > 0) {
                    if (substr(spl[1],n,n) == '-') {
                        line <- substr(line,1,nchar(line)-1)
                        spl[1] <- substr(spl[1],1,n-1)
                    }
                    text[textLen+1] <- spl[1]
                    textLen <- textLen + 1
                }

                # We've found the end of a brew section, but we only care if the
                # section is a BRCODE or BRCATCODE. We just implicitly drop BRCOMMENT sections
                if (state == BRCODE){
                    code[codeLen+1] <- paste(text[textStart:textLen],collapse='')
                    codeLen <- codeLen + 1
                } else if (state == BRCATCODE){
                    code[codeLen + 1] <- paste0("showCode(", deparse(paste(text[textStart:textLen], collapse = "\n")), ")")
                    codeLen <- codeLen + 1
                }
                textStart <- textLen + 1
                state <- BRTEXT
            } else if (regexpr("<%",line,perl=TRUE) > 0){
                stop("Oops! Someone forgot to close a tag. We saw: ",DELIM[[state]][1],' and we need ',DELIM[[state]][2])
            } else {
                text[textLen+1] <- line
                textLen <- textLen + 1
                line <- ''
            }
        }
    }
    if (state == BRTEXT){
        if (textStart <= textLen) {
            code[codeLen+1] <- paste('showText(',textStart,',',textLen,')',sep='')
            codeLen <- codeLen + 1
            textStart <- textLen + 1
        }
    } else {
        stop("Oops! Someone forgot to close a tag. We saw: ",DELIM[[state]][1],' and we need ',DELIM[[state]][2], call. = FALSE)
    }

    showText <- function(from, to) {

        localtexts <- text[from:to]
        for (localtext in localtexts) {

            cat(localtext)

            if (grepl('^#+[ \t]+', localtext)) {
                heading.level <- nchar(gsub("^(#{1,6})[ \t]+.*", "\\1", localtext))
                localtext <- gsub('^#{1,6}[ \t]+', '', localtext)
                type <- 'heading'
            } else
                type <- 'text'

            localstorage <- get('.storage', envir = envir)
            localstorage.last <- tail(localstorage, 1)[[1]]
            localstorage.last.text <- localstorage.last$text$eval
            localstorage.last.type <- ifelse(is.null(localstorage.last$type), '', localstorage.last$type)

            if (localstorage.last.type == 'block' & type == 'text' & localtext != '\n') {
                localstorage.last.pander  <- localstorage.last$robject$output

                ## we had an inline chunk in the beginning of the line converted to block
                if (!('image' %in% localstorage.last$type) & (length(localstorage.last.pander) <= 1))
                    localstorage <- c(localstorage[-length(localstorage)],
                                      list(list(type = 'text',
                                           text = list(
                                               raw  = paste0('<%=', localstorage.last$robject$src,  '%>', localtext),
                                               eval = paste0(localstorage.last.pander, localtext)),
                                           chunks = list(
                                               raw = paste0('<%=', localstorage.last$robject$src,  '%>'),
                                               eval = localstorage.last.pander
                                               ),
                                           msg = list(
                                               messages = localstorage.last$robject$msg$messages,
                                               warnings = localstorage.last$robject$msg$warnings,
                                               errors   = localstorage.last$robject$msg$errors
                                               ))))

                ## leave that block as is and add localtext as new
                else

                    localstorage <- c(localstorage, list(list(type = type, text = list(raw = localtext, eval = localtext), chunks = list(raw = NULL, eval = NULL), msg = list(messages = NULL, warnings = NULL, errors = NULL))))

            } else {

                ## text continues
                if (is.character(localstorage.last.text) & (type == 'text') & ifelse(localstorage.last.type == 'heading', !grepl('\n', localstorage.last.text), TRUE))
                    localstorage[[length(localstorage)]]$text <- list(raw = paste0(localstorage.last$text$raw, localtext), eval = paste0(localstorage.last.text, localtext))

                ## new text starts here
                else
                    localstorage <- c(localstorage, list(list(type = type, text = list(raw = localtext, eval = localtext), chunks = list(raw = NULL, eval = NULL), msg = list(messages = NULL, warnings = NULL, errors = NULL))))

            }

            if (type == 'heading')
                localstorage[[length(localstorage)]]$level <- heading.level

            assign('.storage', localstorage, envir = envir)

        }

    }

    assign('showText', showText, envir = envir)

    e <- tryCatch(eval(parse(text = code), envir = envir), error = function(e) e)

    if (inherits(e, 'error')) {

        msg <- e$message
        assign('last', list(code = code, text = text, error = msg), envir = debug) # debug

        brcodes <- code[!grepl('^show', code)]
        if (length(brcodes) > 0) {
            brcodes <- p(brcodes, wrap = '`')
            if (grepl('[Uu]nexpected', msg))
                stop(paste0('`', sub('.*([Uu]nexpected [a-zA-Z0-9\\(\\)\'\\{\\} ]*)( at character|\n).*', '\\1', msg), '` in your BRCODEs: ', brcodes), call. = FALSE)
            else
                stop(sprintf('Error (`%s`) in your BRCODEs: %s', msg, brcodes), call. = FALSE)
        } else

            stop(paste0('Error: ', p(msg, wrap = '`')), call. = FALSE)

    } else
        assign('last', list(code = code, text = text, result = e), envir = debug) # debug

    ## safety check: not leaving any `sink` open
    ## while (sink.number() != 0)
    ##     sink()

    invisible()

}