Add more input events

DESCRIPTION

@@ -71,6 +71,6 @@ Suggests:
     plotlyGeoAssets,
     forcats
 LazyData: true
-RoxygenNote: 6.1.0
+RoxygenNote: 6.1.1
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)

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

@@ -56,26 +56,67 @@ prepareWidget <- function(x) {
 #' 
 #' 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 relevant shiny input. 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
+#' @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)
+
+  # make sure the input event is sensible
+  event <- match.arg(event)
+  priority <- match.arg(priority)
+
+  isNullEvent <- event %in% c("plotly_doubleclick", "plotly_deselect", "plotly_afterplot")
+  if (isNullEvent && priority != "event") {
+    message(
+      "The input value tied to a '", event, "' event never changes. ", 
+      "Setting `priority = 'event'` so that the event actually triggers re-execution."
+    )
+    priority <- "event"
+  }
+
+  # register event on client-side
+  session$onFlushed(function() {
+    session$sendCustomMessage(
+      type = "plotlyEventData", 
+      message = list(event = event, source = source, priority = priority)
+    )
+  }, once = FALSE)
+
+
+  src <- sprintf(".clientValue-%s-%s-%s", event, source, priority)
   val <- session$rootScope()$input[[src]]
-  if (is.null(val)) val else jsonlite::fromJSON(val)
+
+  # legend clicking returns trace(s), which shouldn't be simplified...
+  fromJSONfunc <- if (event %in% c("plotly_legendclick", "plotly_legenddoubleclick")) from_JSON else jsonlite::fromJSON
+
+  if (is.null(val)) val else fromJSONfunc(val)
 }

inst/examples/shiny/event_data/app.R

@@ -6,7 +6,10 @@ ui <- fluidPage(
   plotlyOutput("plot"),
   verbatimTextOutput("hover"),
   verbatimTextOutput("click"),
-  verbatimTextOutput("brush")
+  verbatimTextOutput("selected"),
+  verbatimTextOutput("selecting"),
+  verbatimTextOutput("brushed"),
+  verbatimTextOutput("brushing")
 )
 
 server <- function(input, output, session) {
@@ -33,11 +36,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"))

inst/examples/shiny/event_data_annotation/app.R

@@ -0,0 +1,26 @@
+library(shiny)
+
+ui <- fluidPage(
+  plotlyOutput("p"),
+  checkboxInput("edit", "Enable edit mode? Capturing annotation click events in edit mode is not possible.", FALSE),
+  verbatimTextOutput("data")
+)
+
+server <- function(input, output, session) {
+
+  output$p <- renderPlotly({
+    plot_ly(mtcars) %>% 
+      add_annotations(x = ~wt, y = ~mpg, text = row.names(mtcars), captureevents = TRUE)
+  })
+
+  observeEvent(input$edit, {
+    plotlyProxy("p", session) %>%
+      plotlyProxyInvoke("reconfig", editable = input$edit)
+  })
+
+  output$data <- renderPrint({
+    event_data("plotly_clickannotation")
+  })
+}
+
+shinyApp(ui, server)

inst/examples/shiny/event_data_legends/app.R

@@ -0,0 +1,26 @@
+library(shiny)
+
+ui <- fluidPage(
+  plotlyOutput("gg"),
+  verbatimTextOutput("click"),
+  verbatimTextOutput("doubleclick")
+)
+
+server <- function(input, output, session) {
+
+  output$gg <- renderPlotly({
+    ggplot(mtcars, aes(wt, mpg, color = factor(cyl))) +
+      geom_point() + 
+      facet_wrap(~vs)
+  })
+
+  output$click <- renderPrint({
+    event_data("plotly_legendclick")
+  })
+
+  output$doubleclick <- renderPrint({
+    event_data("plotly_legenddoubleclick")
+  })
+}
+
+shinyApp(ui, server)

inst/examples/shiny/event_data_parcoords/app.R

@@ -0,0 +1,67 @@
+library(plotly)
+library(shiny)
+
+ui <- fluidPage(
+  plotlyOutput("parcoords"),
+  tableOutput("data")
+)
+
+server <- function(input, output, session) {
+
+  iris_numeric <- dplyr::select_if(iris, is.numeric)
+
+  output$parcoords <- renderPlotly({
+    dims <- Map(function(x, y) {
+      list(values = x, range = range(x), label = y)
+    }, iris_numeric, names(iris_numeric), USE.NAMES = FALSE)
+    plot_ly(type = 'parcoords', dimensions = dims, source = "pcoords")
+  })
+
+  # maintain a collection of selection ranges
+  # since each parcoord dimension is allowed to have multiple 
+  # selected ranges, this reactive values data structure is 
+  # allowed 
+  # list(
+  #  var1 = list(c(min1, max1), c(min2, max2), ...),
+  #  var2 = list(c(min1, max1)),
+  #  ...
+  # )
+  ranges <- reactiveValues()
+  observeEvent(event_data("plotly_restyle", source = "pcoords"), {
+    d <- event_data("plotly_restyle", source = "pcoords")
+    # what is the relevant dimension (i.e. variable)?
+    dimension <- as.numeric(stringr::str_extract(names(d[[1]]), "[0-9]+"))
+    # careful of the indexing in JS (0) versus R (1)!
+    dimension_name <- names(iris_numeric)[[dimension + 1]]
+    # 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))
+    }
+  })
+
+  # 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 <- renderTable({
+    iris_selected()
+  })
+}
+
+shinyApp(ui, server)

inst/examples/shiny/event_priority/app.R

@@ -0,0 +1,29 @@
+library(plotly)
+library(shiny)
+
+ui <- fluidPage(
+  checkboxInput("priority", "Shiny event priority", FALSE),
+  plotlyOutput("p")
+)
+
+server <- function(input, output, session) {
+
+  output$p <- renderPlotly({
+    title <- if (input$priority) {
+      "Clicking on the same point repeatedly will keep triggering console output"
+    } else {
+      "Clicking on the same point won't trigger more output"
+    }
+
+    plot_ly(mtcars, x = ~wt, y = ~mpg) %>%
+      layout(title = title) %>%
+      config(priority = if (input$priority) "event")
+  })
+
+  observeEvent(event_data("plotly_click"), {
+    print("clicked!")
+  })
+
+}
+
+shinyApp(ui, server)