Export widgets that can be embedded in R Notebooks

cc @hadley

Author: lionel-

NAMESPACE

@@ -18,8 +18,11 @@ export(toggleOutput)
 export(validate_cases)
 export(vdiffrAddin)
 export(widget_diff)
+export(widget_diff_)
 export(widget_slide)
+export(widget_slide_)
 export(widget_toggle)
+export(widget_toggle_)
 importFrom(R6,R6Class)
 importFrom(purrr,"%||%")
 importFrom(purrr,every)

NEWS.md

@@ -4,6 +4,12 @@
 * Depends on gdtools 0.1.2 or later as this version fixes a crash on
   Linux platforms.
 
+* `widget_toggle()`, `widget_slide()` and `widget_diff()` now take
+  plots as arguments. This makes it easy to embed a vdiffr widget in
+  R Markdown documents. The underscored versions take HTML sources as
+  argument (paths to SVG files or inline SVGs).
+
+
 # vdiffr 0.1.0
 
 * Generated SVGs are now reproducible across platforms thanks to

R/shiny-server.R

@@ -10,9 +10,9 @@ vdiffrServer <- function(cases) {
     output$type_controls <- renderTypeInput(input, cases)
     output$case_controls <- renderCaseInput(input, cases$active)
 
-    output$toggle <- renderDiffer(input, cases$active, widget_toggle)
-    output$slide <- renderDiffer(input, cases$active, widget_slide)
-    output$diff <- renderDiffer(input, cases$active, widget_diff)
+    output$toggle <- renderDiffer(input, cases$active, widget_toggle_)
+    output$slide <- renderDiffer(input, cases$active, widget_slide_)
+    output$diff <- renderDiffer(input, cases$active, widget_diff_)
 
     validateGroupCases(input, cases)
     validateSingleCase(input, cases)

R/svg.R

@@ -14,7 +14,7 @@ get_aliases <- function() {
   aliases
 }
 
-write_svg <- function(p, file, title, user_fonts) {
+write_svg <- function(p, file, title, user_fonts = NULL) {
   user_fonts <- user_fonts %||% get_aliases()
   svglite::svglite(file, user_fonts = user_fonts)
   on.exit(grDevices::dev.off())
@@ -31,7 +31,7 @@ print_plot.default <- function(p, title) {
 
 print_plot.ggplot <- function(p, title) {
   add_dependency("ggplot2")
-  if (!"title" %in% names(p$labels)) {
+  if (title != "" && !"title" %in% names(p$labels)) {
     p <- p + ggplot2::ggtitle(title)
   }
   if (!length(p$theme)) {

R/widgets.R

@@ -1,15 +1,33 @@
 #' HTML Widgets for graphical comparison
 #'
+#' These widgets can be used at the console and embedded in a R
+#' Markdown document or Shiny application.
+#'
+#' The regular versions take plots or functions as \code{before} and
+#' \code{after} arguments (see \code{\link{expect_doppelganger}()}
+#' for details). The versions suffixed with underscores take HTML image
+#' sources. These can be paths to SVG files or inlined SVG
+#' images. Currently, \code{widget_diff_()} is compatible only with
+#' inlined images.
+#'
 #' @inheritParams htmlwidgets::createWidget
-#' @param before Path to the picture that is taken as reference.
-#' @param after Path to the picture against which the reference is
-#'   compared.
+#' @param before The picture that is taken as reference.
+#' @param after The picture against which the reference is compared.
 #' @name htmlwidgets
+#' @examples
+#' p1 <- function() hist(mtcars$disp)
+#' p2 <- function() hist(mtcars$drat)
+#'
+#' # You can also call these functions in a R Markdown document or
+#' # in a Shiny application:
+#' widget_toggle(p1, p2)
+#' widget_slide(p1, p2)
+#' widget_diff(p1, p2)
 NULL
 
 #' @rdname htmlwidgets
 #' @export
-widget_toggle <- function(before, after, width = NULL, height = NULL) {
+widget_toggle_ <- function(before, after, width = NULL, height = NULL) {
   sources <- list(files = list(before = before, after = after))
 
   htmlwidgets::createWidget("vdiffr-toggle",
@@ -22,7 +40,7 @@ widget_toggle <- function(before, after, width = NULL, height = NULL) {
 
 #' @rdname htmlwidgets
 #' @export
-widget_slide <- function(before, after, width = NULL, height = NULL) {
+widget_slide_ <- function(before, after, width = NULL, height = NULL) {
   # Drawing a SVG into a canvas requires that the svg node has 'width'
   # and 'height' attributes set. Otherwise the result is oddly cropped.
   sources <- list(before = before, after = after)
@@ -38,7 +56,7 @@ widget_slide <- function(before, after, width = NULL, height = NULL) {
 
 #' @rdname htmlwidgets
 #' @export
-widget_diff <- function(before, after, width = NULL, height = NULL) {
+widget_diff_ <- function(before, after, width = NULL, height = NULL) {
   sources <- list(before = before, after = after)
   sources <- list(sources = map(sources, svg_add_dims))
 
@@ -49,3 +67,39 @@ widget_diff <- function(before, after, width = NULL, height = NULL) {
     package = "vdiffr"
   )
 }
+
+#' @rdname htmlwidgets
+#' @export
+widget_toggle <- function(before, after, width = NULL, height = NULL) {
+  files <- widget_svgs(before, after)
+  widget_toggle_(files$before, files$after, width, height)
+}
+
+#' @rdname htmlwidgets
+#' @export
+widget_slide <- function(before, after, width = NULL, height = NULL) {
+  files <- widget_svgs(before, after)
+  widget_slide_(files$before, files$after, width, height)
+}
+
+#' @rdname htmlwidgets
+#' @export
+widget_diff <- function(before, after, width = NULL, height = NULL) {
+  files <- widget_svgs(before, after)
+  widget_diff_(files$before, files$after, width, height)
+}
+
+widget_svgs <- function(before, after) {
+  out <- suppressMessages(list(
+    before = svglite::stringSVG(print_plot(before, "")),
+    after = svglite::stringSVG(print_plot(after, ""))
+  ))
+
+  # widget_diff() does not work if SVG doesn't finish with newline
+  out <- map(out, paste0, "\n")
+
+  # Inline SVGs so the widget can be easily embedded anywhere
+  out <- map(out, as_inline_svg)
+
+  out
+}