Merge pull request #1392 from ropensci/input-events

Add more input events

Author: cpsievert

.travis.yml

@@ -33,3 +33,6 @@ before_script:
 
 # work around temporary travis + R 3.5 bug
 r_packages: devtools  
+
+# temporary: needed for plotly input testing in shiny 
+r_github_packages: rstudio/shinytest

DESCRIPTION

@@ -27,7 +27,7 @@ Imports:
     tools,
     scales,
     httr,
-    jsonlite,
+    jsonlite (>= 1.6),
     magrittr,
     digest,
     viridisLite,
@@ -54,6 +54,7 @@ Suggests:
     knitr,
     devtools,
     shiny (>= 1.1.0),
+    shinytest (> 1.3.0),
     curl,
     rmarkdown,
     vdiffr,

NAMESPACE

@@ -128,6 +128,8 @@ export(do)
 export(do_)
 export(embed_notebook)
 export(event_data)
+export(event_register)
+export(event_unregister)
 export(export)
 export(filter)
 export(filter_)
@@ -246,7 +248,8 @@ importFrom(httr,config)
 importFrom(httr,content)
 importFrom(httr,stop_for_status)
 importFrom(httr,warn_for_status)
-importFrom(jsonlite,fromJSON)
+importFrom(jsonlite,parse_json)
+importFrom(jsonlite,read_json)
 importFrom(jsonlite,toJSON)
 importFrom(lazyeval,all_dots)
 importFrom(lazyeval,f_eval)

NEWS.md

@@ -4,6 +4,11 @@
 
 * The `orca_serve()` function was added for efficient exporting of many plotly graphs. For examples, see `help(orca_serve)`.
 * The `orca()` function gains new arguments `more_args` and `...` for finer control over the underlying system commands.
+* Improvements related to accessing plotly.js events in shiny:
+  * The `event` argument of the `event_data()` function now supports the following events: `plotly_selecting`, `plotly_brushed`, `plotly_brushing`, `plotly_restyle`, `plotly_legendclick`, `plotly_legenddoubleclick`, `plotly_clickannotation`, `plotly_afterplot`, `plotly_doubleclick`, `plotly_deselect`, `plotly_unhover`. For examples, see `plotly_example("shiny", "event_data")`, `plotly_example("shiny", "event_data_legends")`, and  `plotly_example("shiny", "event_data_annotation")`, 
+    * New `event_register()` and `event_unregister()` functions for declaring which events to transmit over the wire (i.e., from the browser to the shiny server). Events that are likely to have large overhead are not registered by default, so you'll need to register these: `plotly_selecting`, `plotly_unhover`, `plotly_restyle`, `plotly_legendclick`, and `plotly_legenddoubleclick`.
+  * A new `priority` argument. By setting `priority='event'`, the `event` is treated like a true event: any reactive expression using the `event` becomes invalidated (regardless of whether the input values has changed). For an example, see `plotly_example("shiny", "event_priority")`.
+* The `method` argument of `plotlyProxyInvoke()` gains support for a `"reconfig"` method. This makes it possible to change just the configuration of a plot. For an example use, see `plotly_example("shiny", "event_data_annotation")`.
 
 ## IMPROVEMENTS
 

R/imports.R

@@ -5,7 +5,7 @@
 #' @importFrom stats setNames complete.cases quantile is.leaf
 #' @importFrom tidyr unnest
 #' @importFrom viridisLite viridis
-#' @importFrom jsonlite toJSON fromJSON
+#' @importFrom jsonlite toJSON parse_json read_json
 #' @importFrom httr GET POST PATCH content config add_headers stop_for_status warn_for_status
 #' @importFrom htmlwidgets createWidget sizingPolicy saveWidget onRender prependContent
 #' @importFrom lazyeval f_eval is_formula all_dots is_lang f_new

R/plotly_build.R

@@ -368,6 +368,9 @@ plotly_build.plotly <- function(p, registerFrames = TRUE) {
     p <- registerFrames(p, frameMapping = frameMapping)
   }
 
+  # set the default plotly.js events to register in shiny
+  p <- shiny_defaults_set(p)
+  
   p <- verify_guides(p)
 
   # verify plot attributes are legal according to the plotly.js spec

R/proxy.R

@@ -101,7 +101,8 @@ plotlyjs_methods <- function() {
   c(
     "restyle", "relayout", "update", "addTraces", "deleteTraces", "moveTraces",
     "extendTraces", "prependTraces", "purge", "toImage", "downloadImage", "animate",
-    "newPlot", "react", "validate", "makeTemplate", "validateTemplate", "addFrames"
+    "newPlot", "react", "validate", "makeTemplate", "validateTemplate", "addFrames",
+    "reconfig"
   )
 }
 

R/shiny.R

@@ -46,7 +46,7 @@ renderPlotly <- function(expr, env = parent.frame(), quoted = FALSE) {
   shiny::snapshotPreprocessOutput(
     renderFunc,
     function(value) {
-      json <- from_JSON_safe(value)
+      json <- from_JSON(value)
       json$x <- json$x[setdiff(names(json$x), c("visdat", "cur_data", "attrs"))]
       to_JSON(json)
     }
@@ -55,38 +55,185 @@ renderPlotly <- function(expr, env = parent.frame(), quoted = FALSE) {
 
 # Converts a plot, OR a promise of a plot, to plotly
 prepareWidget <- function(x) {
-  if (promises::is.promising(x)) {
-    promises::then(x, ggplotly)
+  p <- if (promises::is.promising(x)) {
+    promises::then(x, plotly_build)
   } else {
-    ggplotly(x)
+    plotly_build(x)
   }
+  register_plot_events(p)
+  p
+}
+
+register_plot_events <- function(p) {
+  session <- getDefaultReactiveDomain()
+  eventIDs <- paste(p$x$shinyEvents, p$x$source, sep = "-")
+  session$userData$plotlyShinyEventIDs <- unique(c(
+    session$userData$plotlyShinyEventIDs,
+    eventIDs
+  ))
 }
 
 
 #' Access plotly user input event data in shiny
 #' 
 #' This function must be called within a reactive shiny context.
 #' 
-#' @param event The type of plotly event. Currently 'plotly_hover',
-#' 'plotly_click', 'plotly_selected', and 'plotly_relayout' are supported.
+#' @param event The type of plotly event. All supported events are listed in the 
+#' function signature above (i.e., the usage section).
 #' @param source a character string of length 1. Match the value of this string 
-#' with the source argument in [plot_ly()] to retrieve the 
-#' event data corresponding to a specific plot (shiny apps can have multiple plots).
+#' with the `source` argument in [plot_ly()] (or [ggplotly()]) to respond to  
+#' events emitted from that specific plot.
 #' @param session a shiny session object (the default should almost always be used).
+#' @param priority the priority of the corresponding shiny input value. 
+#' If equal to `"event"`, then [event_data()] always triggers re-execution, 
+#' instead of re-executing only when the relevant shiny input value changes 
+#' (the default).
 #' @export
+#' @seealso [event_register], [event_unregister]
+#' @references 
+#'   * <https://plotly-book.cpsievert.me/shiny-plotly-inputs.html> 
+#'   * <https://plot.ly/javascript/plotlyjs-function-reference/>
 #' @author Carson Sievert
 #' @examples \dontrun{
 #' plotly_example("shiny", "event_data")
 #' }
 
-event_data <- function(event = c("plotly_hover", "plotly_click", "plotly_selected", 
-                                 "plotly_relayout"), source = "A",
-                       session = shiny::getDefaultReactiveDomain()) {
+event_data <- function(
+  event = c(
+    "plotly_hover", "plotly_unhover", "plotly_click", "plotly_doubleclick",
+    "plotly_selected", "plotly_selecting", "plotly_brushed", "plotly_brushing", 
+    "plotly_deselect", "plotly_relayout", "plotly_restyle", "plotly_legendclick", 
+    "plotly_legenddoubleclick", "plotly_clickannotation", "plotly_afterplot"
+  ),
+  source = "A",
+  session = shiny::getDefaultReactiveDomain(),
+  priority = c("input", "event")
+) {
   if (is.null(session)) {
     stop("No reactive domain detected. This function can only be called \n",
          "from within a reactive shiny context.")
   }
-  src <- sprintf(".clientValue-%s-%s", event[1], source)
-  val <- session$rootScope()$input[[src]]
-  if (is.null(val)) val else jsonlite::fromJSON(val)
+  
+  event <- match.arg(event)
+  eventID <- paste(event, source, sep = "-")
+  
+  # It's possible for event_data() to execute before any 
+  # relevant input values have been registered (i.e, before 
+  # relevant plotly graphs have been executed). Therefore, 
+  # we delay checking that a relevant input value has been 
+  # registered until shiny flushes
+  session$onFlushed(
+    function() {
+      eventIDRegistered <- eventID %in% session$userData$plotlyShinyEventIDs
+      if (!eventIDRegistered) {
+        warning(
+          "The '", event, "' event tied a source ID of '", source, "' ",
+          "is not registered. In order to obtain this event data, ", 
+          "please add `event_register(p, '", event, "')` to the plot (`p`) ",
+          "that you wish to obtain event data from.",
+          call. = FALSE
+        )
+      }
+    }
+  )
+  
+  # legend clicking returns trace(s), which shouldn't be simplified...
+  parseJSON <- if (event %in% c("plotly_legendclick", "plotly_legenddoubleclick")) {
+    from_JSON
+  } else {
+    function(x) jsonlite::parse_json(x, simplifyVector = TRUE)
+  }
+  
+  # Handle NULL sensibly
+  parseJSONVal <- function(x) {
+    if (is.null(x)) x else parseJSON(x)
+  }
+  
+  parsedInputValue <- function() {
+    parseJSONVal(session$rootScope()$input[[eventID]])
+  }
+  
+  priority <- match.arg(priority)
+  if (priority == "event") {
+    # Shiny.setInputValue() is always called with event priority
+    # so simply return the parse input value
+    return(parsedInputValue())
+    
+  } else {
+    
+    eventHasStorage <- eventID %in% names(session$userData$plotlyInputStore)
+    
+    if (!eventHasStorage) {
+      # store input value as a reactive value to leverage caching
+      session$userData$plotlyInputStore <- session$userData$plotlyInputStore %||% shiny::reactiveValues()
+      session$userData$plotlyInputStore[[eventID]] <- shiny::isolate(parsedInputValue())
+      shiny::observe({
+        session$userData$plotlyInputStore[[eventID]] <- parsedInputValue()
+      }, priority = 10000, domain = session)
+    } 
+    
+    session$userData$plotlyInputStore[[eventID]]
+  }
+  
+}
+
+
+#' Register a shiny input value 
+#' 
+#' @inheritParams event_data
+#' @seealso [event_data]
+#' @export
+#' @author Carson Sievert
+event_register <- function(p, event = NULL) {
+  event <- match.arg(event, event_data_events())
+  shiny_event_add(p, event)
+}
+
+#' Un-register a shiny input value
+#' 
+#' @inheritParams event_data
+#' @seealso [event_data]
+#' @export
+#' @author Carson Sievert
+event_unregister <- function(p, event = NULL) {
+  event <- match.arg(event, event_data_events())
+  shiny_event_remove(p, event) 
+}
+
+
+# helpers
+shiny_event_add <- function(p, event) {
+  p <- shiny_defaults_set(p)
+  p$x$shinyEvents <- unique(c(p$x$shinyEvents, event))
+  p
+}
+
+shiny_event_remove <- function(p, event) {
+  p <- shiny_defaults_set(p)
+  p$x$shinyEvents <- setdiff(p$x$shinyEvents, event)
+  p
+}
+
+shiny_defaults_set <- function(p) {
+  p$x$shinyEvents <- p$x$shinyEvents %||% shiny_event_defaults()
+  p
+}
+
+shiny_event_defaults <- function() {
+  c(
+    "plotly_hover", 
+    "plotly_click", 
+    "plotly_selected", 
+    "plotly_relayout", 
+    "plotly_brushed",
+    "plotly_brushing",
+    "plotly_clickannotation",
+    "plotly_doubleclick", 
+    "plotly_deselect", 
+    "plotly_afterplot"
+  )
+}
+
+event_data_events <- function() {
+  eval(formals(event_data)$event)
 }

R/utils.R

@@ -949,7 +949,7 @@ grab <- function(what = "username") {
 
 # try to grab an object key from a JSON file (returns empty string on error)
 try_file <- function(f, what) {
-  tryCatch(jsonlite::fromJSON(f)[[what]], error = function(e) NULL)
+  tryCatch(jsonlite::read_json(f)[[what]], error = function(e) NULL)
 }
 
 # preferred defaults for toJSON mapping
@@ -960,14 +960,7 @@ to_JSON <- function(x, ...) {
 
 # preferred defaults for toJSON mapping
 from_JSON <- function(x, ...) {
-  jsonlite::fromJSON(x, simplifyDataFrame = FALSE, simplifyMatrix = FALSE, ...)
-}
-
-from_JSON_safe <- function(txt, ...) {
-  if (!jsonlite::validate(txt)) {
-    stop("Expected a valid JSON string.")
-  }
-  from_JSON(txt, ...)
+  jsonlite::parse_json(x, simplifyVector = TRUE, simplifyDataFrame = FALSE, simplifyMatrix = FALSE, ...)
 }
 
 i <- function(x) {

inst/examples/shiny/event_data/app.R

@@ -6,21 +6,25 @@ ui <- fluidPage(
   plotlyOutput("plot"),
   verbatimTextOutput("hover"),
   verbatimTextOutput("click"),
-  verbatimTextOutput("brush")
+  verbatimTextOutput("selected"),
+  verbatimTextOutput("selecting"),
+  verbatimTextOutput("brushed"),
+  verbatimTextOutput("brushing")
 )
 
 server <- function(input, output, session) {
 
   nms <- row.names(mtcars)
 
   output$plot <- renderPlotly({
-    if (identical(input$plotType, "ggplotly")) {
-      p <- ggplot(mtcars, aes(x = mpg, y = wt, customdata = nms)) + geom_point()
-      ggplotly(p) %>% layout(dragmode = "select")
+    p <- if (identical(input$plotType, "ggplotly")) {
+      ggplotly(ggplot(mtcars, aes(x = mpg, y = wt, customdata = nms)) + geom_point())
     } else {
-      plot_ly(mtcars, x = ~mpg, y = ~wt, customdata = nms) %>%
-        layout(dragmode = "select")
+      plot_ly(mtcars, x = ~mpg, y = ~wt, customdata = nms)
     }
+    p %>% 
+      layout(dragmode = "select") %>%
+      event_register("plotly_selecting")
   })
 
   output$hover <- renderPrint({
@@ -33,11 +37,26 @@ server <- function(input, output, session) {
     if (is.null(d)) "Click events appear here (double-click to clear)" else d
   })
 
-  output$brush <- renderPrint({
+  output$selected <- renderPrint({
     d <- event_data("plotly_selected")
     if (is.null(d)) "Click and drag events (i.e., select/lasso) appear here (double-click to clear)" else d
   })
 
+  output$selecting <- renderPrint({
+    d <- event_data("plotly_selecting")
+    if (is.null(d)) "Click and drag events (i.e., select/lasso) appear here (double-click to clear)" else d
+  })
+  
+  output$brush <- renderPrint({
+    d <- event_data("plotly_brushed")
+    if (is.null(d)) "Extents of the selection brush will appear here." else d
+  })
+  
+  output$brushing <- renderPrint({
+    d <- event_data("plotly_brushing")
+    if (is.null(d)) "Extents of the selection brush will appear here." else d
+  })
+  
 }
 
 shinyApp(ui, server, options = list(display.mode = "showcase"))