Related
I am interested in using leaflet-groupedlayercontrol within an Leaflet map created in R and have been following this gist. I can successfully add the JS plugin (as in this working example below), but my question is how do I refer to marker groups already created in R?
library(leaflet)
library(htmltools)
library(htmlwidgets)
library(dplyr)
#Download the JS and CSS
urlf <- 'https://raw.githubusercontent.com/ismyrnow/leaflet-groupedlayercontrol/gh-pages/dist/%s'
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.js'), 'C:/Temp/L.Control.groupedlayer.js', mode="wb")
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.css'), 'C:/Temp/L.Control.groupedlayer.css', mode="wb")
#Add the dependency
ctrlGrouped <- htmltools::htmlDependency(
name = 'ctrlGrouped',
version = "1.0.0",
src = c(file = normalizePath('C:/Temp')),
script = "L.Control.groupedlayer.js",
stylesheet = "L.Control.groupedlayer.css"
)
registerPlugin <- function(map, plugin) {
map$dependencies <- c(map$dependencies, list(plugin))
map
}
#create a basic map
map <- leaflet() %>%
setView(-122.38, 47.56, zoom = 12)
#add the plugin and then tell it to do stuff within onRender()
map <- map %>% registerPlugin(ctrlGrouped) %>%
#I can create some points within onRender() but I want to refer to existing R objects if possible.
onRender("function(el, x) {
var basemaps = {
Grayscale: L.tileLayer('http://{s}.tiles.wmflabs.org/bw-mapnik/{z}/{x}/{y}.png', {
maxZoom: 18,
attribution: '© <a href=http://www.openstreetmap.org/copyright>OpenStreetMap</a>'
})
};
basemaps.Grayscale.addTo(this); // default base layer
var groups = {
highschool: new L.LayerGroup(),
elementary: new L.LayerGroup()
};
L.marker([47.577541, -122.3843482]).bindPopup('West Seattle HS').addTo(groups.highschool);
L.marker([47.5661429, -122.3840636]).bindPopup('Seattle Lutheran HS').addTo(groups.highschool);
L.marker([47.581081, -122.3871535]).bindPopup('Lafayette ES').addTo(groups.elementary);
L.marker([47.566556, -122.3964651]).bindPopup('Genesee Hill ES').addTo(groups.elementary);
// Overlay layers are grouped
var groupedOverlays = {
'all schools': {
'High School locations': groups.highschool,
'Elementary locations': groups.elementary
}
};
var options = {
groupCheckboxes: true
};
L.control.groupedLayers(null, groupedOverlays, options).addTo(this);
}")
map
Instead of making the all the markers within onRender(), I was hoping to refer existing R objects, use addLegend(), control what is visible initially, etc. If didn't want the grouped layer control so badly, the code would looks something more like this:
map <- leaflet() %>%
addCircles(lng =highschool$Longitude,lat=highschool$Latitude,weight = 1, radius = highschool$units*2 , color = ~pal(a_palette), popup = popup_hs, group="highschool" )%>%
addCircles(lng =elementary$Longitude,lat=elementary$Latitude,weight = 1, radius = misc$units*2 , color = ~pal(a_palette), popup = popup_el, group="elementary" )%>%
addLegend("bottomleft", colors = palette_color_RSEI ,group = "highschool",labels = c("Lowest ","","","Highest"),
title = "Highschool size", opacity = 1) %>%
addLegend("bottomleft", colors = a_palette ,group = "elementary",labels = c("Lower % of population", "", "","","","Higher % of population"),
title = "Elementary size", opacity = .5) %>%
addLayersControl(overlayGroups = c("highschool", "elementary"))%>%
hideGroup(c( "highschool"))
Any guidance would be greatly appreciated.
It also looks like you can reference R objects within htmlwidgets::onRender() within javascript for loop. Key for me was realizing that R objects have dot notation within onRender(). So for example, an R vector df$longitude is a JSON object as data.longitude within onRender().
Here is a example from my question, where I add 4 markers from an R object to a leaflet map within onRender()and then use leaflet add-on leaflet-groupedlayercontrol. My real world map had many more groups, so this may not be the most tidy approach.
library(leaflet)
library(dplyr)
library(htmlwidgets)
df<-tibble::tibble(lat= c(47.577541, 47.5661429,47.581081,47.566556),
lng = c(-122.3843482,-122.3840636,-122.3871535,-122.3964651),
name= c("West Seattle HS","Seattle Lutheran HS","Lafayette ES","Genesee Hill ES"),
grouping=c("groups.highschool","groups.highschool","groups.elementary","groups.elementary"))
urlf <- 'https://raw.githubusercontent.com/ismyrnow/leaflet-groupedlayercontrol/gh-pages/dist/%s'
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.js'), 'C:/Temp/L.Control.groupedlayer.js', mode="wb")
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.css'), 'C:/Temp/L.Control.groupedlayer.css', mode="wb")
ctrlGrouped <- htmltools::htmlDependency(
name = 'ctrlGrouped',
version = "1.0.0",
# works in R and Shiny - download js/css files, then use this:
src = c(file = normalizePath('C:/Temp')),
script = "L.Control.groupedlayer.js",
stylesheet = "L.Control.groupedlayer.css"
)
registerPlugin <- function(map, plugin) {
map$dependencies <- c(map$dependencies, list(plugin))
map
}
leaflet() %>% addTiles() %>%
registerPlugin(ctrlGrouped) %>%
fitBounds(min(df$lng), min(df$lat), max(df$lng), max(df$lat)) %>%
onRender("
function(el, x, data) {
var groups = {
highschool: new L.LayerGroup(),
elementary: new L.LayerGroup()
};
for (var i = 0; i < data.lng.length; i++) {
var label = JSON.stringify(data.name[i])
var mygroup = data.grouping[i]
var marker = L.marker([data.lat[i], data.lng[i]]).bindPopup(label).addTo(eval(mygroup));
}
var groupedOverlays = {
'all schools': {
'High School locations': groups.highschool,
'Elementary locations': groups.elementary
}
};
var options = {
groupCheckboxes: true,
collapsed:false
};
L.control.groupedLayers(null, groupedOverlays, options).addTo(this);
}
", data = df)
It would look similar to this:
map <- leaflet() %>%
addCircles(...) %>%
addCircles(...) %>%
addLegend(...) %>%
addLegend(...) %>%
registerPlugin(ctrlGrouped) %>%
onRender("function(el, x) {
var groupedOverlays = {
'all schools': {
'High School locations': groups.highschool,
'Elementary locations': groups.elementary
}
};
var options = {
groupCheckboxes: true
};
L.control.groupedLayers(null, groupedOverlays, options).addTo(this);
}")
An example showing L.tileLayer(s), adapted from SEAnalyst answer.
library(leaflet)
library(dplyr)
library(htmlwidgets)
urlf <- 'https://raw.githubusercontent.com/ismyrnow/leaflet-
groupedlayercontrol/gh-pages/dist/%s'
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.js'),
'C:/grouped_layer_controls/L.Control.groupedlayer.js', mode="wb")
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.css'),
'C:/grouped_layer_controls/L.Control.groupedlayer.css', mode="wb")
ctrlGrouped <- htmltools::htmlDependency(
name = 'ctrlGrouped',
version = "1.0.0",
# works in R and Shiny - download js/css files, then use this:
src = c(file = normalizePath('C:/grouped_layer_controls')),
script = "L.Control.groupedlayer.js",
stylesheet = "L.Control.groupedlayer.css"
)
registerPlugin <- function(map, plugin) {
map$dependencies <- c(map$dependencies, list(plugin))
map
}
leaflet() %>%
addTiles() %>%
setView(lng = -122.3903184, lat = 47.5724059, zoom = 15) |>
leaflet::addCircles(lng = -122.3903184,
lat = 47.5724059,
radius = 20,
fillColor = 'red',
fillOpacity = 1,
group = "r") |>
leaflet::addCircles(lng = -122.390,
lat = 47.572,
radius = 20,
fillColor = 'blue',
fillOpacity = 1,
group = "b") |>
leaflet::addLayersControl(baseGroups = c("r", "b"),
options = leaflet::layersControlOptions(collapsed = FALSE)) |>
registerPlugin(ctrlGrouped) %>%
htmlwidgets::onRender(
"function(el, x, data) {
var basemaps = {
Stadia_AlidadeSmoothDark:
L.tileLayer( 'https://tiles.stadiamaps.com/tiles/alidade_smooth_dark/{z}/{x}/{y}{r}.png',
{
attribution: '© BLAM-O'
}),
Streets:
L.tileLayer('http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png', {}),
CartoDB_Positron:
L.tileLayer('https://{s}.basemaps.cartocdn.com/light_all/{z}/{x}/{y}{r}.png', {})
};
var groupedOverlays = {
\"Map Type\": {
\"Stadia\": basemaps.Stadia_AlidadeSmoothDark,
\"Streets\": basemaps.Streets,
\"Positron\": basemaps.CartoDB_Positron
}
};
var options = {
groupCheckboxes: false,
exclusiveGroups: [\"Map Type\"],
collapsed:false
};
L.control.groupedLayers(null, groupedOverlays, options).addTo(this);
basemaps.Streets.addTo(this);
}")
This is a follow up question based on THIS post.
The demo app here is a closer representation of my more complex situation of my real shiny app that I'm trying to improve by replacing code that causes re-rendering of plotly objects by javascript codes that alter the existing plots.
This app has:
- 4 plots with unique ID's
- sets of 2 plots listen to the same set of colourInputs, 1 for each trace in each plot
- the legend and marker size in all plots are linked to numericInputs
The modification of the javascript from the previous question for this solution would need to:
- follow the size inputs
- follow the trace - colourInput linking
- target trace n in 2 plots based on colourInput n belonging to those 2 plots.
EDIT: slightly simplified scenario
Lets drop the legend issue for now, since the solution part 2 by Stephane does what I want for the colors. I'll deal with the legend sizing later.
The modified version might be a little clearer.
The javascript should:
if plot id is "plot1" or "plot2" listen to color-set1-1 till -3
if plot id is 'plot3' or 'plot4', lister to color-set2-1 till -3
I suppose we need some to add some lines in the js like: "
"var setnr = parseInt(id.split('-')[1]) ;",
to see which set of buttons we are looking at, followed by an if statement that achieves:
if 'setnr' == set1 , then var plots = plot1, plot2
else if 'setnr == set2, then var plots = plot3, plot4
and then update the trace in 'plots'
In the new app, the color-set1-1, color-set1-2, color-set1-3 still target all 4 plots.
library(plotly)
library(shiny)
library(colourpicker)
library(htmlwidgets)
js <- c(
"function(el,x){",
" $('[id^=Color]').on('change', function(){",
" var color = this.value;",
" var id = this.id;",
" var index = parseInt(id.split('-')[1]) - 1;",
" var data = el.data;",
" var marker = data[index].marker;",
" marker.color = color;",
" Plotly.restyle(el, {marker: marker}, [index]);",
" });",
"}")
ui <- fluidPage(
fluidRow(
column(4,plotlyOutput("plot1")),
column(4,plotlyOutput("plot2")),
column(4,
colourInput("Color-1", "Color item 1", value = "blue"), # these buttons will become named Color-set1-1, Color-set1-2, Color-set1-3
colourInput("Color-2", "Color item 2", value = "red"), # but that requires an extra change to the js
colourInput("Color-3", "Color item 3", value = "green")
)
),
fluidRow(
column(4,plotlyOutput("plot3")),
column(4,plotlyOutput("plot4")),
column(4,
colourInput("Color-set2-1", "Color item 1", value = "blue"),
colourInput("Color-set2-2", "Color item 2", value = "red"),
colourInput("Color-set2-3", "Color item 3", value = "green")
)
)
)
server <- function(input, output, session) {
values <- reactiveValues(colors1 = c('red', 'blue', 'black'), colors2 = c('yellow', 'blue', 'green') )
myplotly <- function(THEPLOT, xvar, setnr) {
markersize <- input[[paste('markersize', THEPLOT, sep = '_')]]
markerlegendsize <- input[[paste('legendsize', THEPLOT, sep = '_')]]
colors <- isolate ({values[[paste('colors', setnr, sep = '')]] })
p <- plot_ly(source = paste('plotlyplot', THEPLOT, sep = '.'))
p <- add_trace(p, data = mtcars, x = mtcars[[xvar]], y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
p <- layout(p, title = 'mtcars group by cyl with switching colors')
p <- plotly_build(p)
p %>% onRender(js)
}
output$plot1 <- renderPlotly({ myplotly('plot1', 'hp', 1) })
output$plot2 <- renderPlotly({ myplotly('plot2', 'disp', 1)})
output$plot3 <- renderPlotly({ myplotly('plot3','hp', 2)})
output$plot4 <- renderPlotly({ myplotly('plot4', 'disp', 2)})
}
shinyApp(ui, server)
The original APP:
library(plotly)
library(shiny)
library(htmlwidgets)
library(colourpicker)
library(shinyjs)
## javascript from previous question's answer:
jsCode <- "shinyjs.changelegend = function(){
var paths = d3.select('#plot1').
select('.legend').
select('.scrollbox').
selectAll('.traces').
select('.scatterpts')
.attr('d','M8,0A8,8 0 1,1 0,-8A8,8 0 0,1 8,0Z');}"
ui <- fluidPage(
tags$script(src = "https://d3js.org/d3.v4.min.js"),
useShinyjs(),
extendShinyjs(text = jsCode),
fluidRow(
column(2,numericInput(inputId = 'markersize_plot1', label = 'marker', min = 1, max = 40, value = 20)),
column(2,numericInput(inputId = 'legendsize_plot1', label = 'legend', min = 1, max = 40, value = 10)),
column(2,numericInput(inputId = 'markersize_plot2', label = 'marker', min = 1, max = 40, value = 4)),
column(2,numericInput(inputId = 'legendsize_plot2', label = 'legend', min = 1, max = 40, value = 20))
),
fluidRow(
column(4,plotlyOutput("plot1")),
column(4,plotlyOutput("plot2")),
column(2,uiOutput('buttons_color_1'))
),
fluidRow(
column(2,numericInput(inputId = 'markersize_plot3', label = 'marker', min = 1, max = 40, value = 10)),
column(2,numericInput(inputId = 'legendsize_plot3', label = 'legend', min = 1, max = 40, value = 30)),
column(2,numericInput(inputId = 'markersize_plot4', label = 'marker', min = 1, max = 40, value = 7)),
column(2,numericInput(inputId = 'legendsize_plot4', label = 'legend', min = 1, max = 40, value = 40))
),
fluidRow(
column(4,plotlyOutput("plot3")),
column(4,plotlyOutput("plot4")),
column(2,uiOutput('buttons_color_2'))
)
)
server <- function(input, output, session) {
values <- reactiveValues(colors1 = c('red', 'blue', 'black'), colors2 = c('yellow', 'blue', 'green') )
lapply(c(1:2), function(i) {
output[[paste('buttons_color_', i,sep = '')]] <- renderUI({
isolate({ lapply(1:3, function(x) { ## 3 in my app changes based on clustering output of my model
Idname <- if(i == 1) { COLElement_1(x) } else {COLElement_2(x) }
div(colourpicker::colourInput(inputId = Idname, label = NULL,
palette = "limited", allowedCols = TheColors,
value = values[[paste('colors', i, sep = '')]][x],
showColour = "background", returnName = TRUE),
style = " height: 30px; width: 30px; border-radius: 6px; border-width: 2px; text-align:center; padding: 0px; display:block; margin: 10px")
})
})})
outputOptions(output, paste('buttons_color_', i,sep = ''), suspendWhenHidden=FALSE)
})
COLElement_1 <- function(idx){sprintf("COL_button_1-%d",idx)}
lapply(1:3, function(ob) {
COLElement_1 <- COLElement_1(ob)
observeEvent(input[[COLElement_1]], {
values[[paste('colors', 1, sep = '')]][ob] <- input[[COLElement_1]]
plotlyProxy("plot1", session) %>%
plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_1]])), list(as.numeric(ob)-1))
plotlyProxy("plot2", session) %>%
plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_1]])), list(as.numeric(ob)-1))
})
})
COLElement_2 <- function(idx){sprintf("COL_button_2-%d",idx)}
lapply(1:3, function(ob) {
COLElement_2 <- COLElement_2(ob)
observeEvent(input[[COLElement_2]], {
values[[paste('colors', 2, sep = '')]][ob] <- input[[COLElement_2]]
plotlyProxy("plot3", session) %>%
plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_2]])), list(as.numeric(ob)-1))
plotlyProxy("plot4", session) %>%
plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_2]])), list(as.numeric(ob)-1))
})
})
myplotly <- function(THEPLOT, xvar, setnr) {
markersize <- input[[paste('markersize', THEPLOT, sep = '_')]]
markerlegendsize <- input[[paste('legendsize', THEPLOT, sep = '_')]]
colors <- isolate ({values[[paste('colors', setnr, sep = '')]] })
p <- plot_ly(source = paste('plotlyplot', THEPLOT, sep = '.'))
p <- add_trace(p, data = mtcars, x = mtcars[[xvar]], y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
p <- layout(p, title = 'mtcars group by cyl with switching colors')
p <- plotly_build(p)
# this is a bit of a hack to change the size of the legend markers to not be equal to the plot marker size.
# it makes a list of 1 size value for each marker in de trace in the plot, and another half of with sizes that are a lot bigger.
# the legend marker size is effectively the average size of all markers of a trace
for(i in seq(1, length(sort(unique(mtcars$cyl) )))) {
length.group <- nrow(mtcars[which(mtcars$cyl == sort(unique(mtcars$cyl))[i]), ])
p$x$data[[i]]$marker$size <- c(rep(markersize,length.group), rep(c(-markersize+2*markerlegendsize), length.group))
}
p
}
output$plot1 <- renderPlotly({ myplotly('plot1', 'hp', 1) })
output$plot2 <- renderPlotly({ myplotly('plot2', 'disp', 1)})
output$plot3 <- renderPlotly({ myplotly('plot3','hp', 2)})
output$plot4 <- renderPlotly({ myplotly('plot4', 'disp', 2)})
}
shinyApp(ui, server)
I'm lost :)
Let's start. Here is an app allowing to change the marker size:
library(plotly)
library(shiny)
js <- paste(c(
"$(document).ready(function(){",
" $('#size').on('change', function(){",
" var size = Number(this.value);",
" var plot = document.getElementById('plot');",
" var data = plot.data;",
" $.each(data, function(index,value){",
" var marker = data[index].marker;",
" marker.size = size;",
" Plotly.restyle(plot, {marker: marker}, [index]);",
" });",
" });",
"})"), sep = "\n")
ui <- fluidPage(
tags$head(
tags$script(HTML(js))
),
plotlyOutput("plot"),
numericInput("size", "Size", value = 5, min = 1, max = 15)
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
p <- plot_ly()
for(name in c("drat", "wt", "qsec"))
{
p <- add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
}
p
})
}
shinyApp(ui, server)
And here is an app allowing to change the marker color:
library(plotly)
library(shiny)
library(colourpicker)
library(htmlwidgets)
js <- c(
"function(el,x){",
" $('[id^=Color]').on('change', function(){",
" var color = this.value;",
" var id = this.id;",
" var index = parseInt(id.split('-')[1]) - 1;",
" var data = el.data;",
" var marker = data[index].marker;",
" marker.color = color;",
" Plotly.restyle(el, {marker: marker}, [index]);",
" });",
"}")
ui <- fluidPage(
plotlyOutput("plot"),
colourInput("Color-1", "Color item 1", value = "blue"),
colourInput("Color-2", "Color item 2", value = "red"),
colourInput("Color-3", "Color item 3", value = "green")
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
p <- plot_ly()
for(name in c("drat", "wt", "qsec"))
{
p <- add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
}
p %>% onRender(js)
})
}
shinyApp(ui, server)
Does it help?
With shiny, you can use color=~get(input$XXX). Here's an example with my own code:
fig = plot_mapbox()
# POLYGONS
fig = fig %>% add_sf(
data=districts,
split=~DISTRICT,
color=~log10(get(input$multi_indicator_districts.selectors.colorBy)))
# POINTS
fig = fig %>% add_trace(
type='scatter',
data=facilities,
x=~longitude,
y=~latitude,
split=~tier)
fig = fig %>% layout(
mapbox=list(
zoom=4,
style='open-street-map'))
I have a reproducible example taken from https://bl.ocks.org/timelyportfolio/5ab450e90ee510f4df9758b9ec5a8ad0.
library(sf)
library(plotly)
library(leaflet)
library(crosstalk)
library(htmltools)
boroughs<- st_read("http://services5.arcgis.com/GfwWNkhOj9bNBqoJ/arcgis/rest/services/nybb/FeatureServer/0/query?where=1=1&outFields=*&outSR=4326&f=geojson")
boroughs$x <- seq(1:5)
boroughs$y <- seq(2,10,2)
boroughs_sd <- SharedData$new(
boroughs,
key=~BoroCode,
# provide explicit group so we can easily refer to this later
group = "boroughs"
)
map <- leaflet(boroughs_sd) %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addPolygons(
data=boroughs,
layerId = ~BoroCode,
color = "#444444",
weight = 1,
smoothFactor = 0.5,
opacity = 1.0,
fillOpacity = 0.5,
fillColor = ~colorQuantile("Greens", x)(x)#,
# turn off highlight since it interferes with selection styling
# if careful with styling could have both highlight and select
# highlightOptions = highlightOptions(color = "white", weight = 2)
)
# borrow from https://github.com/r-spatial/mapedit/blob/master/R/query.R#L73-L132
# to select/deselect features but instead of Shiny.onInputChange
# use crosstalk to manage state
add_select_script <- function(lf, styleFalse, styleTrue, ns="") {
## check for existing onRender jsHook?
htmlwidgets::onRender(
lf,
sprintf(
"
function(el,x) {
var lf = this;
var style_obj = {
'false': %s,
'true': %s
}
// instead of shiny input as our state manager
// use crosstalk
if(crosstalk) {
var ct_sel = new crosstalk.SelectionHandle()
ct_sel.setGroup('boroughs')
ct_sel.on('change', function(x){
if(x.sender !== ct_sel) { //ignore select from this map
lf.eachLayer(function(lyr){
if(lyr.options && lyr.options.layerId) {
var id = String(lyr.options.layerId)
if(
!x.value ||
(Array.isArray(x.value) && x.value.indexOf(id) === -1)
) {
toggle_state(lyr, false)
toggle_style(lyr, style_obj.false)
}
if(Array.isArray(x.value) && x.value.indexOf(id) > -1) {
toggle_state(lyr, true)
toggle_style(lyr, style_obj.true)
}
}
})
}
})
}
// define our functions for toggling
function toggle_style(layer, style_obj) {
layer.setStyle(style_obj);
};
function toggle_state(layer, selected, init) {
if(typeof(selected) !== 'undefined') {
layer._mapedit_selected = selected;
} else {
selected = !layer._mapedit_selected;
layer._mapedit_selected = selected;
}
if(typeof(Shiny) !== 'undefined' && Shiny.onInputChange && !init) {
Shiny.onInputChange(
'%s-mapedit_selected',
{
'group': layer.options.group,
'id': layer.options.layerId,
'selected': selected
}
)
}
if(ct_sel) {
var ct_values = ct_sel.value
var id = String(layer.options.layerId)
if(selected) {
if(!ct_values) {
ct_sel.set([id])
}
if(Array.isArray(ct_values) && ct_values.indexOf(id) === -1) {
ct_sel.set(ct_values.concat(id))
}
}
if(ct_values && !selected) {
ct_values.length > 1 ?
ct_sel.set(
ct_values.filter(function(d) {
return d !== id
})
) :
ct_sel.set(null) // select all if nothing selected
}
}
return selected;
};
// set up click handler on each layer with a group name
lf.eachLayer(function(lyr){
if(lyr.on && lyr.options && lyr.options.layerId) {
// start with all unselected ?
toggle_state(lyr, false, init=true);
toggle_style(lyr, style_obj[lyr._mapedit_selected]);
lyr.on('mouseover',function(e){
var selected = toggle_state(e.target);
toggle_style(e.target, style_obj[String(selected)]);
});
}
});
}
",
jsonlite::toJSON(styleFalse, auto_unbox=TRUE),
jsonlite::toJSON(styleTrue, auto_unbox=TRUE),
ns
)
)
}
browsable(
tagList(
tags$div(
style = "float:left; width: 49%;",
add_select_script(
map,
styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4, color="black"),
styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7, color="blue")
)
),
tags$div(
style = "float:left; width: 49%;",
plot_ly(boroughs_sd, x = ~x, y = ~y) %>%
add_markers(alpha = 0.5,text = ~paste('Borough: ', BoroName)) %>%
highlight(on = "plotly_selected")
)
)
)
I made a minor change to the code from it's original source so that polygons are highlighted on mouseover rather than click.
My experience with JavaScript is pretty minimal. What do I need to change so that selection of polygons is not persistent (i.e. highlight style only changes when on mouseover and does not remain after the mouse has left that particular polygon)?
I suggest to change the following part of code
lyr.on('mouseover',function(e){
var selected = toggle_state(e.target);
toggle_style(e.target, style_obj[String(selected)]);
});
with
lyr.on('mouseover',function(e) {
var selected = toggle_state(e.target, true);
toggle_style(e.target, style_obj[String(selected)]);
});
lyr.on('mouseout',function(e) {
var selected = toggle_state(e.target, false);
toggle_style(e.target, style_obj[String(selected)]);
});
It works on my R.
I have an app where I am trying to change a point's size or color or symbol.
The point being the object that the user has clicked.
Clicking a point creates a popup in my program that shows another dataset linked to the ID value in a column belonging to the rownumber belonging to the point clicked. I included the flow of events in the demo app (without popups) for the click event.
I'm trying to change the point based on the answer here for a plotly 2d scatter plot. However, applying the code to my 3d plot doesn't seem to work.
A little extra background info: i'm building a program to analyse 3d scatter data and my app contains several of these 3D plots
Does anyone know how to make this work?
The app below contains the code for both a 2d (commented) and 3d plot object to show the working and non working situation and is a direct modification of the code given by #Maximilian Peters
Thank you for any help!
bonus question: Assuming we can make it work for the 3dplot, I would also like to figure out how to change the JavaScript code to change a point based on a number stored in a reactive variable (i.e. values$activepoint) rather than from a click event since I will allow the user to cycle through points with a <- and -> button that changes the point ID we are retrieving the additional info from.
library(shiny)
library(plotly)
library(htmlwidgets)
ui <- fluidPage(
plotlyOutput("plot"),
textOutput('messageNr')
)
javascript <- "
function(el, x){
el.on('plotly_click', function(data) {
colors = [];
var base_color = document.getElementsByClassName('legendpoints')[data.points[0].curveNumber].getElementsByTagName('path')[0].style['stroke']
for (var i = 0; i < data.points[0].data.x.length; i += 1) {
colors.push(base_color)
};
colors[data.points[0].pointNumber] = '#000000';
Plotly.restyle(el,
{'marker':{color: colors}},
[data.points[0].curveNumber]
);
//make sure all the other traces get back their original color
for (i = 0; i < document.getElementsByClassName('plotly')[0].data.length; i += 1) {
if (i != data.points[0].curveNumber) {
colors = [];
base_color = document.getElementsByClassName('legendpoints')[i].getElementsByTagName('path')[0].style['stroke'];
for (var p = 0; p < document.getElementsByClassName('plotly')[0].data[i].x.length; p += 1) {
colors.push(base_color);
}
Plotly.restyle(el,
{'marker':{color: colors}},
[i]);
}
};
});
}"
server <- function(input, output, session) {
row.names(mtcars) <- 1:nrow(mtcars)
colorscale <- c("blue", "red", "yellow")
values <- reactiveValues()
output$plot <- renderPlotly({
values$point <- event_data("plotly_click", source = "select")
plot_ly(mtcars,
x = ~mpg,
y = ~cyl,
z = ~wt,
type = "scatter3d",
color = as.factor(mtcars$gear),
colors = colorscale,
mode = "markers",
source = "select",
showlegend = F)%>%
add_markers() %>% onRender(javascript)
} )
observeEvent(values$point, {
values$row <- as.numeric(values$point$pointNumber) +1
values$ID <- rownames(mtcars)[values$row]
### the values$ID is what I use to look up the corresponding dataset in other dataframes containing the detailed info of a datapoint in the
### summary data set that is used to create the real scatter3d plots in which the user clicks.
output$messageNr <- renderText(values$ID)
})
}
# server <- function(input, output, session) {
#
# nms <- row.names(mtcars)
#
# output$plot <- renderPlotly({
# p <- ggplot(mtcars, aes(x = mpg, y = wt, col = as.factor(cyl))) +
# geom_point()
# ggplotly(p) %>% onRender(javascript)
#
# })
# }
shinyApp(ui, server)
You could add a trace just for highlighting the point, change the location of the single point in response to a Javascript eventListener.
library(shiny)
library(plotly)
library(htmlwidgets)
ui <- fluidPage(
plotlyOutput("plot"),
textOutput('messageNr')
)
javascript <- "
function(el, x) {
el.on('plotly_click', function(data) {
var highlight_trace = el.data.length - 1;
//the coordinates of the point which was clicked on
//is found in data
var newPoint = {x: data.points[0].x,
y: data.points[0].y,
z: data.points[0].z};
//update the plot data and redraw it
if (el.data[highlight_trace].x[0] != newPoint.x ||
el.data[highlight_trace].y[0] != newPoint.y ||
el.data[highlight_trace].z[0] != newPoint.z) {
el.data[highlight_trace].x[0] = newPoint.x;
el.data[highlight_trace].y[0] = newPoint.y
el.data[highlight_trace].z[0] = newPoint.z
Plotly.redraw(el);
}
})
}
"
server <- function(input, output, session) {
output$plot <- renderPlotly(
{
p <- plot_ly()
p <- add_trace(p,
data = mtcars,
x = ~mpg,
y = ~cyl,
z = ~wt,
color = as.factor(mtcars$gear),
type = 'scatter3d',
mode = "markers")
p <- add_trace(p,
x = c(20),
y = c(5),
z = c(4),
name = 'highlight',
type = 'scatter3d',
mode = 'markers',
marker = list(size = 15,
opacity = 0.5)) %>% onRender(javascript)
p
}
)
}
shinyApp(ui, server)
el is the JavaScript element where your plot is stored
'el.data' is where Plotly stores the data for your plot
the if block makes sure that the graph is only redrawn if a new point is clicked on
if a point is clicked on, the data for the highlight trace is overwritten and the plot is redrawn
Notes
Please make sure that you are using the latest version of Plotly, otherwise the click event might not work or is buggy
In your original code the trace is drawn multiple times (remove showlegend to see it), probably because of add_markers()
Interactive JavaScript example
Plotly.d3.csv('https://raw.githubusercontent.com/plotly/datasets/master/3d-scatter.csv', function(err, rows) {
function unpack(rows, key) {
return rows.map(function(row) {
return row[key];
});
}
var trace1 = {
x: unpack(rows, 'x1').slice(0, 30),
y: unpack(rows, 'y1').slice(0, 30),
z: unpack(rows, 'z1').slice(0, 30),
mode: 'markers',
marker: {
size: 12,
line: {
color: 'rgba(217, 217, 217, 0.14)',
width: 0.5
},
opacity: 0.8
},
type: 'scatter3d'
};
var trace3 = {
x: [0],
y: [0],
z: [0],
name: 'highlight',
mode: 'markers',
type: 'scatter3d',
marker: {
size: 24,
opacity: 0.5
}
};
var data = [trace1, trace3];
var layout = {
margin: {
l: 0,
r: 0,
b: 0,
t: 0
}
};
myDiv = document.getElementById('myDiv');
Plotly.newPlot(myDiv, data);
myDiv.on('plotly_click', function(data) {
var highlight_trace = myDiv.data.length - 1;
//the coordinates of the point which was clicked on
//is found in data
var newPoint = {
x: data.points[0].x,
y: data.points[0].y,
z: data.points[0].z
};
//update the plot data and redraw it
if (myDiv.data[highlight_trace].x[0] != newPoint.x ||
myDiv.data[highlight_trace].y[0] != newPoint.y ||
myDiv.data[highlight_trace].z[0] != newPoint.z) {
myDiv.data[highlight_trace].x[0] = newPoint.x;
myDiv.data[highlight_trace].y[0] = newPoint.y
myDiv.data[highlight_trace].z[0] = newPoint.z
Plotly.redraw(myDiv);
}
});
})
<script src="https://cdn.plot.ly/plotly-latest.min.js"></script>
<div id='myDiv'></div>
I have this scatter plot where I want to zoom in an area and then subset a table to show only the data from the subsetted points. The first step is done by zoomType = "xy", but I'm having troubles on the second step. Could anyone give me a hint on how can I access the upper left and bottom right points coordinates of the zoomed area, so I can subset the table?
Thank you!
library("shiny")
library("highcharter")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
dscars <- round(mvrnorm(n = 20, mu = c(1, 1), Sigma = matrix(c(1,0,0,1),2)), 2)
dsplan <- round(mvrnorm(n = 10, mu = c(3, 4), Sigma = matrix(c(2,.5,2,2),2)), 2)
dstrck <- round(mvrnorm(n = 15, mu = c(5, 1), Sigma = matrix(c(1,.5,.5,1),2)), 2)
output$hcontainer <- renderHighchart({
canvasClickFunction <- JS("function(event) {Shiny.onInputChange('canvasClicked', [this.name, event.point.category]);}")
legendClickFunction <- JS("function(event) {Shiny.onInputChange('legendClicked', this.name);}")
highchart() %>%
hc_chart(type = "scatter", zoomType = "xy") %>%
hc_tooltip(
useHTML = T,
enabled = F,
pointFormat = paste0("<span style=\"color:{series.color};\">{series.options.icon}</span>",
"{series.name}: <b>[{point.x}, {point.y}]</b><br/>")
) %>%
hc_add_series(data = list.parse2(as.data.frame(dscars)),marker = list(symbol = fa_icon_mark("car")),icon = fa_icon("car"), name = "car") %>%
hc_add_series(data = list.parse2(as.data.frame(dsplan)),marker = list(symbol = fa_icon_mark("plane")),icon = fa_icon("plane"), name = "plane") %>%
hc_add_series(data = list.parse2(as.data.frame(dstrck)),marker = list(symbol = fa_icon_mark("truck")),icon = fa_icon("truck"), name = "truck") %>%
hc_plotOptions(series = list(stacking = FALSE, events = list(click = canvasClickFunction, legendItemClick = legendClickFunction)))
})
makeReactiveBinding("outputText")
observeEvent(input$canvasClicked, {
outputText <<- paste0("You clicked on series ", input$canvasClicked[1], " and the bar you clicked was from category ", input$canvasClicked[2], ".")
})
observeEvent(input$legendClicked, {
outputText <<- paste0("You clicked into the legend and selected series ", input$legendClicked, ".")
})
output$text <- renderText({
outputText
})
}
shinyApp(ui, server)
2nd Try
I tried something like:
selectionfunction<- JS("function(event) {Shiny.onInputChange('range', [event.xAxis, event.yAxis]);}")
with:
hc_plotOptions(series = list(stacking = FALSE, events = list( selection=selectionfunction )))
makeReactiveBinding("outputText")
observeEvent(input$range, {
outputText <<- paste0("x= ", input$range[1],"y= " ,input$range[2])
})
output$text <- renderText({
outputText
})
But it seems to me that the function selectionfunction is not called when I zoom the plot.
Almost a good solution
I found a almost functional solution:
library("shiny")
library("highcharter")
library("MASS")
ui <- shinyUI(
fluidPage(
column(width = 8, highchartOutput("hcontainer", height = "500px")),
column(width = 4, textOutput("text"))
)
)
server <- function(input, output) {
dscars <- round(mvrnorm(n = 20, mu = c(1, 1), Sigma = matrix(c(1,0,0,1),2)), 2)
dsplan <- round(mvrnorm(n = 10, mu = c(3, 4), Sigma = matrix(c(2,.5,2,2),2)), 2)
dstrck <- round(mvrnorm(n = 15, mu = c(5, 1), Sigma = matrix(c(1,.5,.5,1),2)), 2)
output$hcontainer <- renderHighchart({
selectionfunction <- JS("function(event) {
Shiny.onInputChange('canvasClicked2', [event.xAxis[0].min , event.xAxis[0].max , event.yAxis[0].min , event.yAxis[0].max ] );}")
highchart() %>%
hc_chart(type = "scatter", zoomType = "xy", events= list(selection=selectionfunction)) %>%
hc_tooltip(
useHTML = T,
enabled = F,
pointFormat = paste0("<span style=\"color:{series.color};\">{series.options.icon}</span>",
"{series.name}: <b>[{point.x}, {point.y}]</b><br/>")
) %>%
hc_add_series(data = list.parse2(as.data.frame(dscars)),marker = list(symbol = fa_icon_mark("car")),icon = fa_icon("car"), name = "car") %>%
hc_add_series(data = list.parse2(as.data.frame(dsplan)),marker = list(symbol = fa_icon_mark("plane")),icon = fa_icon("plane"), name = "plane") %>%
hc_add_series(data = list.parse2(as.data.frame(dstrck)),marker = list(symbol = fa_icon_mark("truck")),icon = fa_icon("truck"), name = "truck")
})
makeReactiveBinding("outputText")
observeEvent(input$canvasClicked, {
outputText <<- paste0("You clicked on series ", input$canvasClicked[1], " and the bar you clicked was from category ", input$canvasClicked[2],input$canvasClicked[3], ".")
})
observeEvent(input$canvasClicked2, {
outputText <<- paste0(input$canvasClicked2[1]," ",input$canvasClicked2[2]," ",input$canvasClicked2[3]," ",input$canvasClicked2[4])
})
output$text <- renderText({
outputText
})
}
shinyApp(ui, server)
The axis boundaries are correctly printed but with 1 step delay. Can someone help?
Final Solution
I found a solution by working on the JS function:
selectionfunction1 <- JS("function(event) {
var x_axis_min,x_axis_max,y_axis_min,y_axis_max;
if (event.xAxis) {
x_axis_min = Highcharts.numberFormat(event.xAxis[0].min, 2),
x_axis_max = Highcharts.numberFormat(event.xAxis[0].max, 2);
}else{
x_axis_min = 'reset',
x_axis_max = 'reset';
}
if (event.yAxis) {
y_axis_min = Highcharts.numberFormat(event.yAxis[0].min, 2),
y_axis_max = Highcharts.numberFormat(event.yAxis[0].max, 2);
}else{
y_axis_min = 'reset',
y_axis_max = 'reset';
}
Shiny.onInputChange('canvasClickedxmin', x_axis_min);
Shiny.onInputChange('canvasClickedxmax', x_axis_max);
Shiny.onInputChange('canvasClickedymin', y_axis_min);
Shiny.onInputChange('canvasClickedymax', y_axis_max);
}")