This is a working example showing how we can perform linked highlighting between plotly and leaflet (see a video of it in action). Plotly itself has extensive support for linked highlighting where interaction types, colors, and persistent/transient selection can be specified via the highlight()
function. See a growing set of examples here
DISCLAIMER: This is very experimental, and requires development versions of several packages. Press the "code" buttons to see how to install and create this example.
knitr::opts_chunk$set(message = FALSE, warning = FALSE)
# A standalone HTML version of launchApp() # devtools::install_github("rstudio/leaflet@56eb3ecbb25ddc195c1cc6f530246dbb565f99ee") library(leaflet) # devtools::install_github("ropensci/plotly@dce5a288b2b7daddf3884b4f57dbfa4e02b9fab8") library(plotly) library(crosstalk) library(htmltools) library(dplyr) library(tidyr) data(pedestrians, package = "pedestrians") data(sensors, package = "pedestrians") data(cog, package = "pedestrians") # put all the cognostics on a 0-1 scale cogVars <- setdiff(names(cog), "ID") for (i in cogVars) { cog[[i]] <- scales::rescale(cog[[i]]) } # attach the sensor description cog <- dplyr::left_join(cog, sensors[c("ID", "Description")], "ID") # random sample (needed for performance/speed) n <- nrow(pedestrians) pedSample <- pedestrians[sample(n, n * 0.01), ] # Use the ID field as the shared key pedestrians <- SharedData$new(pedestrians, key = ~ID, group = "melb") pedSample <- SharedData$new(pedSample, key = ~ID, group = "melb") sensors <- SharedData$new(sensors, key = ~ID, group = "melb") cog <- SharedData$new(cog, key = ~ID, group = "melb") # let leaflet know that selections should persist options(persistent = TRUE) # plot 1 p1 <- sensors %>% leaflet(height = 200) %>% addTiles() %>% fitBounds( ~min(Longitude), ~min(Latitude), ~max(Longitude), ~max(Latitude) ) %>% addCircleMarkers( ~Longitude, ~Latitude, layerId = ~ID, label = ~Description, color = "black" ) # plot 2 p <- cog %>% plot_ly(height = 200) %>% gather_("variable", "value", cogVars) %>% ggplot(aes(variable, value, group = ID, text = Description)) + geom_line() + geom_point(size = 0.01) + theme(axis.text.x = element_text(angle = 45)) + labs(x = NULL, y = NULL) p2 <- p %>% ggplotly(tooltip = "Description", height = 200) %>% layout(dragmode = "select", margin = list(b = 70)) %>% highlight(dynamic = TRUE, persistent = TRUE) # plot 3 p3 <- pedSample %>% plot_ly(x = ~Hour, y = ~Counts, color = I("black"), alpha = 0.01, height = 200) %>% toWebGL() %>% highlight(opacityDim = 1, persistent = TRUE) # plot 4 (IQR ribbons) tidyIQR <- function(data, groups = NULL) { if (is.SharedData(data)) data <- data$origData() for (i in groups) { data <- group_by_(data, i, add = TRUE) } summarise( data, min = min(Counts), q1 = quantile(Counts, 0.25), med = median(Counts), q3 = quantile(Counts, 0.75), max = max(Counts) ) } byHour <- tidyIQR(pedestrians, "Hour") byHourID <- tidyIQR(pedestrians, c("Hour", "ID")) byHourID <- SharedData$new(byHourID, ~ID, "melb") p4 <- plot_ly(byHour, x = ~Hour, color = I("black"), height = 200) %>% add_ribbons(ymin = ~q1, ymax = ~q3) %>% add_lines(y = ~med) %>% add_data(byHourID) %>% group_by(ID) %>% add_ribbons(ymin = ~q1, ymax = ~q3, color = I("red")) %>% add_lines(y = ~med, color = I("red")) %>% highlight(defaultValues = 1, opacityDim = 0, persistent = TRUE) %>% hide_legend() browsable(tags$div( style = "display: flex; flex-wrap: wrap", tagList( tags$div(p1, style = "width: 50%; padding: 1em; border: solid;"), tags$div(p2, style = "width: 50%; padding: 1em; border: solid;"), tags$div(p3, style = "width: 50%; padding: 1em; border: solid;"), tags$div(p4, style = "width: 50%; padding: 1em; border: solid;") ) ))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.