Merge pull request #416 from ropensci/feature/transmit

Send 'plotly_click' and 'plotly_selected' events to shiny when in shinyMode

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: plotly
 Title: Create Interactive Web Graphics via Plotly's JavaScript Graphing Library
-Version: 2.4.4
+Version: 2.5.0
 Authors@R: c(person("Carson", "Sievert", role = c("aut", "cre"),
     email = "[email protected]"),
     person("Chris", "Parmer", role = c("aut", "cph"),

NAMESPACE

@@ -7,6 +7,7 @@ export(add_trace)
 export(as.widget)
 export(config)
 export(embed_notebook)
+export(event_data)
 export(get_figure)
 export(gg2list)
 export(ggplot_build2)

NEWS

@@ -1,3 +1,19 @@
+2.5.0 -- 1 Mar 2015
+
+NEW FEATURES
+
+* New event_data() function provides easy access to plotly events in shiny.
+For an example, see https://github.com/ropensci/plotly/tree/master/inst/examples/plotlyEvents
+
+* plot_ly() and ggplotly() gain a source argument to differentiate between 
+plotly events in shiny apps with multiple plots. ggplotly() also gains width 
+and height arguments.
+
+CHANGES
+
+The arguments filename, fileopt, world_readable in ggplotly() were removed as
+they should be provided to plotly_POST() instead. 
+
 2.4.4 -- 13 Feb 2015
 
 as.widget() now returns htmlwidget objects untouched. See #449.

R/ggplotly.R

@@ -4,15 +4,9 @@
 #' \url{https://plot.ly/ggplot2}
 #'
 #' @param p a ggplot object.
-#' @param filename character string describing the name of the plot in your plotly account. 
-#' Use / to specify directories. If a directory path does not exist it will be created.
-#' If this argument is not specified and the title of the plot exists,
-#' that will be used for the filename.
-#' @param fileopt character string describing whether to create a "new" plotly, "overwrite" an existing plotly, 
-#' "append" data to existing plotly, or "extend" it.
-#' @param world_readable logical. If \code{TRUE}, the graph is viewable 
-#' by anyone who has the link and in the owner's plotly account.
-#' If \code{FALSE}, graph is only viewable in the owner's plotly account.
+#' @param width Width of the plot in pixels (optional, defaults to automatic sizing).
+#' @param height Height of the plot in pixels (optional, defaults to automatic sizing).
+#' @param source Only relevant for \link{event_data}.
 #' @seealso \link{signup}, \link{plot_ly}
 #' @import httr jsonlite
 #' @export
@@ -32,13 +26,9 @@
 #'  ggplotly(viz)
 #' }
 #' 
-ggplotly <- function(p = ggplot2::last_plot(), filename, fileopt, 
-                     world_readable = TRUE) {
-  l <- gg2list(p)
-  # tack on special keyword arguments
-  if (!missing(filename)) l$filename <- filename
-  if (!missing(fileopt)) l$fileopt <- fileopt
-  l$world_readable <- world_readable
+ggplotly <- function(p = ggplot2::last_plot(), width = NULL, height = NULL,
+                     source = "A") {
+  l <- gg2list(p, width = width, height = height, source = source)
   hash_plot(p$data, l)
 }
 
@@ -116,9 +106,12 @@ guide_names <- function(p, aes = c("shape", "fill", "alpha", "area",
 #' Convert a ggplot to a list.
 #' @import ggplot2
 #' @param p ggplot2 plot.
+#' @param width Width of the plot in pixels (optional, defaults to automatic sizing).
+#' @param height Height of the plot in pixels (optional, defaults to automatic sizing).
+#' @param source Only relevant for \link{event_data}.
 #' @return figure object (list with names "data" and "layout").
 #' @export
-gg2list <- function(p) {
+gg2list <- function(p, width = NULL, height = NULL, source = "A") {
   # ggplot now applies geom_blank() (instead of erroring) when no layers exist
   if (length(p$layers) == 0) p <- p + geom_blank()
   layout <- list()
@@ -960,6 +953,8 @@ gg2list <- function(p) {
   }
 
   l <- list(data = flipped.traces, layout = flipped.layout)
-
+  l$width <- width
+  l$height <- width
+  l$source <- source
   structure(add_boxed(rm_asis(l)), class = "plotly")
 }

R/plotly.R

@@ -23,6 +23,7 @@
 #' @param height Height in pixels (optional, defaults to automatic sizing).
 #' @param inherit logical. Should future traces inherit properties from this initial trace?
 #' @param evaluate logical. Evaluate arguments when this function is called?
+#' @param source Only relevant for \link{event_data}.
 #' @seealso \code{\link{layout}()}, \code{\link{add_trace}()}, \code{\link{style}()}
 #' @author Carson Sievert
 #' @export
@@ -66,7 +67,7 @@
 plot_ly <- function(data = data.frame(), ..., type = "scatter",
                     group, color, colors, symbol, symbols, size,
                     width = NULL, height = NULL, inherit = FALSE, 
-                    evaluate = FALSE) {
+                    evaluate = FALSE, source = "A") {
   # "native" plotly arguments
   argz <- substitute(list(...))
   # old arguments to this function that are no longer supported
@@ -97,7 +98,8 @@ plot_ly <- function(data = data.frame(), ..., type = "scatter",
     layout = NULL,
     url = NULL,
     width = width,
-    height = height
+    height = height,
+    source = source
   )
 
   if (evaluate) p <- plotly_build(p)

R/shiny.R

@@ -29,3 +29,33 @@ renderPlotly <- function(expr, env = parent.frame(), quoted = FALSE) {
   expr <- call("as.widget", expr)
   shinyRenderWidget(expr, plotlyOutput, env, quoted = TRUE)
 }
+
+
+#' 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', and 'plotly_selected' are supported.
+#' @param source Which plot should the listener be tied to? This 
+#' (character string) should match the value of \code{source} in \link{plot_ly}.
+#' @export
+#' @author Carson Sievert
+#' @examples \dontrun{
+#' shiny::runApp(system.file("examples", "events", package = "plotly"))
+#' }
+
+event_data <- function(event = c("plotly_hover", "plotly_click", "plotly_selected"), 
+                       source = "A") {
+  session <- shiny::getDefaultReactiveDomain()
+  if (is.null(session)) {
+    stop("No reactive domain detected. This function can only be called \n",
+         "from within a reactive shiny context.")
+  }
+  val <- session$input[[sprintf(".clientValue-%s-%s", event[1], source)]]
+  if (event[1] == "plotly_selected" && !is.null(val)) {
+    data.frame(lapply(val, as.numeric))
+  } else  {
+    val
+  }
+}

inst/examples/lmGadget/app.R

@@ -0,0 +1,86 @@
+# Many thanks to RStudio for shiny gadgets
+# And special thanks to Winston Chang for the inspiration
+# https://gist.github.com/wch/c4b857d73493e6550cba
+library(shiny)
+library(miniUI)
+library(plotly)
+
+#' Shiny gadget for interactive linear model fitting
+#' 
+#' Click on points to add/remove them from consideration
+#' 
+#' @param dat a data.frame
+#' @param x a character string specifying the x variable
+#' @param y a character string specifying the y variable
+
+lmGadget <- function(dat, x, y) {
+
+  ui <- miniPage(
+    gadgetTitleBar("Interactive lm"),
+    miniContentPanel(
+      fillRow(
+        flex = c(NA, 1),
+        fillCol(
+          width = "100px",
+          selectInput("degree", "Polynomial degree", c(1, 2, 3, 4))
+        ),
+        plotlyOutput("plot1", height = "100%")
+      )
+    )
+  )
+
+  # mechanism for managing selected points
+  init <- function() {
+    selected <- rep(FALSE, nrow(dat))
+    function(x) {
+      selected <<- xor(selected, x)
+      selected
+    }
+  }
+  selection <- init()
+
+  server <- function(input, output) {
+
+    # obtain a subset of the data that is still under consideration
+    left <- reactive({
+      d <- event_data("plotly_click")
+      if (!is.null(d)) {
+        dat <- dat[!selection(row.names(dat) %in% d[["key"]]), ]
+      }
+      dat
+    })
+
+    # fit a model to subsetted data
+    refit <- reactive({
+      req(input$degree)
+      formula <- as.formula(
+        sprintf("%s ~ poly(%s, degree = %s)", y, x, input$degree)
+      )
+      lm(formula, left())
+    })
+
+    output$plot1 <- renderPlotly({
+      dat2 <- left()
+      dat2$yhat <- as.numeric(fitted(refit()))
+      # sort data by 'x' variable so we draw a line (not a path)
+      dat2 <- dat2[order(dat2[, x]), ]
+
+      plot_ly(x = dat[, x], y = dat[, y], key = row.names(dat), mode = "markers",
+              marker = list(color = toRGB("grey90"), size = 10)) %>%
+        add_trace(x = dat2[, x], y = dat2[, y], mode = "markers",
+                  marker = list(color = toRGB("black"), size = 10)) %>%
+        add_trace(x = dat2[, x], y = dat2$yhat, mode = "lines",
+                  marker = list(color = toRGB("black"))) %>%
+        layout(showlegend = FALSE, xaxis = list(title = x), yaxis = list(title = y))
+    })
+
+    # Return the most recent fitted model, when we press "done"
+    observeEvent(input$done, {
+      stopApp(refit())
+    })
+  }
+
+  runGadget(ui, server)
+}
+
+m <- lmGadget(mtcars, "wt", "mpg")

inst/examples/map_click/app.R

@@ -0,0 +1,33 @@
+# git checkout feature/transmit
+# R CMD install ./
+
+library(shiny)
+library(plotly)
+
+ui <- fluidPage(
+  plotlyOutput("plot"),
+  verbatimTextOutput("click")
+)
+
+server <- function(input, output, session) {
+
+  output$plot <- renderPlotly({
+    # specify some map projection/options
+    g <- list(
+      scope = 'usa',
+      projection = list(type = 'albers usa'),
+      lakecolor = toRGB('white')
+    )
+    plot_ly(z = state.area, text = state.name, locations = state.abb,
+            type = 'choropleth', locationmode = 'USA-states') %>%
+      layout(geo = g)
+  })
+
+  output$click <- renderPrint({
+    d <- event_data("plotly_click")
+    if (is.null(d)) "Click on a state to view event data" else d
+  })
+
+}
+
+shinyApp(ui, server)

inst/examples/plotlyEvents/DESCRIPTION

@@ -0,0 +1,8 @@
+Title: Passing plotly selections to shiny via crosstalk
+Author: Plotly, Inc.
+AuthorUrl: https://plot.ly/r/
+License: MIT
+DisplayMode: Showcase
+Tags: plotly, crosstalk, shiny
+Type: Shiny
+

inst/examples/plotlyEvents/app.R

@@ -0,0 +1,41 @@
+library(shiny)
+library(plotly)
+
+ui <- fluidPage(
+  radioButtons("plotType", "Plot Type:", choices = c("ggplotly", "plotly")),
+  plotlyOutput("plot"),
+  verbatimTextOutput("hover"),
+  verbatimTextOutput("click"),
+  verbatimTextOutput("brush")
+)
+
+server <- function(input, output, session) {
+
+  output$plot <- renderPlotly({
+    if (identical(input$plotType, "ggplotly")) {
+      p <- ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point()
+      ggplotly(p) %>% layout(dragmode = "select")
+    } else {
+      plot_ly(mtcars, x = mpg, y = wt, mode = "markers") %>%
+        layout(dragmode = "select")
+    }
+  })
+
+  output$hover <- renderPrint({
+    d <- event_data("plotly_hover")
+    if (is.null(d)) "Hover events appear here (unhover to clear)" else d
+  })
+
+  output$click <- renderPrint({
+    d <- event_data("plotly_click")
+    if (is.null(d)) "Click events appear here (double-click to clear)" else d
+  })
+
+  output$brush <- 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
+  })
+
+}
+
+shinyApp(ui, server, options = list(display.mode = "showcase"))