#' @export
print.htmlwidget <- function(x, ..., view = interactive()) {
# if we have a viewer then forward viewer pane height (if any)
viewer <- getOption("viewer")
if (!is.null(viewer)) {
viewerFunc <- function(url) {
# get the requested pane height (it defaults to NULL)
paneHeight <- x$sizingPolicy$viewer$paneHeight
# convert maximize to -1 for compatibility with older versions of rstudio
# (newer versions convert 'maximize' to -1 interally, older versions
# will simply ignore the height if it's less than zero)
if (identical(paneHeight, "maximize"))
paneHeight <- -1
# call the viewer
viewer(url, height = paneHeight)
}
} else {
viewerFunc <- utils::browseURL
}
# call html_print with the viewer
html_print(htmltools::as.tags(x, standalone=TRUE), viewer = if (view) viewerFunc)
# return value
invisible(x)
}
#' @export
print.suppress_viewer <- function(x, ..., view = interactive()) {
viewer <- if (view) {
if (isTRUE(x$sizingPolicy$browser$external)) {
browseURL
} else if (!is.null(getOption("page_viewer"))) {
function(url) getOption("page_viewer")(url)
} else {
browseURL
}
} else {
NULL
}
html_print(htmltools::as.tags(x, standalone=TRUE), viewer = viewer)
invisible(x)
}
#' @method as.tags htmlwidget
#' @export
as.tags.htmlwidget <- function(x, standalone = FALSE, ...) {
toHTML(x, standalone = standalone)
}
#' Prepend/append extra HTML content to a widget
#'
#' Use these functions to attach extra HTML content (primarily JavaScript and/or
#' CSS styles) to a widget, for rendering in standalone mode (i.e. printing at
#' the R console) or in a knitr document. These functions are NOT supported when
#' running in a Shiny widget rendering function, and will result in a warning if
#' used in that context. Multiple calls are allowed, and later calls do not undo
#' the effects of previous calls.
#'
#' @param x An HTML Widget object
#' @param ... Valid \link[htmltools]{tags}, text, and/or
#' \code{\link[htmltools]{HTML}}, or lists thereof.
#' @return A modified HTML Widget object.
#'
#' @export
prependContent <- function(x, ...) {
x$prepend <- c(x$prepend, list(...))
x
}
#' @rdname prependContent
#' @export
appendContent <- function(x, ...) {
x$append <- c(x$append, list(...))
x
}
#' Execute custom JavaScript code after rendering
#'
#' Use this function to supplement the widget's built-in JavaScript rendering
#' logic with additional custom JavaScript code, just for this specific widget
#' object.
#'
#' @param x An HTML Widget object
#' @param jsCode Character vector containing JavaScript code (see Details)
#' @param data An additional argument to pass to the \code{jsCode} function.
#' This can be any R object that can be serialized to JSON. If you have
#' multiple objects to pass to the function, use a named list.
#' @return The modified widget object
#'
#' @details The \code{jsCode} parameter must contain valid JavaScript code which
#' when evaluated returns a function.
#'
#' The function will be invoked with three arguments: the first is the widget's
#' main HTML element, and the second is the data to be rendered (the \code{x}
#' parameter in \code{createWidget}). The third argument is the JavaScript
#' equivalent of the R object passed into \code{onRender} as the \code{data}
#' argument; this is an easy way to transfer e.g. data frames without having
#' to manually do the JSON encoding.
#'
#' When the function is invoked, the \code{this} keyword will refer to the
#' widget instance object.
#'
#' @seealso \code{\link{onStaticRenderComplete}}, for writing custom JavaScript
#' that involves multiple widgets.
#'
#' @examples
#' \dontrun{
#' library(leaflet)
#'
#' # This example uses browser geolocation. RStudio users:
#' # this won't work in the Viewer pane; try popping it
#' # out into your system web browser.
#' leaflet() %>% addTiles() %>%
#' onRender("
#' function(el, x) {
#' // Navigate the map to the user's location
#' this.locate({setView: true});
#' }
#' ")
#'
#'
#' # This example shows how you can make an R data frame available
#' # to your JavaScript code.
#'
#' meh <- "😐";
#' yikes <- "😨";
#'
#' df <- data.frame(
#' lng = quakes$long,
#' lat = quakes$lat,
#' html = ifelse(quakes$mag < 5.5, meh, yikes),
#' stringsAsFactors = FALSE
#' )
#'
#' leaflet() %>% addTiles() %>%
#' fitBounds(min(df$lng), min(df$lat), max(df$lng), max(df$lat)) %>%
#' onRender("
#' function(el, x, data) {
#' for (var i = 0; i < data.lng.length; i++) {
#' var icon = L.divIcon({className: '', html: data.html[i]});
#' L.marker([data.lat[i], data.lng[i]], {icon: icon}).addTo(this);
#' }
#' }
#' ", data = df)
#' }
#'
#' @export
onRender <- function(x, jsCode, data = NULL) {
addHook(x, "render", jsCode, data)
}
addHook <- function(x, hookName, jsCode, data = NULL) {
if (length(jsCode) == 0)
return(x)
if (length(jsCode) > 1)
jsCode <- paste(jsCode, collapse = "\n")
x$jsHooks[[hookName]] <- c(x$jsHooks[[hookName]], list(list(code = jsCode, data = data)))
x
}
toHTML <- function(x, standalone = FALSE, knitrOptions = NULL) {
x$id <- x$elementId %||% paste("htmlwidget", createWidgetId(), sep = "-")
sizeInfo <- resolveSizing(x, x$sizingPolicy, standalone = standalone, knitrOptions = knitrOptions)
name <- class(x)[1]
package <- attr(x, "package")
html <- widget_html(
name, package, id = x$id,
style = css(
width = validateCssUnit(sizeInfo$width),
height = validateCssUnit(sizeInfo$height),
),
class = paste(name, "html-widget"),
width = sizeInfo$width,
height = sizeInfo$height
)
html <- bindFillRole(html, item = sizeInfo$fill)
html <- tagList(x$prepend, html, x$append)
if (isTRUE(standalone)) {
html <- div(id = "htmlwidget_container", html)
}
html <- tagList(
html, widget_data(x, x$id),
if (!is.null(sizeInfo$runtime)) {
tags$script(
type = "application/htmlwidget-sizing",
`data-for` = x$id,
toJSON(sizeInfo$runtime)
)
}
)
deps <- c(
widget_dependencies(name, package),
x$dependencies
)
browsable(attachDependencies(html, deps, append = TRUE))
}
lookup_func <- function(name, package) {
tryCatch(
get(name, asNamespace(package), inherits = FALSE),
error = function(e) NULL
)
}
lookup_widget_html_method <- function(name, package) {
# There are two ways we look for custom widget html container methods:
#
# PACKAGE:::widget_html.NAME - This is the newer, preferred lookup. Note that
# it doesn't actually use S3 dispatch, because we don't have an S3 object to
# dispatch with (widget_html can be called without a widget instance existing
# yet).
#
# PACKAGE:::NAME_html - This is the original, legacy lookup. This is not
# preferred because it's not unique enough, i.e. someone could happen to have
# a function with this name that's not intended for widget_html use. However,
# we have to keep it for now, for backward compatibility.
fn_name <- paste0("widget_html.", name)
fn <- lookup_func(fn_name, package)
if (!is.null(fn)) {
return(list(fn = fn, name = fn_name, legacy = FALSE))
}
fn_name <- paste0(name, "_html")
fn <- lookup_func(fn_name, package)
if (!is.null(fn)) {
return(list(fn = fn, name = fn_name, legacy = TRUE))
}
list(fn = widget_html.default, name = "widget_html.default", legacy = FALSE)
}
widget_html <- function(name, package, id, style, class, inline = FALSE, ...) {
fn_info <- lookup_widget_html_method(name, package)
fn <- fn_info[["fn"]]
# id, style, and class have been required args for years, but inline is fairly new
# and undocumented, so unsuprisingly there are widgets out there are don't have an
# inline arg https://github.com/renkun-ken/formattable/blob/484777/R/render.R#L79-L88
args <- list(id = id, style = style, class = class, ...)
if ("inline" %in% names(formals(fn))) {
args$inline <- inline
}
fn_res <- do.call(fn, args)
if (isTRUE(fn_info[["legacy"]])) {
# For the PACKAGE:::NAME_html form (only), we worry about false positives;
# hopefully false positives will return something that doesn't look like a
# Shiny tag/html and they'll get this warning as a hint
if (!inherits(fn_res, c("shiny.tag", "shiny.tag.list", "html"))) {
warning(fn_info[["name"]], " returned an object of class `", class(fn_res)[1],
"` instead of a `shiny.tag`."
)
}
}
fn_res
}
widget_html.default <- function (name, package, id, style, class, inline = FALSE, ...) {
if (inline) {
tags$span(id = id, style = style, class = class)
} else {
tags$div(id = id, style = style, class = class)
}
}
## These functions are to support unit tests #######################
widgetA_html <- function(name, package, id, style, class, inline = FALSE, ...) {
tags$canvas(id = id, class = class, style = style)
}
widgetB_html <- function(name, package, id, style, class, inline = FALSE, ...) {
# Return a non-HTML result
TRUE
}
widgetC_html <- function(name, package, id, style, class, inline = FALSE, ...) {
tags$strong(id = id, class = class, style = style)
}
widget_html.widgetC <- function(name, package, id, style, class, inline = FALSE, ...) {
tags$em(id = id, class = class, style = style)
}
widget_html.widgetD <- function(name, package, id, style, class, inline = FALSE, ...) {
TRUE
}
widgetE_html <- function(name, package, id, style, class, inline = FALSE, ...) {
tagList(tags$div(id = id, style = style, class = class))
}
widgetF_html <- function(name, package, id, style, class, inline = FALSE, ...) {
HTML(as.character(tags$div(id = id, style = style, class = class)))
}
## End unit test support functions #################################
widget_dependencies <- function(name, package){
getDependency(name, package)
}
# Generates a <script type="application/json"> tag with the JSON-encoded data,
# to be picked up by htmlwidgets.js for static rendering.
widget_data <- function(x, id, ...){
# It's illegal for </script> to appear inside of a script tag, even if it's
# inside a quoted string. Fortunately we know that in JSON, the only place
# the '<' character can appear is inside a quoted string, where a Unicode
# escape has the same effect, without confusing the browser's parser. The
# repro for the bug this gsub fixes is to have the string "</script>" appear
# anywhere in the data/metadata of a widget--you will get a syntax error
# instead of a properly rendered widget.
#
# Another issue is that if </body></html> appears inside a quoted string,
# then when pandoc coverts it with --self-contained, the escaping gets messed
# up. There may be other patterns that trigger this behavior, so to be safe
# we can replace all instances of "</" with "\\u003c/".
payload <- toJSON(createPayload(x))
payload <- gsub("</", "\\u003c/", payload, fixed = TRUE)
tags$script(type = "application/json", `data-for` = id, HTML(payload))
}
#' Create an HTML Widget
#'
#' Create an HTML widget based on widget YAML and JavaScript contained within
#' the specified package.
#'
#' For additional details on developing widgets, see package vignettes:
#' \code{vignette("develop_intro", package = "htmlwidgets")}.
#'
#' @param name Widget name (should match the base name of the YAML and
#' JavaScript files used to implement the widget)
#' @param x Widget instance data (underlying data to render and options that
#' govern how it's rendered). This value will be converted to JSON using
#' \code{\link[jsonlite]{toJSON}} and made available to the widget's
#' JavaScript \code{renderValue} function.
#' @param width Fixed width for widget (in css units). The default is
#' \code{NULL}, which results in intelligent automatic sizing based on the
#' widget's container.
#' @param height Fixed height for widget (in css units). The default is
#' \code{NULL}, which results in intelligent automatic sizing based on the
#' widget's container.
#' @param sizingPolicy Options that govern how the widget is sized in various
#' containers (e.g. a standalone browser, the RStudio Viewer, a knitr figure,
#' or a Shiny output binding). These options can be specified by calling the
#' \code{\link{sizingPolicy}} function.
#' @param package Package where the widget is defined (defaults to the widget
#' name).
#' @param dependencies Additional widget HTML dependencies (over and above those
#' defined in the widget YAML). This is useful for dynamic dependencies that
#' only exist when selected widget options are enabled (e.g. sets of map tiles
#' or projections).
#' @param elementId Use an explicit element ID for the widget (rather than an
#' automatically generated one). Useful if you have other JavaScript that
#' needs to explicitly discover and interact with a specific widget instance.
#' @param preRenderHook A function to be run on the widget, just prior to
#' rendering. It accepts the entire widget object as input, and should return
#' a modified widget object.
#'
#' @return An object of class \code{htmlwidget} that will intelligently print
#' itself into HTML in a variety of contexts including the R console, within R
#' Markdown documents, and within Shiny output bindings.
#' @export
createWidget <- function(name,
x,
width = NULL,
height = NULL,
sizingPolicy = htmlwidgets::sizingPolicy(),
package = name,
dependencies = NULL,
elementId = NULL,
preRenderHook = NULL) {
# Turn single dependency object into list of dependencies, if necessary
if (inherits(dependencies, "html_dependency"))
dependencies <- list(dependencies)
structure(
list(x = x,
width = width,
height = height,
sizingPolicy = sizingPolicy,
dependencies = dependencies,
elementId = elementId,
preRenderHook = preRenderHook,
jsHooks = list()),
class = c(name,
if (sizingPolicy$viewer$suppress) "suppress_viewer",
"htmlwidget"),
package = package
)
}
#' Shiny bindings for HTML widgets
#'
#' Helpers to create output and render functions for using HTML widgets within
#' Shiny applications and interactive Rmd documents.
#'
#' @param outputId output variable to read from
#' @param name Name of widget to create output binding for
#' @param width,height Must be a valid CSS unit (like `"100%"`,
#' `"400px"`, `"auto"`) or a number, which will be coerced to a
#' string and have `"px"` appended.
#' @param package Package containing widget (defaults to `name`)
#' @param inline use an inline (`span()`) or block container (`div()`)
#' for the output
#' @param outputFunction Shiny output function corresponding to this render
#' function.
#' @param reportSize Should the widget's container size be reported in the
#' shiny session's client data?
#' @param reportTheme Should the widget's container styles (e.g., colors and fonts)
#' be reported in the shiny session's client data?
#' @param expr An expression that generates an HTML widget (or a
#' [promise](https://rstudio.github.io/promises/) of an HTML widget).
#' @param env The environment in which to evaluate `expr`.
#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
#' is useful if you want to save an expression in a variable.
#' @param cacheHint Extra information to use for optional caching using
#' `shiny::bindCache()`.
#' @param fill whether or not the returned tag should be treated as a fill item,
#' meaning that its `height` is allowed to grow/shrink to fit a fill container
#' with an opinionated height (see [htmltools::bindFillRole()] for more).
#' Examples of fill containers include `bslib::card()` and
#' `bslib::card_body_fill()`.
#'
#' @return An output or render function that enables the use of the widget
#' within Shiny applications.
#'
#' @details These functions are delegated to from within your widgets own shiny
#' output and render functions. The delegation is boilerplate and always works
#' the same for all widgets (see example below).
#'
#' @examples
#' # shiny output binding for a widget named 'foo'
#' fooOutput <- function(outputId, width = "100%", height = "400px") {
#' htmlwidgets::shinyWidgetOutput(outputId, "foo", width, height)
#' }
#'
#' # shiny render function for a widget named 'foo'
#' renderFoo <- function(expr, env = parent.frame(), quoted = FALSE) {
#' if (!quoted) { expr <- substitute(expr) } # force quoted
#' htmlwidgets::shinyRenderWidget(expr, fooOutput, env, quoted = TRUE)
#' }
#' @name htmlwidgets-shiny
#'
#' @export
#' @md
shinyWidgetOutput <- function(outputId, name, width, height, package = name,
inline = FALSE, reportSize = TRUE, reportTheme = FALSE,
fill = !inline) {
# Theme reporting requires this shiny feature
# https://github.com/rstudio/shiny/pull/2740/files
if (reportTheme && !is_installed("shiny", "1.4.0.9003")) {
message("`reportTheme = TRUE` requires shiny v.1.4.0.9003 or higher. Consider upgrading shiny.")
}
tag <- widget_html(
name, package, id = outputId,
class = paste0(
name, " html-widget html-widget-output",
if (reportSize) " shiny-report-size",
if (reportTheme) " shiny-report-theme"
),
style = css(
width = validateCssUnit(width),
height = validateCssUnit(height),
display = if (inline) "inline-block"
),
width = width,
height = height
)
tag <- bindFillRole(tag, item = fill)
# Adds an additional and unnecessary tagList() container to the return value...
# I'd love remove it, but lets keep it for backwards-compatibility
tag <- tagList(tag)
attachDependencies(
tag, widget_dependencies(name, package), append = TRUE
)
}
#' @rdname htmlwidgets-shiny
#' @export
shinyRenderWidget <- function(expr, outputFunction, env, quoted, cacheHint = "auto") {
# generate a function for the expression
shiny::installExprFunction(expr, "func", env, quoted)
renderWidget <- function(instance) {
if (!is.null(instance$elementId)) {
warning("Ignoring explicitly provided widget ID \"",
instance$elementId, "\"; Shiny doesn't use them"
)
}
# We don't support prependContent/appendContent in dynamic Shiny contexts
# because the Shiny equivalent of onStaticRenderComplete is unclear. If we
# ever figure that out it would be great to support it. One possibility
# would be to have a dedicated property for "post-render customization JS",
# I suppose. In any case, it's less of a big deal for Shiny since there are
# other mechanisms (that are at least as natural) for putting custom JS in a
# Shiny app.
if (!is.null(instance$prepend)) {
warning("Ignoring prepended content; prependContent can't be used in a ",
"Shiny render call")
}
if (!is.null(instance$append)) {
warning("Ignoring appended content; appendContent can't be used in a ",
"Shiny render call")
}
deps <- .subset2(instance, "dependencies")
deps_payload <- lapply(
htmltools::resolveDependencies(deps),
shiny::createWebDependency
)
payload <- c(createPayload(instance), list(deps = deps_payload))
payload <- toJSON(payload)
attr(payload, "deps") <- deps
payload
}
# The cacheHint and cacheReadHook args were added in Shiny 1.6.0.
if (all(c("cacheHint", "cacheReadHook") %in% names(formals(shiny::createRenderFunction)))) {
shiny::createRenderFunction(
func,
function(instance, session, name, ...) {
renderWidget(instance)
},
outputFunction,
NULL,
cacheHint = cacheHint,
cacheReadHook = function(value) {
# If we've pulled the value from the cache and we're in a different R
# process from the one that created it, we'll need to register the
# dependencies again.
deps <- attr(value, "deps")
lapply(
htmltools::resolveDependencies(deps),
shiny::createWebDependency
)
value
}
)
} else {
shiny::createRenderFunction(
func,
function(instance, session, name, ...) {
renderWidget(instance)
},
outputFunction,
NULL
)
}
}
# For the magic behind shiny::installExprFunction()
utils::globalVariables("func")
# Helper function to create payload
createPayload <- function(instance){
if (!is.null(instance$preRenderHook)){
instance <- instance$preRenderHook(instance)
instance$preRenderHook <- NULL
}
x <- .subset2(instance, "x")
list(x = x, evals = JSEvals(x), jsHooks = instance$jsHooks)
}
# package globals
.globals <- new.env(parent = emptyenv())
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.