0byt3m1n1
Path:
C:
/
Program Files
/
RStudio
/
resources
/
app
/
R
/
modules
/
[
Home
]
File: NotebookHtmlWidgets.R
# # NotebookHtmlWidgets.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. # # .rs.addFunction("recordHtmlWidget", function(x, htmlfile, depfile) { .Call("rs_recordHtmlWidget", htmlfile, depfile, list( classes = class(x), sizingPolicy = if (is.list(x)) x$sizingPolicy else list() )) }) .rs.addFunction("rnb.setHtmlCaptureContext", function(...) { .rs.setVar("rnb.htmlCaptureContext", list(...)) }) .rs.addFunction("rnb.getHtmlCaptureContext", function() { .rs.getVar("rnb.htmlCaptureContext") }) # Hooks ---- .rs.addFunction("rnb.saveHtmlToCache", function(x, ...) { ctx <- .rs.rnb.getHtmlCaptureContext() # tempfile paths for html resources htmlfile <- tempfile("_rs_html_", tmpdir = ctx$outputFolder, fileext = ".html") depfile <- tempfile("_rs_html_deps_", tmpdir = ctx$outputFolder, fileext = ".json") # render html tags (to discover recursive dependencies + get html) rendered <- htmltools::renderTags(x) htmldeps <- rendered$dependencies html <- rendered$html if (length(htmldeps)) { # if we have html dependencies, write those to file and use 'save_html' cat(.rs.toJSON(htmldeps, unbox = TRUE), file = depfile, sep = "\n") htmltools::save_html(x, file = htmlfile, libdir = ctx$libraryFolder) } else { # otherwise, just write html to file as-is cat(as.character(html), file = htmlfile, sep = "\n") } # record the generated artefacts .rs.recordHtmlWidget(x, htmlfile, depfile) }) .rs.addFunction("rnbHooks.print.html", .rs.rnb.saveHtmlToCache) .rs.addFunction("rnbHooks.print.shiny.tag", .rs.rnb.saveHtmlToCache) .rs.addFunction("rnbHooks.print.shiny.tag.list", .rs.rnb.saveHtmlToCache) .rs.addFunction("rnbHooks.print.knit_asis", function(x, ...) { ctx <- .rs.rnb.getHtmlCaptureContext() # create temporary file paths mdfile <- tempfile("_rs_md_", fileext = ".md") htmlfile <- tempfile("_rs_html_", tmpdir = ctx$outputFolder, fileext = ".html") # save contents to temporary file writeLines(enc2utf8(x), con = mdfile, useBytes = TRUE) # render to HTML with pandoc rmarkdown::pandoc_convert(input = rmarkdown::pandoc_path_arg(mdfile), to = "html", output = rmarkdown::pandoc_path_arg(htmlfile)) # record in cache .rs.recordHtmlWidget(x, htmlfile, NULL) }) .rs.addFunction("rnbHooks.print.knit_image_paths", function(x, ...) { .Call("rs_recordExternalPlot", vapply(x, function(path) { dest <- tempfile(fileext = paste(".", tools::file_ext(path), sep = "")) if (identical(substr(path, 1, 7), "http://") || identical(substr(path, 1, 8), "https://")) { # if the path appears to be a URL, download it locally tryCatch({ suppressMessages(download.file(path, dest, quiet = TRUE)) }, error = function(e) {}) } else { # not a URL, presume it to be an ordinary path on disk file.copy(path, dest, copy.mode = FALSE) } dest }, "")) }) .rs.addFunction("rnbHooks.print.htmlwidget", function(x, ...) { ctx <- .rs.rnb.getHtmlCaptureContext() outputFolder <- ctx$outputFolder chunkOptions <- ctx$chunkOptions libraryFolder <- ctx$libraryFolder if (!requireNamespace("htmlwidgets", quietly = TRUE)) stop("print.htmlwidget called without 'htmlwidgets' available") htmlfile <- tempfile(pattern = "_rs_html_", tmpdir = outputFolder, fileext = ".html") # extract dependencies (for our own accounting) dependencies <- c( htmlwidgets:::widget_dependencies(class(x)[1], attr(x, "package")), x$dependencies ) # write them to JSON depfile <- tempfile(pattern = "_rs_html_deps_", tmpdir = outputFolder, fileext = ".json") cat(.rs.toJSON(dependencies, unbox = TRUE), file = depfile, sep = "\n") # force a responsive viewer sizing policy x$sizingPolicy$viewer.padding <- 0 x$sizingPolicy$viewer.fill <- TRUE # make width dynamic to size correctly non-figured if (!is.null(x$sizingPolicy$knitr) && identical(x$sizingPolicy$knitr$figure, FALSE)) { x$sizingPolicy$defaultWidth <- "auto" x$sizingPolicy$browser$fill <- FALSE } # collect knitr options knitrOptions <- knitr::opts_current$get() `%||%` <- function(x, y) if (length(x)) x else y defaultDpi <- 96 defaultFigWidth <- 7 defaultFigHeight <- 5 # detect if the default knitr chunk fig.width, fig.height have been set # TODO: could this be made more robust? are we setting these values, # or are they coming from rmarkdown / knitr? # infer the DPI (be careful to handle fig.retina) if (!is.null(chunkOptions$dpi)) { dpi <- chunkOptions$dpi } else if (!is.null(knitrOptions$dpi)) { dpi <- knitrOptions$dpi if (is.numeric(knitrOptions$fig.retina)) dpi <- dpi / knitrOptions$fig.retina } else { dpi <- defaultDpi } isDefaultKnitrSizing <- identical(knitrOptions$fig.width, defaultFigWidth) && identical(knitrOptions$fig.height, defaultFigHeight) && identical(dpi, defaultDpi) && is.null(knitrOptions$fig.asp) # detect if the user has explicitly set fig.width, fig.height for # the currently executing chunk isDefaultChunkSizing <- is.null(chunkOptions$fig.width) && is.null(chunkOptions$fig.height) && is.null(chunkOptions$fig.asp) if (isDefaultKnitrSizing && isDefaultChunkSizing) { # if the user has not set any options related to chunk sizing, then # rely on the pre-computed values in 'knitrOptions', which should # have been set based on the htmlwidget sizing policy. (recompute # those values if not set) knitrOptions$out.width.px <- .rs.firstOf( knitrOptions$out.width.px, defaultFigWidth * defaultDpi ) knitrOptions$out.height.px <- .rs.firstOf( knitrOptions$out.height.px, defaultFigHeight * defaultDpi ) } else { # otherwise, set the figure width + height according to those chunk options # compute fig.width, fig.height figWidth <- .rs.firstOf(chunkOptions$fig.width, knitrOptions$fig.width) * dpi figHeight <- .rs.firstOf(chunkOptions$fig.height, knitrOptions$fig.height) * dpi figAsp <- .rs.firstOf(chunkOptions$fig.asp, knitrOptions$fig.asp, 1) # if fig.width or fig.height is null, compute from the companion knitrOptions$out.width.px <- figWidth knitrOptions$out.height.px <- figHeight %||% figWidth * figAsp } # if, for some reason, we don't have an out.width.px or out.height.px # at this point, then just set some sane defaults knitrOptions$out.width.px <- floor(knitrOptions$out.width.px %||% 500) knitrOptions$out.height.px <- floor(knitrOptions$out.height.px %||% 500) # save as HTML -- save a modified version of the 'standalone' representation # that works effectively the same way as the 'embedded' representation; # we use a filter on the server side to disentangle things as needed html <- htmlwidgets:::toHTML(x, standalone = TRUE, knitrOptions = knitrOptions) # validate some expectations about the data structure if (length(html) != 3) stop("unexpected htmlwidget structure: expected taglist of length 3") if (html[[1]]$attribs$id != "htmlwidget_container") stop("expected a container div with id 'htmlwidget_container'") if (length(html[[1]]$children) == 0) stop("expected one or more children for htmlwidget container div") # force knitr styling on 'standalone' widget (will be overridden by sizing policy # in dynamic environments; this ensures that the 'preview' will be displayed as # though the widget were generated through 'rmarkdown::render()') # # note that this make assumptions about the widget structure that might not be # true in all cases so we wrap this in tryCatch embedded <- htmlwidgets:::toHTML(x, standalone = FALSE, knitrOptions = knitrOptions) .rs.tryCatch(html[[1]]$children[[1]][[2]]$attribs$style <- embedded[[1]][[2]]$attribs$style) # split up into parts div <- html[[1]]$children[[1]] json <- html[[2]] policy <- html[[3]] # encode the htmlwidget sizing policy as base64 (disentangled on the server # as appropriate, e.g. when showing viewer element in IDE) fmt <- "<!-- htmlwidget-sizing-policy-base64 %s -->" encodedPolicy <- .rs.base64encode(paste(as.character(policy), collapse = "\n")) htmlPolicy <- htmltools::HTML(sprintf(fmt, encodedPolicy)) # generate annotated version of standalone html that we can disentangle # with a server-side filter as needed # NOTE: if you touch this make sure you update the parsing code in NotebookOutput.cpp htmlProduct <- htmltools::tagList( htmltools::HTML("<!-- htmlwidget-container-begin -->"), div, htmltools::HTML("<!-- htmlwidget-container-end -->"), json, htmlPolicy ) attributes(htmlProduct) <- attributes(html) # write html htmltools::save_html(htmlProduct, file = htmlfile, libdir = libraryFolder) # record the saved artefacts .rs.recordHtmlWidget(x, htmlfile, depfile) }) # HTML Capture ---- .rs.addFunction("rnb.htmlCaptureHooks", function() { list( "print.htmlwidget" = .rs.rnbHooks.print.htmlwidget, "print.html" = .rs.rnbHooks.print.html, "print.shiny.tag" = .rs.rnbHooks.print.shiny.tag, "print.shiny.tag.list" = .rs.rnbHooks.print.shiny.tag.list, "print.knit_asis" = .rs.rnbHooks.print.knit_asis, "print.knit_image_paths" = .rs.rnbHooks.print.knit_image_paths ) }) .rs.addFunction("initHtmlCapture", function(outputFolder, libraryFolder, chunkOptions) { # cache context .rs.rnb.setHtmlCaptureContext( outputFolder = outputFolder, libraryFolder = libraryFolder, chunkOptions = chunkOptions ) # get and load hooks hooks <- .rs.rnb.htmlCaptureHooks() .rs.enumerate(hooks, function(key, value) { .rs.addS3Override(key, value) }) }) .rs.addFunction("releaseHtmlCapture", function() { # remove hooks hooks <- .rs.rnb.htmlCaptureHooks() for (name in names(hooks)) { .rs.removeS3Override(name) } }) .rs.addFunction("firstOf", function(...) { for (item in list(...)) if (length(item)) return(item) return(NULL) })