1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232
|
# Copied from shiny 0.14.2
toJSON2 <- function(
x, ..., dataframe = "columns", null = "null", na = "null", auto_unbox = TRUE,
digits = getOption("shiny.json.digits", 16), use_signif = TRUE, force = TRUE,
POSIXt = "ISO8601", UTC = TRUE, rownames = FALSE, keep_vec_names = TRUE,
strict_atomic = TRUE
) {
if (strict_atomic) x <- I(x)
jsonlite::toJSON(
x, dataframe = dataframe, null = null, na = na, auto_unbox = auto_unbox,
digits = digits, use_signif = use_signif, force = force, POSIXt = POSIXt,
UTC = UTC, rownames = rownames, keep_vec_names = keep_vec_names,
json_verbatim = TRUE, ...
)
}
if (requireNamespace('shiny') && packageVersion('shiny') >= '0.12.0') local({
tryCatch({
toJSON <- getFromNamespace('toJSON', 'shiny')
args2 <- formals(toJSON2)
args1 <- formals(toJSON)
if (!identical(args1, args2)) {
warning('Check shiny:::toJSON and make sure htmlwidgets:::toJSON is in sync')
}
})
})
toJSON <- function(x) {
if (!is.list(x) || !('x' %in% names(x))) return(toJSON2(x))
func <- attr(x$x, 'TOJSON_FUNC', exact = TRUE)
args <- attr(x$x, 'TOJSON_ARGS', exact = TRUE)
if (length(args) == 0) args <- getOption('htmlwidgets.TOJSON_ARGS')
if (!is.function(func)) func <- toJSON2
res <- if (length(args) == 0) func(x) else do.call(func, c(list(x = x), args))
# make sure shiny:::toJSON() does not encode it again
structure(res, class = 'json')
}
#' Get js and css dependencies for a htmlwidget
#'
#' @param name name of the widget.
#' @param package name of the package, defaults to the widget name.
#' @export
getDependency <- function(name, package = name){
config = sprintf("htmlwidgets/%s.yaml", name)
jsfile = sprintf("htmlwidgets/%s.js", name)
# if yaml does not exist then assume no dependencies
# in this cases dependencies should be provided through the
# dependencies argument of createWidget
widgetDep <- list()
if(file.exists(system.file(config, package = package))) {
config = yaml::yaml.load_file(
system.file(config, package = package)
)
widgetDep <- lapply(config$dependencies, function(l){
l$src = system.file(l$src, package = package)
do.call(htmlDependency, l)
})
}
# if js binding does not exist then assume provided through
# some other mechanism such as a specified `htmlDependency` or `script` tag.
# Note, this is a very special case.
bindingDep <- if (file.exists(system.file(jsfile, package = package))) {
bindingDir <- system.file("htmlwidgets", package = package)
htmlDependency(
paste0(name, "-binding"), packageVersion(package),
bindingDir, script = basename(jsfile), all_files = FALSE
)
}
c(
list(htmlDependency("htmlwidgets", packageVersion("htmlwidgets"),
src = system.file("www", package="htmlwidgets"),
script = "htmlwidgets.js"
)),
widgetDep,
list(bindingDep)
)
}
`%||%` <- function(x, y){
if (is.null(x)) y else x
}
prop <- function(x, path) {
tryCatch({
for (i in strsplit(path, "$", fixed = TRUE)[[1]]) {
if (is.null(x))
return(NULL)
x <- x[[i]]
}
return(x)
}, error = function(e) {
return(NULL)
})
}
any_prop <- function(scopes, path) {
for (scope in scopes) {
result <- prop(scope, path)
if (!is.null(result))
return(result)
}
return(NULL)
}
#' Mark character strings as literal JavaScript code
#'
#' This function \code{JS()} marks character vectors with a special class, so
#' that it will be treated as literal JavaScript code when evaluated on the
#' client-side.
#' @param ... character vectors as the JavaScript source code (all arguments
#' will be pasted into one character string)
#' @author Yihui Xie
#' @export
#' @examples library(htmlwidgets)
#' JS('1 + 1')
#' list(x = JS('function(foo) {return foo;}'), y = 1:10)
#' JS('function(x) {', 'return x + 1;', '}')
JS <- function(...) {
x <- c(...)
if (is.null(x)) return()
if (!is.character(x))
stop("The arguments for JS() must be a character vector")
x <- paste(x, collapse = '\n')
structure(x, class = unique(c("JS_EVAL", oldClass(x))))
}
#' Creates a list of keys whose values need to be evaluated on the client-side
#'
#' It works by transforming \code{list(foo = list(1, list(bar =
#' I('function(){}')), 2))} to \code{list("foo.2.bar")}. Later on the JS side,
#' the \code{window.HTMLWidgets.evaluateStringMember} function is called with
#' the JSON object and the "foo.2.bar" string, which is split to \code{['foo',
#' '2', 'bar']}, and the string at that location is replaced \emph{in-situ} with
#' the results of evaluating it. Note '2' (character) should have been 2
#' (integer) but it does not seem to matter in JS: x[2] is the same as x['2']
#' when all child members of x are unnamed, and ('2' in x) will be true even if
#' x is an array without names. This is a little hackish.
#'
#' This function is intended mostly for internal use. There's generally no need
#' for widget authors or users to call it, as it's called automatically on the
#' widget instance data during rendering. It's exported in case other packages
#' want to add support for \code{\link{JS}} in contexts outside of widget
#' payloads.
#'
#' @param list a list in which the elements that should be evaluated as
#' JavaScript are to be identified
#' @author Yihui Xie
#' @keywords internal
#' @export
JSEvals <- function(list) {
# the `%||% list()` part is necessary as of R 3.4.0 (April 2017) -- if `evals`
# is NULL then `I(evals)` results in a warning in R 3.4.0. This is circumvented
# if we let `evals` be equal to `list()` in those cases
evals <- names(which(unlist(shouldEval(list)))) %||% list()
I(evals) # need I() to prevent toJSON() from converting it to scalar
}
#' JSON elements that are character with the class JS_EVAL will be evaluated
#'
#' @noRd
#' @keywords internal
shouldEval <- function(options) {
if (is.list(options)) {
if ((n <- length(options)) == 0) return(FALSE)
# use numeric indices as names (remember JS indexes from 0, hence -1 here)
if (is.null(names(options)))
names(options) <- seq_len(n) - 1L
# Escape '\' and '.' by prefixing them with '\'. This allows us to tell the
# difference between periods as separators and periods that are part of the
# name itself.
names(options) <- gsub("([\\.])", "\\\\\\1", names(options))
nms <- names(options)
if (length(nms) != n || any(nms == ''))
stop("'options' must be a fully named list, or have no names (NULL)")
lapply(options, shouldEval)
} else {
is.character(options) && inherits(options, 'JS_EVAL')
}
}
# JSEvals(list(list(foo.bar=JS("hi"), baz.qux="bye"))) == "0.foo\\.bar"
#' Execute JavaScript code after static render
#'
#' Convenience function for wrapping a JavaScript code string with a
#' \code{<script>} tag and the boilerplate necessary to delay the execution of
#' the code until after the next time htmlwidgets completes rendering any
#' widgets that are in the page. This mechanism is designed for running code to
#' customize widget instances, which can't be done at page load time since the
#' widget instances will not have been created yet.
#'
#' Each call to \code{onStaticRenderComplete} will result in at most one
#' invocation of the given code. In some edge cases in Shiny, it's possible for
#' static rendering to happen more than once (e.g. a \code{renderUI} that
#' contains static HTML widgets). \code{onStaticRenderComplete} calls only
#' schedule execution for the next static render operation.
#'
#' The pure JavaScript equivalent of \code{onStaticRenderComplete} is
#' \code{HTMLWidgets.addPostRenderHandler(callback)}, where \code{callback} is a
#' JavaScript function that takes no arguments.
#'
#' @param jsCode A character vector containing JavaScript code. No R error will
#' be raised if the code is invalid, not even on JavaScript syntax errors.
#' However, the web browser will throw errors at runtime.
#' @return An htmltools \code{\link[htmltools]{tags}$script} object.
#'
#' @examples
#' \dontrun{
#' library(leaflet)
#' library(htmltools)
#' library(htmlwidgets)
#'
#' page <- tagList(
#' leaflet() %>% addTiles(),
#' onStaticRenderComplete(
#' "HTMLWidgets.find('.leaflet').setZoom(4);"
#' )
#' )
#' print(page, browse = TRUE)
#' }
#'
#' @export
onStaticRenderComplete <- function(jsCode) {
tags$script(
"HTMLWidgets.addPostRenderHandler(function() {",
HTML(paste0(jsCode, collapse = "\n")),
"});"
)
}
|