Fine grained control over sizing

Allows $width, $height, and $sizingPolicy elements of a widget object
to work together to determine the size a widget should be rendered at
for any given situation.

Still TBD: How to opt out of the RStudio Viewer pane

DESCRIPTION

@@ -7,3 +7,9 @@ Author: Ramnath Vaidyanathan, Joe Cheng, and JJ Allaire
 Maintainer: Ramnath Vaidyanathan <[email protected]>
 Description: HTML Widgets for R
 License: MIT
+Imports:
+    htmltools,
+    RJSONIO,
+    yaml
+Enhances: shiny,
+    knitr

NAMESPACE

@@ -15,5 +15,5 @@ export(widgetOutput)
 export(widget_data)
 export(widget_dependencies)
 export(widget_html)
+import(RJSONIO)
 import(htmltools)
-importFrom(knitr,knit_print)

R/htmlwidgets-package.R

@@ -1,3 +1,2 @@
-#' @import htmltools
-#' @importFrom knitr knit_print
+#' @import htmltools RJSONIO
 NULL

R/htmlwidgets.R

@@ -1,43 +1,57 @@
 #' @export
 print.htmlwidget <- function(x, ...) {
-  print(htmltools::as.tags(x))
+  print(browsable(htmltools::as.tags(x, standalone=TRUE)))
 }
 
 #' @export
-as.tags.htmlwidget <- function(x) {
-  toHTML(x, 450, 350)
+as.tags.htmlwidget <- function(x, standalone = FALSE) {
+  toHTML(x, standalone = standalone)
 }
 
 
-#' @export
-knit_print.htmlwidget <- function(x, ..., options) {
-  knit_print(
-    toHTML(x, options$out.width.px, options$out.height.px),
-    options = options, 
-    ...
-  )
-}
-
 #' @export
 toHTML <- function(x, ...){
   UseMethod('toHTML')
 }
 
 #' @export
-toHTML.htmlwidget <- function(x, defaultWidth, defaultHeight){
+toHTML.htmlwidget <- function(x, standalone = FALSE, knitrOptions = NULL, ...){
+
+  sizeInfo <- resolveSizing(x, x$sizePolicy, standalone = standalone, knitrOptions = knitrOptions)
+
   id <- paste("htmlwidget", as.integer(stats::runif(1, 1, 10000)), sep="-")
 
-  width <- if (is.null(x$width)) defaultWidth else x$width
-  height <- if (is.null(x$height)) defaultHeight else x$height
+  w <- validateCssUnit(sizeInfo$width)
+  h <- validateCssUnit(sizeInfo$height)
 
   # create a style attribute for the width and height
-  style <- paste("width:", width, "px;height:", height, "px;", sep = "")
+  style <- paste(
+    "width:", w, ";",
+    "height:", h, ";",
+    sep = "")
+
+  x$id <- id
 
-  x$id = id
+  container <- if (isTRUE(standalone)) {
+    function(x) {
+      div(id="htmlwidget_container", x)
+    }
+  } else {
+    identity
+  }
 
   html <- htmltools::tagList(
-    widget_html(x, id = id, style = style, class = class(x)[1]),
-    widget_data(x, id)
+    container(
+      widget_html(x, id = id, style = style, class = class(x)[1],
+        width = sizeInfo$width, height = sizeInfo$height
+      )
+    ),
+    widget_data(x, id),
+    if (!is.null(sizeInfo$runtime)) {
+      tags$script(type="application/htmlwidget-sizing", `data-for` = id,
+        toJSON(sizeInfo$runtime, collapse="")
+      )
+    }
   )
 
   html <- htmltools::attachDependencies(html, widget_dependencies(x))
@@ -71,12 +85,12 @@ renderWidget <- function(expr, env = parent.frame(), quoted = FALSE){
 
 
 #' @export
-widget_html <- function(x, id, style, class){
+widget_html <- function(x, id, style, class, width, height, ...){
   UseMethod('widget_html')
 }
 
 #' @export
-widget_html.htmlwidget <- function(x, id, style, class){
+widget_html.htmlwidget <- function(x, id, style, class, ...){
   tags$div(id = id, style = style, class = class)
 }
 
@@ -89,9 +103,9 @@ widget_dependencies <- function(x){
 #' @export
 widget_dependencies.htmlwidget <- function(x){
   lib = class(x)[1]
-  jsfile = attr(x, "jsfile") %||% sprintf('%s.js', lib)
-  config = attr(x, "config") %||% sprintf('%s.yaml', lib)
-  package = attr(x, "package") %||% lib
+  jsfile = attr(x, "jsfile", exact = TRUE) %||% sprintf('%s.js', lib)
+  config = attr(x, "config", exact = TRUE) %||% sprintf('%s.yaml', lib)
+  package = attr(x, "package", exact = TRUE) %||% lib
   widgetDep <- getDependency(config, package)
 
   # TODO: The binding JS file should really be in its own directory to prevent
@@ -121,6 +135,6 @@ widget_data <- function(x, id, ...){
 #' @export
 widget_data.htmlwidget <- function(x, id, ...){
   tags$script(type="application/json", `data-for` = id,
-    HTML(RJSONIO::toJSON(x))
+    HTML(toJSON(x, collapse = ""))
   )
 }

R/knitr-methods.R

@@ -0,0 +1,39 @@
+# Reusable function for registering a set of methods with S3 manually. The
+# methods argument is a list of character vectors, each of which has the form
+# c(package, genname, class).
+registerMethods <- function(methods) {
+  lapply(methods, function(method) {
+    pkg <- method[[1]]
+    generic <- method[[2]]
+    class <- method[[3]]
+    func <- get(paste(generic, class, sep="."))
+    if (pkg %in% loadedNamespaces()) {
+      registerS3method(generic, class, func, envir = asNamespace(pkg))
+    }
+    setHook(
+      packageEvent(pkg, "onLoad"),
+      function(...) {
+        registerS3method(generic, class, func, envir = asNamespace(pkg))
+      }
+    )
+  })
+}
+
+.onLoad <- function(...) {
+  # htmlwidgets provides methods for knitr::knit_print, but knitr isn't a Depends or
+  # Imports of htmltools, only an Enhances. Therefore, the NAMESPACE file has to
+  # declare it as an export, not an S3method. That means that R will only know to
+  # use our methods if htmlwidgets is actually attached, i.e., you have to use
+  # library(htmlwidgets) in a knitr document or else you'll get escaped HTML in your
+  # document. This code snippet manually registers our method(s) with S3 once both
+  # htmlwidgets and knitr are loaded.
+  registerMethods(list(
+    # c(package, genname, class)
+    c("knitr", "knit_print", "htmlwidget")
+  ))
+}
+
+#' @export
+knit_print.htmlwidget <- function(x, ..., options) {
+  knitr::knit_print(toHTML(x, standalone = FALSE, knitrOptions = options), options = options,  ...)
+}

R/sizing.R

@@ -0,0 +1,69 @@
+DEFAULT_WIDTH <- 450
+DEFAULT_HEIGHT <- 350
+DEFAULT_PADDING <- 15
+
+#' Resolve widget sizing policy
+#' 
+#' Take a widget object and sizing policy, and some other contextual details, 
+#' and figure out what width/height to use, if possible. Some decisions may need
+#' to be deferred until runtime; include any metadata that's needed for that
+#' decision in the result as well.
+#' 
+#' @param x The widget object whose size is to be determined. It may have $width
+#'   and $height directly on it, which means we should obey those.
+#' @param sp The sizing policy to use.
+#' @param standalone Logical value indicating whether the widget is being
+#'   rendered in a standalone context (where it's the only thing on the page;
+#'   this is usually via `print.htmlwidget()`).
+#' @param knitrOptions Object representing the knitr options passed to us via 
+#'   `knit_print`. If we're not doing a `knit_print` right now, then the value 
+#'   should be `NULL`.
+#' @value A list that is guaranteed to have `width` and `height` values, each of
+#'   which is either a number or CSS unit string. If `standalone=TRUE` then the
+#'   list will also have a `runtime` value that is a list, that contains two
+#'   nested lists `viewer` and `browser`. Each of those in turn has `width`,
+#'   `height`, `padding` (between 1 and 4 numbers), and `fill` (`TRUE`/`FALSE`).
+#' @keywords internal
+resolveSizing <- function(x, sp, standalone, knitrOptions = NULL) {  
+  if (isTRUE(standalone)) {
+    userSized <- !is.null(x$width) || !is.null(x$height)
+    viewerScopes <- list(sp$viewer, sp)
+    browserScopes <- list(sp$browser, sp)
+    # Precompute the width, height, padding, and fill for each scenario.
+    return(list(
+      runtime = list(
+        viewer = list(
+          width = x$width %||% any_prop(viewerScopes, "defaultWidth") %||% DEFAULT_WIDTH,
+          height = x$height %||% any_prop(viewerScopes, "defaultHeight") %||% DEFAULT_HEIGHT,
+          padding = any_prop(viewerScopes, "padding") %||% DEFAULT_PADDING,
+          fill = !userSized && any_prop(viewerScopes, "fill") %||% TRUE
+        ),
+        browser = list(
+          width = x$width %||% any_prop(browserScopes, "defaultWidth") %||% DEFAULT_WIDTH,
+          height = x$height %||% any_prop(browserScopes, "defaultHeight") %||% DEFAULT_HEIGHT,
+          padding = any_prop(browserScopes, "padding") %||% DEFAULT_PADDING,
+          fill = !userSized && any_prop(browserScopes, "fill") %||% FALSE
+        )
+      ),
+      width = x$width %||% prop(sp, "defaultWidth"),
+      height = x$height %||% prop(sp, "defaultHeight")
+    ))
+  } else if (!is.null(knitrOptions)) {
+    knitrScopes <- list(sp$knitr, sp)
+    isFigure <- any_prop(knitrScopes, "figure")
+    figWidth <- if (isFigure) knitrOptions$out.width.px else NULL
+    figHeight <- if (isFigure) knitrOptions$out.height.px else NULL
+    # Compute the width and height
+    return(list(
+      width = x$width %||% figWidth %||% any_prop(knitrScopes, "defaultWidth"),
+      height = x$height %||% figHeight %||% any_prop(knitrScopes, "defaultHeight")
+    ))
+  } else {
+    # Some non-knitr, non-print scenario.
+    # Just resolve the width/height vs. defaultWidth/defaultHeight
+    return(list(
+      width = x$width %||% prop(sp, "defaultWidth"),
+      height = x$height %||% prop(sp, "defaultHeight")
+    ))
+  }
+}

R/utils.R

@@ -19,4 +19,26 @@ getScript <- function(x, file, package){
 
 `%||%` <- 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)
 }

htmlwidgets.Rproj

@@ -15,3 +15,4 @@ LaTeX: pdfLaTeX
 BuildType: Package
 PackageUseDevtools: Yes
 PackageInstallArgs: --no-multiarch --with-keep.source
+PackageRoxygenize: rd,namespace