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 = "cpsievert1@gmail.com"),
  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"))

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 = "cpsievert1@gmail.com"),
  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"))

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 = "cpsievert1@gmail.com"),
  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"))

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 = "cpsievert1@gmail.com"),
  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"))

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 = "cpsievert1@gmail.com"),
  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"))

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 = "cpsievert1@gmail.com"),
  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"))

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 = "cpsievert1@gmail.com"),
  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"))

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 = "cpsievert1@gmail.com"),
  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"))