Track plot events in user's session data to throw informative errors

Also introduces new R functions to explictly register/un-register events

Author: cpsievert

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_)

R/layout.R

@@ -101,8 +101,6 @@ rangeslider <- function(p, start = NULL, end = NULL, ...) {
 #' (see [here](https://github.com/ropensci/plotly/blob/master/inst/examples/rmd/MathJax/index.Rmd) 
 #' for an **rmarkdown** example and 
 #' [here](https://github.com/ropensci/plotly/blob/master/inst/examples/rmd/MathJax/index.Rmd) for a **shiny** example).
-#' @param shinyInputs plotly.js events to register as shiny input values
-#' @param shinyEvents plotly.js events to register as shiny input values with event priority
 #' @author Carson Sievert
 #' @export
 #' @examples
@@ -133,9 +131,7 @@ rangeslider <- function(p, start = NULL, end = NULL, ...) {
 #' config(p, locale = "zh-CN")
 #' 
 
-config <- function(p, ..., collaborate = TRUE, cloud = FALSE, locale = NULL, mathjax = NULL, 
-                   shinyInputs = c("plotly_hover", "plotly_click", "plotly_selected", "plotly_relayout"),
-                   shinyEvents = c("plotly_doubleclick", "plotly_deselect", "plotly_afterplot")) {
+config <- function(p, ..., collaborate = TRUE, cloud = FALSE, locale = NULL, mathjax = NULL) {
 
   if (!is.null(locale)) {
     p$dependencies <- c(
@@ -174,8 +170,6 @@ config <- function(p, ..., collaborate = TRUE, cloud = FALSE, locale = NULL, mat
   }
 
   p$x$config$cloud <- cloud
-  p$x$config$shinyInputs <- I(validate_event_names(shinyInputs))
-  p$x$config$shinyEvents <- I(validate_event_names(shinyEvents))
 
   p
 }
@@ -192,12 +186,3 @@ validate_event_names <- function(events) {
     call. = FALSE
   )
 }
-
-shiny_input_events <- function() {
-  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"
-  )
-}

R/plotly_build.R

@@ -366,6 +366,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/shiny.R

@@ -55,11 +55,27 @@ 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 = "-")
+  inputIDs <- paste(p$x$shinyInputs, p$x$source, sep = "-")
+  session$userData$plotlyShinyEventIDs <- unique(c(
+    session$userData$plotlyShinyEventIDs,
+    eventIDs
+  ))
+  session$userData$plotlyShinyInputIDs <- unique(c(
+    session$userData$plotlyShinyInputIDs,
+    inputIDs
+  ))
 }
 
 
@@ -74,6 +90,7 @@ prepareWidget <- function(x) {
 #' events emitted from that specific plot.
 #' @param session a shiny session object (the default should almost always be used).
 #' @export
+#' @seealso [event_register], [event_unregister]
 #' @references 
 #'   * <https://plotly-book.cpsievert.me/shiny-plotly-inputs.html> 
 #'   * <https://plot.ly/javascript/plotlyjs-function-reference/>
@@ -90,20 +107,118 @@ event_data <- function(
     "plotly_legenddoubleclick", "plotly_clickannotation", "plotly_afterplot"
   ), 
   source = "A",
-  session = shiny::getDefaultReactiveDomain()
+  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.")
   }
 
-  # make sure the input event is sensible
   event <- match.arg(event)
-  src <- sprintf(".clientValue-%s-%s", event, source)
-  val <- session$rootScope()$input[[src]]
+  # TODO: resolve priority
+  priority <- match.arg(priority)
+  # check to see if this event-source-priority combo is registered
+  eventID <- paste(event, source, sep = "-")
+  keyName <- if (priority == "event") "plotlyShinyEventIDs" else "plotlyShinyInputIDs"
+  if (!eventID %in% session$userData[[keyName]]) {
+    stop(
+      "The '", event, "' event has not been registered for a source ID ",
+      "of '", source, "' with priority '", priority, "'. ", 
+      "Please add `event_register(p, '", event, "', '", priority, "')` to your plot `p`."
+    )
+  }
+  
+  inputName <- sprintf(".clientValue-%s-%s", event, source)
+  val <- session$rootScope()$input[[inputName]]
 
   # legend clicking returns trace(s), which shouldn't be simplified...
-  fromJSONfunc <- if (event %in% c("plotly_legendclick", "plotly_legenddoubleclick")) from_JSON else jsonlite::parse_json
+  parseJSON <- if (event %in% c("plotly_legendclick", "plotly_legenddoubleclick")) {
+    from_JSON
+  } else {
+    function(x) jsonlite::parse_json(x, simplifyVector = TRUE)
+  }
 
-  if (is.null(val)) val else fromJSONfunc(val)
+  if (is.null(val)) val else parseJSON(val)
+}
+
+
+#' Register a shiny input value 
+#' 
+#' @inheritParams event_data
+#' @seealso [event_data]
+#' @export
+#' @author Carson Sievert
+event_register <- function(p, event = NULL, priority = c("input", "event")) {
+  priority <- match.arg(priority)
+  event <- match.arg(event, event_data_events())
+  if (priority == "event") shiny_event_add(p, event) else shiny_input_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, priority = c("input", "event")) {
+  priority <- match.arg(priority)
+  event <- match.arg(event, event_data_events())
+  if (priority == "event") shiny_event_remove(p, event) else shiny_input_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_input_add <- function(p, event) {
+  p <- shiny_defaults_set(p)
+  p$x$shinyInputs <- unique(c(p$x$shinyInputs, event))
+  p
+}
+
+shiny_event_remove <- function(p, event) {
+  p <- shiny_defaults_set(p)
+  p$x$shinyEvents <- setdiff(p$x$shinyEvents, event)
+  p
+}
+
+shiny_input_remove <- function(p, event) {
+  p <- shiny_defaults_set(p)
+  p$x$shinyInputs <- setdiff(p$x$shinyInputs, event)
+  p
+}
+
+shiny_defaults_set <- function(p) {
+  p$x$shinyEvents <- p$x$shinyEvents %||% shiny_event_defaults()
+  p$x$shinyInputs <- p$x$shinyInputs %||% shiny_input_defaults()
+  p
+}
+
+shiny_input_defaults <- function() {
+  c(
+    "plotly_hover", 
+    "plotly_click", 
+    "plotly_selected", 
+    "plotly_relayout", 
+    "plotly_brushed",
+    "plotly_brushing",
+    "plotly_clickannotation"
+  )
+}
+
+shiny_event_defaults <- function() {
+  c(
+    "plotly_doubleclick", 
+    "plotly_deselect", 
+    "plotly_afterplot"
+  )
+}
+
+event_data_events <- function() {
+  eval(formals(event_data)$event)
 }

R/utils.R

@@ -959,7 +959,7 @@ to_JSON <- function(x, ...) {
 
 # preferred defaults for toJSON mapping
 from_JSON <- function(x, ...) {
-  jsonlite::parse_json(x, simplifyDataFrame = FALSE, simplifyMatrix = FALSE, ...)
+  jsonlite::parse_json(x, simplifyVector = TRUE, simplifyDataFrame = FALSE, simplifyMatrix = FALSE, ...)
 }
 
 i <- function(x) {

inst/examples/shiny/event_data/app.R

@@ -25,18 +25,8 @@ server <- function(input, output, session) {
       plot_ly(mtcars, x = ~mpg, y = ~wt, key = nms) 
     }
     p %>% 
-      layout(dragmode = "select") %>% 
-      config(
-        shinyInputs = c(
-          "plotly_hover", 
-          "plotly_hover", 
-          "plotly_click",
-          "plotly_selected",
-          "plotly_selecting",
-          "plotly_brushed",
-          "plotly_brushing"
-        ) 
-      )
+      layout(dragmode = "select") %>%
+      event_register("plotly_selecting")
   })
 
   output$hover <- renderPrint({

inst/examples/shiny/event_data_annotation/app.R

@@ -10,8 +10,7 @@ server <- function(input, output, session) {
 
   output$p <- renderPlotly({
     plot_ly(mtcars) %>% 
-      add_annotations(x = ~wt, y = ~mpg, text = row.names(mtcars), captureevents = TRUE) %>%
-      config(shinyInputs = "plotly_clickannotation")
+      add_annotations(x = ~wt, y = ~mpg, text = row.names(mtcars), captureevents = TRUE)
   })
 
   observeEvent(input$edit, {

inst/examples/shiny/event_data_legends/app.R

@@ -9,9 +9,12 @@ ui <- fluidPage(
 server <- function(input, output, session) {
 
   output$gg <- renderPlotly({
-    ggplot(mtcars, aes(wt, mpg, color = factor(cyl))) +
+    p <- ggplot(mtcars, aes(wt, mpg, color = factor(cyl))) +
       geom_point() + 
       facet_wrap(~vs)
+    ggplotly(p) %>%
+      event_register("plotly_legendclick") %>%
+      event_register("plotly_legenddoubleclick")
   })
 
   output$click <- renderPrint({

inst/examples/shiny/event_data_parcoords/app.R

@@ -15,7 +15,8 @@ server <- function(input, output, session) {
       list(values = x, range = range(x), label = y)
     }, iris_numeric, names(iris_numeric), USE.NAMES = FALSE)
     plot_ly(type = 'parcoords', dimensions = dims, source = "pcoords") %>% 
-      layout(margin = list(r = 30))
+      layout(margin = list(r = 30)) %>%
+      config(shinyInputs = "plotly_restyle")
   })
 
   # maintain a collection of selection ranges
@@ -39,32 +40,37 @@ server <- function(input, output, session) {
     # a given dimension can have multiple selected ranges
     # these will come in as 3D arrays, but a list of vectors 
     # is nicer to work with
-    info <- d[[1]][[1]]
-    ranges[[dimension_name]] <- if (length(dim(info)) == 3) {
-      lapply(seq_len(dim(info)[2]), function(i) info[,i,])
-    } else {
-      list(as.numeric(info))
-    }
+    browser()
+    ranges[[dimension_name]] <- d[[1]][[1]]
+    
+    #print(info)
+    #browser()
+    #ranges[[dimension_name]] <- if (length(dim(info)) == 3) {
+    #  lapply(seq_len(dim(info)[2]), function(i) info[,i,])
+    #} else {
+    #  list(as.numeric(info))
+    #}
   })
 
-  # filter the dataset down to the rows that match the selection ranges
-  iris_selected <- reactive({
-    keep <- TRUE
-    for (i in names(ranges)) {
-      range_ <- ranges[[i]]
-      keep_var <- FALSE
-      for (j in seq_along(range_)) {
-        rng <- range_[[j]]
-        keep_var <- keep_var | dplyr::between(iris[[i]], min(rng), max(rng))
-      }
-      keep <- keep & keep_var
-    }
-    iris[keep, ]
-  })
-  
-  output$data <- renderPrint({
-    tibble::as_tibble(iris_selected())
-  })
+  ## filter the dataset down to the rows that match the selection ranges
+  #iris_selected <- reactive({
+  #  keep <- TRUE
+  #  print(ranges)
+  #  for (i in names(ranges)) {
+  #    range_ <- ranges[[i]]
+  #    keep_var <- FALSE
+  #    for (j in seq_along(range_)) {
+  #      rng <- range_[[j]]
+  #      keep_var <- keep_var | dplyr::between(iris[[i]], min(rng), max(rng))
+  #    }
+  #    keep <- keep & keep_var
+  #  }
+  #  iris[keep, ]
+  #})
+  #
+  #output$data <- renderPrint({
+  #  tibble::as_tibble(iris_selected())
+  #})
 }
 
 shinyApp(ui, server)

inst/examples/shiny/proxy_relayout/app.R

@@ -17,6 +17,8 @@ server <- function(input, output, session) {
 
   observeEvent(event_data("plotly_relayout"), {
     d <- event_data("plotly_relayout")
+    # unfortunately, the data structure emitted is different depending on 
+    # whether the relayout is triggered from the rangeslider or the plot
     xmin <- if (length(d[["xaxis.range[0]"]])) d[["xaxis.range[0]"]] else d[["xaxis.range"]][1]
     xmax <- if (length(d[["xaxis.range[1]"]])) d[["xaxis.range[1]"]] else d[["xaxis.range"]][2]
     if (is.null(xmin) || is.null(xmax)) return(NULL)

inst/htmlwidgets/plotly.js

@@ -352,11 +352,11 @@ HTMLWidgets.widget({
         });
       }
 
-      var shinyInputs = x.config.shinyInputs || [];
+      var shinyInputs = x.shinyInputs || [];
       shinyInputs.map(function(input) { 
         return registerShinyValue(input, false); 
       });
-      var shinyEvents = x.config.shinyEvents || [];
+      var shinyEvents = x.shinyEvents || [];
       shinyEvents.map(function(event) { 
         return registerShinyValue(event, true); 
       });