0byt3m1n1
Path:
C:
/
Program Files
/
RStudio
/
resources
/
app
/
R
/
modules
/
[
Home
]
File: SessionRmdNotebook.R
# # SessionRmdNotebook.R # # Copyright (C) 2022 by Posit Software, PBC # # Unless you have received this program directly from Posit Software pursuant # to the terms of a commercial license agreement with Posit Software, then # this program is licensed to you under the terms of version 3 of the # GNU Affero General Public License. This program is distributed WITHOUT # ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING THOSE OF NON-INFRINGEMENT, # MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Please refer to the # AGPL (http://www.gnu.org/licenses/agpl-3.0.txt) for more details. # # assign(".rs.notebookVersion", envir = .rs.toolsEnv(), "1.0") .rs.addFunction("extractRmdFromNotebook", function(notebook) { # parse the notebook to get the text of the contained R markdown doc parsed <- try(rmarkdown::parse_html_notebook(notebook), silent = TRUE) if (inherits(parsed, "try-error") || is.null(parsed$rmd)) { return("") } # as this string will be eventually written to (and compared with) files # on disk, use native line endings return(paste(parsed$rmd, collapse = ifelse(identical(.Platform$OS.type, "windows"), "\r\n", "\n"))) }) .rs.addFunction("reRmdChunkBegin", function() { "^[\t >]*```+\\s*\\{[.]?([a-zA-Z]+.*)\\}\\s*$" }) .rs.addFunction("reRmdChunkEnd", function() { "^[\t >]*```+\\s*$" }) .rs.addFunction("reRmdInlineChunk", function(commentPrefix = "#") { sprintf("^%s\\| .*", commentPrefix) }) .rs.addFunction("rnb.cachePathFromRmdPath", function(rmdPath) { .Call("rs_chunkCacheFolder", rmdPath) }) .rs.addFunction("coalesceCsvOutput", function(chunkData) { # nothing to coalesce if < 2 outputs if (length(chunkData) < 2) return(chunkData) # keep all output by default keep <- rep(TRUE, length(chunkData)) # coalesce contents for consecutive csv entries csvs <- .rs.endsWith(names(chunkData), ".csv") for (i in seq.int(1, length(csvs) - 1)) { if (keep[[i]] && csvs[[i]] && csvs[[i + 1]]) { chunkData[[i]] <- paste(chunkData[[i]], chunkData[[i + 1]], sep = "") keep[[i + 1]] <- FALSE } } chunkData[keep] }) .rs.addFunction("readRnbCache", function(rmdPath, cachePath) { if (!file.exists(rmdPath)) stop("No file at path '", rmdPath, "'") # tolerate missing cache (implies there's no chunk outputs) rmdPath <- path.expand(rmdPath) rmdContents <- .rs.readLines(rmdPath) # Begin collecting the units that form the Rnb data structure rnbData <- list() # store reference to source path rnbData[["source_path"]] <- rmdPath rnbData[["cache_path"]] <- cachePath # Keep the original source data rnbData[["contents"]] <- rmdContents # Set up rnbData structure (if we have a cache, these entries will be filled) rnbData[["chunk_info"]] <- list() rnbData[["chunk_data"]] <- list() # early return if we have no cache if (!file.exists(cachePath)) return(rnbData) # Read the chunk information chunkInfoPath <- file.path(cachePath, "chunks.json") chunkInfo <- .rs.fromJSON(.rs.readFile(chunkInfoPath, encoding = "UTF-8")) names(chunkInfo$chunk_definitions) <- unlist(lapply(chunkInfo$chunk_definitions, `[[`, "chunk_id")) rnbData[["chunk_info"]] <- chunkInfo # Read external chunks (code chunks defined in other files) rnbData[["external_chunks"]] <- chunkInfo$external_chunks # Read the chunk data chunkDirs <- file.path(cachePath, names(chunkInfo$chunk_definitions)) chunkData <- lapply(chunkDirs, function(dir) { files <- list.files(dir, full.names = TRUE) # exclude directories fileInfo <- file.info(files) files <- files[!fileInfo$isdir] # extract the contents from each regular file contents <- lapply(files, function(file) { # ignore files that do not have a registered output handler ext <- tools::file_ext(file) if (!ext %in% names(.rs.rnb.outputHandlers)) return(NULL) # read other files (suppress warnings in case we attempt # to read a text file that has NUL bytes and hence is truncated; # if those are an issue they'll cause a louder down-stream error) suppressWarnings( .rs.readFile( file = file, encoding = "UTF-8", binary = ext %in% c("webp", "png", "jpg", "jpeg", "rdf") ) ) }) names(contents) <- basename(files) contents }) names(chunkData) <- basename(chunkDirs) rnbData[["chunk_data"]] <- chunkData rnbData }) .rs.addFunction("extractHTMLBodyElement", function(html) { begin <- regexpr('<body[^>]*>', html, perl = TRUE) end <- regexpr('</body>', html, perl = TRUE) contents <- substring(html, begin + attr(begin, "match.length"), end - 1) .rs.trimWhitespace(contents) }) .rs.addFunction("rnb.resolveActiveChunkId", function(rnbData, label) { chunkDefns <- rnbData$chunk_info$chunk_definitions for (defn in chunkDefns) { if (identical(defn$chunk_label, label)) return(defn$chunk_id) } return(NULL) }) .rs.addFunction("rnb.engineToCodeClass", function(engine) { engine <- tolower(engine) switch(engine, rcpp = "cpp", sh = "bash", engine) }) .rs.addFunction("rnb.outputSourcePng", function(fileName, fileContents, metadata, ...) { rmarkdown:::html_notebook_output_png(bytes = fileContents, meta = metadata) }) .rs.addFunction("rnb.outputSourceJpeg", function(fileName, fileContents, metadata, ...) { rmarkdown:::html_notebook_output_img(bytes = fileContents, meta = metadata, format = "jpeg") }) .rs.addFunction("rnb.outputSourceConsole", function(fileName, fileContents, context, includeSource, ...) { Encoding(fileContents) <- "UTF-8" parsed <- .rs.rnb.readConsoleData(fileContents) # exclude source code if requested if (!includeSource) parsed <- parsed[parsed$type != 0, ] # exclude console output if requested if (identical(context$results, "hide")) parsed <- parsed[parsed$type != 1, ] attributes <- list(class = .rs.rnb.engineToCodeClass(context$engine)) rendered <- .rs.rnb.renderConsoleData(parsed, attributes = attributes, context) return(rendered) }) .rs.addFunction("rnb.outputSourceHtml", function(fileName, fileContents, rnbData, chunkId, metadata, ...) { # if we have a '.json' sidecar file, this is an HTML widget jsonName <- .rs.withChangedExtension(fileName, ".json") jsonPath <- file.path(rnbData$cache_path, chunkId, jsonName) if (file.exists(jsonPath)) { # read and restore 'html_dependency' class (this may not be # preserved in the serialized JSON file) jsonContents <- .rs.fromJSON(.rs.readFile(jsonPath, encoding = "UTF-8")) for (i in seq_along(jsonContents)) class(jsonContents[[i]]) <- "html_dependency" # extract body element (this is effectively what the # widget emitted on print in addition to aforementioned # dependency information) bodyEl <- .rs.extractHTMLBodyElement(fileContents) # annotate widget manually and return asis output annotated <- rmarkdown:::html_notebook_annotated_output( bodyEl, "htmlwidget", list(dependencies = jsonContents, metadata = metadata) ) preserved <- htmltools::htmlPreserve(annotated) widget <- knitr::asis_output(preserved) attr(widget, "knit_meta") <- jsonContents return(widget) } # no .json file; just return HTML as-is annotated <- rmarkdown:::html_notebook_annotated_output( fileContents, "html", list(metadata = metadata) ) preserved <- htmltools::htmlPreserve(annotated) knitr::asis_output(preserved) }) .rs.addFunction("rnb.pagedTableHtml", function(rdfPath) { data <- .rs.readDataCapture(rdfPath) paste( "<div data-pagedtable=\"false\">", " <script data-pagedtable-source type=\"application/json\">", jsonlite::toJSON(data), " </script>", "</div>", sep = "\n" ) }) .rs.addFunction("rnb.outputSourceRdf", function(fileName, fileContents, metadata, rnbData, chunkId, ...) { rdfName <- .rs.withChangedExtension(fileName, ".rdf") rdfPath <- file.path(rnbData$cache_path, chunkId, rdfName) annotated <- rmarkdown:::html_notebook_annotated_output( .rs.rnb.pagedTableHtml(rdfPath), "frame", list(metadata = metadata, rdf = .rs.base64encode(fileContents)) ) knitr::asis_output(annotated) }) .rs.addFunction("rnb.outputSource", function(rnbData) { force(rnbData) # define output source result <- function(code, context, ...) { # resolve chunk id (attempt to match labels) chunkId <- .rs.rnb.resolveActiveChunkId(rnbData, context$label) # determine whether we include source code (respect chunk options) includeSource <- isTRUE(context$echo) && isTRUE(context$include) if (identical(context$engine, "js") || identical(context$engine, "css")) { # these engines never show code; ensure they're marked for evaluation # and then emit contents literally wrapped in the appropriate tags htmlOutput <- "" if (isTRUE(context$eval)) { if (identical(context$engine, "js")) { htmlOutput <- paste( c('<script type="text/javascript">', code, '</script>'), collapse = '\n') } else if (identical(context$engine, "css")) { htmlOutput <- paste( c('<style type="text/css">', code, '</style>'), collapse = '\n') } } return(knitr::asis_output(htmlOutput)) } else if (is.null(chunkId)) { # if we have no chunk outputs, just show source code (respecting # chunk options as appropriate) if (includeSource) { attributes <- list(class = .rs.rnb.engineToCodeClass(context$engine)) # tidy code if necessary if (isTRUE(context$tidy)) { args <- c(list(text = code, output = FALSE), context$tidy.opts) formatted <- do.call(formatR::tidy_source, args) code <- formatted$text.tidy } if (!is.null(context$indent)) { return(.rs.rnb.renderVerbatimConsoleInput(code, tolower(context$engine), "")) } else { return(rmarkdown::html_notebook_output_code(code, attributes = attributes)) } } return(knitr::asis_output("")) } chunkData <- .rs.coalesceCsvOutput(rnbData$chunk_data[[chunkId]]) # map file extensions to handlers outputList <- .rs.enumerate(chunkData, function(fileName, fileContents) { # read metadata sidecar if present metadata <- NULL metadataName <- .rs.withChangedExtension(fileName, ".metadata") metadataPath <- file.path(rnbData$cache_path, chunkId, metadataName) if (file.exists(metadataPath)) metadata <- .rs.fromJSON(.rs.readFile(metadataPath, encoding = "UTF-8")) # find and execute handler for extension (return NULL if no handler defined) ext <- tools::file_ext(fileName) handler <- .rs.rnb.outputHandlers[[ext]] if (!is.function(handler)) return(NULL) handler(code = code, context = context, fileName = fileName, fileContents = fileContents, metadata = metadata, rnbData = rnbData, chunkId = chunkId, includeSource = includeSource) }) # remove nulls filtered <- Filter(Negate(is.null), outputList) lapply(filtered, function(x) { if (!is.list(x)) list(x) else x }) } # attach a pre_knit handler that injects setup chunk options attr(result, "pre_knit") <- function() { # extract setup chunk options options <- rnbData$chunk_info$default_chunk_options if (is.null(options)) return() # fix up case where 'fig.dim' is a list options[["fig.dim"]] <- as.numeric(options[["fig.dim"]]) # set those options knitr::opts_chunk$set(options) # return invisibly invisible(NULL) } # return output source result }) .rs.addFunction("createNotebookFromCacheData", function(rnbData, inputFile, outputFile = NULL, envir = .GlobalEnv) { if (is.null(outputFile)) outputFile <- .rs.withChangedExtension(inputFile, ext = ".nb.html") # specify default encoding (we'll try to infer + convert to UTF-8 # if necessary) encoding <- getOption("encoding") # attempt to get encoding from source database (note: this will only # succeed for files already open in the IDE, but since this operation # is normally called when attempting to preview / create a notebook on # save we generally expect the document to be available) properties <- .rs.getSourceDocumentProperties(inputFile, FALSE) if (!is.null(properties$encoding)) encoding <- properties$encoding # reset the knitr chunk counter (it can be modified as a side effect of # parse_params, which is called during notebook execution) knitr:::chunk_counter(reset = TRUE) # restore external chunks into the knit environment if (!is.null(rnbData$external_chunks)) knitr:::knit_code$restore(rnbData$external_chunks) # set up output_source outputOptions <- list(output_source = .rs.rnb.outputSource(rnbData)) # override knitr's 'eval_lang' and suppress evaluation of language / # symbol chunk options (necessary since we don't actually execute any # R code while evaluating chunks and so evaluation of such chunk options # could fail) if (exists("eval_lang", envir = asNamespace("knitr"))) { override <- function(x, envir = knitr:::knit_global()) { # white-list for the commonly-used 'T' and 'F' options if (identical(x, as.name("T"))) return(TRUE) else if (identical(x, as.name("F"))) return(FALSE) else if (is.language(x)) return(NULL) else return(x) } original <- .rs.replaceBinding("eval_lang", "knitr", override) on.exit(.rs.replaceBinding("eval_lang", "knitr", original), add = TRUE) } # knitr outputs relevant information in the form of messages that we attach to the error renderMessages <- list() tryCatch({ withCallingHandlers({ # call render with special format hooks rmarkdown::render(input = inputFile, output_format = "html_notebook", output_options = outputOptions, output_file = outputFile, quiet = TRUE, envir = envir, encoding = encoding) }, message = function(...) { args <- list(...) renderMessages <<- c(renderMessages, args[[1]]) }) }, error = function(e) { messages <- list(e$message) lapply(renderMessages, function(m) { if (typeof(m) != "character") return(); result <- regexec("Quitting from lines ([0-9]+)-([0-9]+) ", text = m) if (result[[1]][[1]] < 0) return(); groups <- regmatches(m, result)[[1]] messages <<- c(messages, paste("See line ", (strtoi(groups[[2]]) - 1), sep = "")) }) stop(paste(messages, collpase = ". ", sep = "")) }) }) .rs.addFunction("createNotebookFromCache", function(rmdPath, outputPath = NULL) { # presume success unless we fail below result <- list(succeeded = .rs.scalar(TRUE)) tryCatch({ cachePath <- .rs.rnb.cachePathFromRmdPath(rmdPath) rnbData <- .rs.readRnbCache(rmdPath, cachePath) .rs.createNotebookFromCacheData(rnbData, rmdPath, outputPath) }, error = function(e) { # convert exception to error message for client result <<- list( succeeded = .rs.scalar(FALSE), error_message = .rs.scalar(e$message) ) }) result }) .rs.addFunction("rnb.readConsoleData", function(encodedData) { # read from CSV csvData <- read.csv( text = encodedData, encoding = "UTF-8", header = FALSE, stringsAsFactors = FALSE ) names(csvData) <- c("type", "text") csvData }) .rs.addFunction("rnb.renderVerbatimConsoleInput", function(code, engine, indent) { Encoding(code) <- "UTF-8" if (length(code) == 1) code <- strsplit(code, "\n", fixed = TRUE)[[1]] # remove indentation from code code <- substring(code, nchar(indent) + 1) # print as block code (as knitr might normally do) fmt <- "```%s\n%s\n```" out <- sprintf(fmt, tolower(engine), paste(code, collapse = "\n")) knitr::asis_output(out) }) .rs.addFunction("rnb.renderConsoleData", function(csvData, attributes = list(class = "r"), context = list()) { # bail early for empty data if (length(csvData) == 0 || nrow(csvData) == 0) return(list()) # remove ANSI escapes used for color from text csvData$text <- gsub("\033\\[\\d*(?:;\\d*)*m", "", csvData$text) # split on type cutpoints <- .rs.cutpoints(csvData$type) ranges <- Map( function(start, end) list(start = start, end = end), c(1, cutpoints), c(cutpoints - 1, nrow(csvData)) ) splat <- lapply(ranges, function(range) { type <- csvData$type[[range$start]] text <- csvData$text[range$start:range$end] collapse <- if (type == 0) "\n" else "" code <- paste(text, collapse = collapse) if (type == 0) { # tidy code if necessary if (isTRUE(context$tidy)) { args <- c(list(text = code, output = FALSE), context$tidy.opts) formatted <- do.call(formatR::tidy_source, args) code <- paste(formatted$text.tidy, collapse = "\n") } if (is.null(context$indent)) { return(rmarkdown::html_notebook_output_code(code, attributes = attributes)) } else { return(.rs.rnb.renderVerbatimConsoleInput(code, tolower(context$engine), context$indent)) } } else { return(code) } }) splat }) .rs.addFunction("scrapeHtmlAttributes", function(line) { reData <- '([[:alnum:]_-]+)[[:space:]]*=[[:space:]]*"(\\\\.|[^"])+"' reMatches <- gregexpr(reData, line)[[1]] starts <- c(reMatches) ends <- starts + attr(reMatches, "match.length") - 1 stripped <- substring(line, starts, ends) equalsIndex <- regexpr("=", stripped, fixed = TRUE) lhs <- substring(stripped, 1, equalsIndex - 1) rhs <- substring(stripped, equalsIndex + 2, nchar(stripped) - 1) names(rhs) <- lhs as.list(rhs) }) .rs.addFunction("rnb.encode", function(data) { .rs.base64encode(.rs.toJSON(data, unbox = TRUE)) }) .rs.addFunction("rnb.decode", function(encoded) { .rs.fromJSON(.rs.base64decode(encoded)) }) .rs.addFunction("parseInlineChunkImpl", function(opt) { # read as YAML opts <- .rs.fromYAML(opt) # knitr version 1.44 introduced a function `knitr:::dot_names` # which converts dashes to dots in chunk options knitr <- asNamespace("knitr") if (is.function(knitr$dot_names)) { opts <- knitr$dot_names(opts) } else { names(opts) <- gsub("-", ".", names(opts)) } # parse truthy and falsy style yaml options opts <- lapply(opts, function(value) { if (!is.character(value)) return(value) if (tolower(value) %in% c("y", "yes", "on")) return(TRUE) if (tolower(value) %in% c("n", "no", "off")) return(FALSE) else return(value) }) opts }) .rs.addFunction("parseInlineChunk", function(opt, commentPrefix = "#") { # remove comment prefix commentPrefixPattern <- sprintf("^%s\\|\\s+", commentPrefix) opt <- sub(commentPrefixPattern, "", opt) # check for YAML entry, mimicking code in knitr; # otherwise, parse the code as R code (comma-separated, tag=value style options) if (grepl("^[^ :]+:($|\\s)", opt[[1]])) { tryCatch( .rs.parseInlineChunkImpl(opt), error = function(cnd) list() ) } else { opts <- paste(opt, collapse = " ") knitr:::parse_params(opts, label = FALSE) } }) .rs.addFunction("evaluateChunkOptions", function(id, type, code) { Encoding(code) <- "UTF-8" code <- unlist(strsplit(code, "\n", fixed = TRUE)) # parsed chunk options; start with default chunk options opts <- list() # first, parse chunk options embedded in the chunk header rmdChunkOpts <- code[[1]] # strip chunk indicators if present matches <- unlist(regmatches(rmdChunkOpts, regexec(.rs.reRmdChunkBegin(), rmdChunkOpts))) if (length(matches) > 1) rmdChunkOpts <- matches[[2]] # attempt to parse parameters (swallow errors) .rs.tryCatch({ # extract and remove engine name (can be overridden below with engine=) opts$engine <- unlist(strsplit(rmdChunkOpts, split = "(\\s|,)+"))[[1]] rmdChunkOpts <- substring(rmdChunkOpts, nchar(opts$engine) + 1) # parse them, then merge with the defaults (evaluate in global environment) parsedParams <- eval( substitute(knitr:::parse_params(rmdChunkOpts)), envir = .GlobalEnv ) # merge options together opts <- .rs.mergeLists(opts, parsedParams) # if this is the setup chunk, it's not included by default if (identical(opts$label, "setup") && is.null(opts$include)) opts$include <- FALSE # if a chunk option is provided in both body (yaml chunk options) and header (rmdChunkOpts) # the body should override the header option opts <- opts[unique(names(opts))] # convert T, F for R code chunk options to TRUE, FALSE as appropriate opts <- lapply(opts, function(opt) { if (identical(opt, as.name("T"))) TRUE else if (identical(opt, as.name("F"))) FALSE else opt }) # convert language name objects to plain characters (these can occur in # malformed expressions, and cause scalar conversion below to fail) names <- vapply(opts, is.name, TRUE) opts[names] <- as.character(opts[names]) }) # now, try to find inline chunk options inlineChunkOptions <- c() # figure out the appropriate chunk prefix based on the engine engine <- tolower(.rs.nullCoalesce(opts$engine, "r")) commentPrefix <- if (engine %in% c("cc", "cpp", "go", "js", "node", "rcpp", "stan")) "//" else if (engine %in% c("haskell", "sql")) "--" else "#" reCommentPrefix <- .rs.reRmdInlineChunk(commentPrefix) for (line in code[-1]) { # there may be variable number of in-body chunk opts, # but they should all be at the top of the chunk match <- unlist(regmatches(line, regexec(reCommentPrefix, line))) if (length(match) == 0 && commentPrefix != "#") { # if the language-specific comment prefix character was not used, # fallback and check for starting with #| instead before bailing match <- unlist(regmatches(line, regexec(.rs.reRmdInlineChunk("#"), line))) if (length(match) == 0) break # if we found a match, we also need to update what gets passed to .rs.parseInlineChunk commentPrefix <- "#" reCommentPrefix <- .rs.reRmdInlineChunk(commentPrefix) } else if (length(match) == 0) break # add the line inlineChunkOptions <- c(inlineChunkOptions, match) } # if we had some YAML chunk options, try to add them if (length(inlineChunkOptions) > 0) { tryCatch({ inlineOpts <- .rs.parseInlineChunk(inlineChunkOptions, commentPrefix) opts <- .rs.mergeLists(opts, inlineOpts) }, error = function(e) { warning("Failed to parse chunk options in body:\n", e) }) } # ensure that fields we expect to be logical are actually logical # (sanitize invalid inputs here since they can break notebook execution) fields <- list( warning = TRUE, message = TRUE, error = FALSE ) .rs.enumerate(fields, function(key, default) { if (is.null(opts[[key]])) return() opts[[key]] <<- tryCatch( as.logical(opts[[key]]), error = function(e) default ) }) # if this is a SQL chunk, try to provide a default connection # TODO: arguably, we should be using `knitr::opts_chunk$get()` # to provide defaults for chunk options, but it's not clear if # that's always the correct choice, so we just make the smaller # piece-meal decision here if (opts$engine %in% c("mysql", "psql", "sql")) { # get current connection conn <- .rs.nullCoalesce( opts$connection, knitr::opts_chunk$get("connection") ) # our chunk execution tools expect connection to be a character naming a variable in the environment # if conn is provided as a symbol, pass connection the actual variable name # if conn is provided as a DB connection, use a temporary variable # to store the connection value and pass the temp variable name if (!is.null(conn) && !is.character(conn)) { if (is.name(conn)) { opts$connection <- as.character(conn) } else { .rs.setVar("chunkConnection", conn) opts$connection <- ".rs.chunkConnection" } } } # knitr sets a default fig.ext of 'png', so we'll set that too # this is necessary for some engines, e.g. dot # https://github.com/rstudio/rstudio/issues/13187 opts$dev <- .rs.nullCoalesce(opts$dev, "png") .rs.scalarListFromList(opts, expressions = TRUE) }) .rs.addFunction("extractChunkInnerCode", function(code) { # split into lines Encoding(code) <- "UTF-8" code <- unlist(strsplit(code, "\n", fixed = TRUE)) # find chunk indicators (safe fallbacks if absent) start <- max(1, grep(.rs.reRmdChunkBegin(), code, perl = TRUE)) end <- min(length(code), grep(.rs.reRmdChunkEnd(), code, perl = TRUE)) code <- code[(start + 1):(end - 1)] code <- gsub("#[|].*$", "", code) paste(code, collapse = "\n") }) .rs.addFunction("extractRmdChunkInformation", function(rmd) { starts <- grep(.rs.reRmdChunkBegin(), rmd, perl = TRUE) ends <- grep(.rs.reRmdChunkEnd(), rmd, perl = TRUE) # TODO: how to handle invalid document? n <- min(length(starts), length(ends)) if (length(starts) != n) starts <- starts[seq_len(n)] if (length(ends) != n) ends <- ends[seq_len(n)] # collect chunk information lapply(seq_len(n), function(i) { begin <- starts[[i]] end <- ends[[i]] contents <- rmd[begin:end] list( begin = starts[[i]], end = ends[[i]], contents = contents ) }) }) .rs.addFunction("rnb.generateRandomChunkId", function() { candidates <- c(letters, 0:9) .rs.randomString("c", candidates = candidates, n = 12L) }) .rs.addFunction("hydrateCacheFromNotebook", function(nbPath, cachePath = NULL) { if (is.null(cachePath)) { rmdPath <- .rs.withChangedExtension(nbPath, ".Rmd") cachePath <- .rs.rnb.cachePathFromRmdPath(rmdPath) } # ensure cache directory if (!.rs.dirExists(cachePath)) dir.create(cachePath, recursive = TRUE) # parse the notebook file nbData <- rmarkdown::parse_html_notebook(nbPath) # clear out old cache unlink(list.files(cachePath, full.names = TRUE), recursive = TRUE) # State, etc. ---- lastActiveAnnotation <- list() activeChunkId <- "unknown" activeChunkIndex <- 0 activeIndex <- 2 headerContent <- nbData$source[`:`( grep("^\\s*<head>\\s*$", nbData$source, perl = TRUE)[[1]] + 1, grep("^\\s*</head>\\s*$", nbData$source, perl = TRUE)[[1]] - 1 )] chunkInfo <- .rs.extractRmdChunkInformation(nbData$rmd) outputPath <- function(cachePath, chunkId, index, ext) { file.path(cachePath, chunkId, sprintf("%06i.%s", as.integer(index), ext)) } # Text ---- onText <- function(annotation) { # HACK: the 'chunk' hook is not fired for chunks that # produce no output on execution, and so such chunks # are not annotated within the generated .nb.html file. # fortunately, we can detect two sequential 'text' # blocks as an indicator that there was an 'invisible' # chunk within. if (identical(annotation$state, "begin") && identical(lastActiveAnnotation$label, "text") && identical(lastActiveAnnotation$state, "end")) { activeChunkId <<- .rs.rnb.generateRandomChunkId() activeChunkIndex <<- activeChunkIndex + 1 activeIndex <<- 2 } } # Console I/O ---- consoleDataBuilder <- .rs.listBuilder() writeConsoleData <- function(builder) { if (builder$empty()) return() # convert to .csv file df <- .rs.rbindList(builder$data()) # reorder and rename type column df <- df[c("type", "data")] df$type[df$type == "input"] <- "0" df$type[df$type == "output"] <- "1" path <- outputPath(cachePath, activeChunkId, activeIndex, "csv") .rs.ensureDirectory(dirname(path)) write.table(df, file = path, quote = TRUE, sep = ",", row.names = FALSE, col.names = FALSE, fileEncoding = "UTF-8") # update state builder$clear() activeIndex <<- activeIndex + 1 } onSource <- function(annotation) { if (annotation$state == "begin") { consoleDataBuilder$append(list( data = paste(annotation$meta$data, collapse = "\n"), type = "input" )) } else { # nothing to do? } } onOutput <- function(annotation) { if (annotation$state == "begin") { consoleDataBuilder$append(list( data = paste(annotation$meta$data, collapse = "\n"), type = "output" )) } else { # nothing to do? } } # Chunk Handling ---- chunkDefnsBuilder <- .rs.listBuilder() onChunk <- function(annotation) { if (annotation$state == "begin") { # update state re: active chunk + number of processed outputs activeChunkIndex <<- activeChunkIndex + 1 activeIndex <<- 2 # create chunk defn for this chunk info <- chunkInfo[[activeChunkIndex]] # get active chunk id (special handling for setup chunk) candidates <- c(letters, 0:9) if (.rs.isSetupChunk(info$contents)) activeChunkId <<- "csetup_chunk" else activeChunkId <<- .rs.rnb.generateRandomChunkId() # add our chunk defn chunkDefnsBuilder$append(list( chunk_id = activeChunkId, expansion_state = 0, options = list(), # TODO: parse from chunk header? row = info$end - 1, row_count = 1, # TODO: ever not 1? visible = TRUE )) } else { # flush console data writeConsoleData(consoleDataBuilder) # leaving active chunk activeChunkId <<- "unknown" } } # Plot Handling ---- plotRange <- list(start = NULL, end = NULL) plotMeta <- NULL writePlot <- function(source, range, meta) { # get html plot output html <- paste(source[`:`( range$start + 1, range$end - 1 )], collapse = " ") # extract base64 encoded content scraped <- .rs.scrapeHtmlAttributes(html) ext <- if (.rs.startsWith(scraped$src, "data:image/jpeg;")) "jpeg" else "png" imgDataEncoded <- substring(scraped$src, nchar(paste("data:image/", ext, ";base64,", sep = "")) + 1) imgData <- .rs.base64decode(imgDataEncoded, binary = TRUE) # write to file path <- outputPath(cachePath, activeChunkId, activeIndex, ext) .rs.ensureDirectory(dirname(path)) writeBin(imgData, path, useBytes = TRUE) # write metadata if present if (!is.null(meta) && !is.null(meta$metadata)) { metaPath <- outputPath(cachePath, activeChunkId, activeIndex, "metadata") cat(.rs.toJSON(meta, unbox = TRUE), file = metaPath, sep = "\n") } # update state activeIndex <<- activeIndex + 1 } onPlot <- function(annotation) { if (annotation$state == "begin") { writeConsoleData(consoleDataBuilder) plotRange$start <<- annotation$row plotMeta <<- annotation$meta } else { plotRange$end <<- annotation$row writePlot(nbData$source, plotRange, plotMeta) plotRange <<- list(start = NULL, end = NULL) plotMeta <<- NULL } } # Data frame handling ---- frameRange <- list(start = NULL, end = NULL) frameMeta <- NULL writeFrame <- function(source, range, meta) { if (is.null(meta)) return(NULL); # write out frame metadata if (!is.null(meta$metadata)) { metaPath <- outputPath(cachePath, activeChunkId, activeIndex, "metadata") cat(.rs.toJSON(meta$metadata, unbox = TRUE), file = metaPath, sep = "\n") } # write out raw frame data if (!is.null(meta$rdf)) { rdfPath <- outputPath(cachePath, activeChunkId, activeIndex, "rdf") writeBin(object = .rs.base64decode(meta$rdf, binary = TRUE), con = rdfPath) } } onFrame <- function(annotation) { if (annotation$state == "begin") { writeConsoleData(consoleDataBuilder) frameRange$start <<- annotation$row frameMeta <<- annotation$meta } else { frameRange$end <<- annotation$row writeFrame(nbData$source, frameRange, frameMeta) frameRange <<- list(start = NULL, end = NULL) frameMeta <<- NULL } } # HTML Handling ---- htmlRange <- list(start = NULL, end = NULL) htmlMeta <- NULL writeHtml <- function(source, range, meta) { # extract html from source document htmlOutput <- source[`:`( range$start + 1, range$end - 1 )] htmlPath <- outputPath(cachePath, activeChunkId, activeIndex, "html") cat(htmlOutput, file = htmlPath, sep = "\n") # write metadata if present if (!is.null(meta) && !is.null(meta$metadata)) { metaPath <- outputPath(cachePath, activeChunkId, activeIndex, "metadata") cat(.rs.toJSON(meta, unbox = TRUE), file = metaPath, sep = "\n") } # update state activeIndex <<- activeIndex + 1 } onHtml <- function(annotation) { if (annotation$state == "begin") { writeConsoleData(consoleDataBuilder) htmlRange$start <<- annotation$row htmlMeta <<- annotation$meta } else { htmlRange$end <<- annotation$row writeHtml(nbData$source, htmlRange, htmlMeta) htmlRange <<- list(start = NULL, end = NULL) htmlMeta <<- NULL } } # HTML Widget Handling ---- widgetRange <- list(start = NULL, end = NULL) widgetMeta <- NULL writeHtmlWidget <- function(source, range, meta) { # get inner (body) HTML htmlBody <- source[`:`( range$start + 1, range$end - 1 )] # TODO: background color should be passed as # metadata attribute and used here fmt <- paste( '<!DOCTYPE html>', '<html>', '<head>', '%s', '</head>', '<body style="background-color:white;">', '%s', '</body>', '</html>', sep = "\n" ) htmlOutput <- sprintf(fmt, paste(headerContent, collapse = "\n"), paste(htmlBody, collapse = "\n")) htmlPath <- outputPath(cachePath, activeChunkId, activeIndex, "html") cat(htmlOutput, file = htmlPath, sep = "\n") jsonPath <- outputPath(cachePath, activeChunkId, activeIndex, "json") cat(.rs.toJSON(meta, unbox = TRUE), file = jsonPath, sep = "\n") # update state activeIndex <<- activeIndex + 1 } onHtmlWidget <- function(annotation) { if (annotation$state == "begin") { writeConsoleData(consoleDataBuilder) widgetRange$start <<- annotation$row widgetMeta <<- annotation$meta } else { widgetRange$end <- annotation$row writeHtmlWidget(nbData$source, widgetRange, widgetMeta) widgetRange <<- list(start = NULL, end = NULL) widgetMeta <<- NULL } } # begin looping through annotations and building cache annotations <- nbData$annotations for (i in seq_along(annotations)) { annotation <- annotations[[i]] label <- annotation$label switch(label, "text" = onText(annotation), "chunk" = onChunk(annotation), "source" = onSource(annotation), "output" = onOutput(annotation), "plot" = onPlot(annotation), "html" = onHtml(annotation), "frame" = onFrame(annotation), "htmlwidget" = onHtmlWidget(annotation)) lastActiveAnnotation <- annotation } # write 'chunks.json' based on gathered chunk info mtime <- file.info(nbPath)$mtime chunks <- list( chunk_definitions = chunkDefnsBuilder$data(), doc_write_time = as.numeric(mtime) ) chunksJson <- .rs.toJSON(chunks, unbox = TRUE) chunksJsonPath <- file.path(cachePath, "chunks.json") cat(chunksJson, file = chunksJsonPath, sep = "\n") # NOTE: we don't bother writing a libs folder as we'll just dump # the base64 encoded headers into all HTML widget elements }) .rs.addFunction("isSetupChunk", function(lines) { if (!is.character(lines) || !length(lines)) return(FALSE) grepl("^\\s*```{[Rr]\\s+setup[\\s,}]", lines[[1]], perl = TRUE) }) .rs.addFunction("setDefaultChunkOptions", function() { # get the current set of chunk options chunkOptions <- knitr::opts_chunk$get() # make sure global connection lists exists if (!exists(".rs.knitr.chunkReferences", envir = .rs.toolsEnv())) assign(".rs.knitr.chunkReferences", list(), envir = .rs.toolsEnv()) # assign connection chunkReferences <- get(".rs.knitr.chunkReferences", envir = .rs.toolsEnv()) if (!is.null(chunkOptions$connection) && !is.character(chunkOptions$connection)) { idReference <- length(chunkReferences) + 1 chunkReferences[[idReference]] <- chunkOptions$connection chunkOptions$connection <- idReference } # cache the current set of chunk options assign(".rs.knitr.chunkOptions", chunkOptions, envir = .rs.toolsEnv()) # cache the set of external code knitrCode <- knitr:::knit_code$get() assign(".rs.knitr.code", knitrCode, envir = .rs.toolsEnv()) # cache default working dir knitrDir <- knitr::opts_knit$get("root.dir") assign(".rs.knitr.root.dir", knitrDir, envir = .rs.toolsEnv()) # unset the chunk options and code (so we know what options/code # were actually specified in setup chunk later) # (we tag the 'FALSE' value so we can detect if the user has explicitly # set or unset it in the setup chunk as well) defaults <- list(error = .rs.scalar(FALSE)) knitr::opts_chunk$restore(defaults) knitr:::knit_code$restore(list()) knitr::opts_knit$set(root.dir = NULL) }) .rs.addFunction("defaultChunkOptions", function() { # get current set of options defaultOptions <- knitr::opts_chunk$get() # remove the rstudio-injected 'error' option if needed if (identical(defaultOptions$error, .rs.scalar(FALSE))) defaultOptions$error <- NULL # restore the previously cached knitr options and code chunkOptions <- get(".rs.knitr.chunkOptions", envir = .rs.toolsEnv()) knitr::opts_chunk$restore(chunkOptions) knitrCode <- get(".rs.knitr.code", envir = .rs.toolsEnv()) knitr:::knit_code$restore(knitrCode) knitrDir <- get(".rs.knitr.root.dir", envir = .rs.toolsEnv()) knitr::opts_knit$set(root.dir = knitrDir) # overlay any newly-set chunk options set by the user in this chunk. # this is necessary so that settings from e.g. # # knitr::opts_chunk$set(connection = conn) # # are appropriately preserved after running the setup chunk knitr::opts_chunk$set(defaultOptions) # return current set .rs.scalarListFromList(defaultOptions) }) .rs.addFunction("executeChunkCallback", function(chunkName, chunkCode) { if (exists(".rs.notebookChunkCallbacks", envir = .rs.toolsEnv()) && length(.rs.notebookChunkCallbacks) != 0) { handle <- ls(envir = .rs.notebookChunkCallbacks) chunkCallback <- get(handle, envir = .rs.notebookChunkCallbacks) return(chunkCallback(eval(chunkName), eval(chunkCode))) } NULL }) # a list mapping file extensions to its associated output handler .rs.setVar("rnb.outputHandlers", list( "png" = .rs.rnb.outputSourcePng, "jpg" = .rs.rnb.outputSourceJpeg, "jpeg" = .rs.rnb.outputSourceJpeg, "csv" = .rs.rnb.outputSourceConsole, "html" = .rs.rnb.outputSourceHtml, "rdf" = .rs.rnb.outputSourceRdf ))