Develop Reference

Adding a 'click' event to leaflet polygons via R

How can I add a mouse 'click' event to each polygon plotted on a leaflet map? I want to do this so I can then filter a separate widget based on data from the features (in this case WD21CD).
---
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)
library(tidyverse)
library(htmltools)
library(leaflet)
```
```{r cars, echo=FALSE}
url <- 'https://opendata.arcgis.com/api/v3/datasets/bf9d32b1aa9941af84e6c2bf0c54b1bb_0/downloads/data?format=geojson&spatialRefId=4326'
wardShapes <- sf::st_read(url) %>%
filter(WD21CD >= "E05011175" & WD21CD <= "E05011181")
leaflet(wardShapes,elementId = "bhamMap",
height = 550,# width = 10,
options = leafletOptions(minZoom = 10, maxZoom = 14)) %>%
addTiles() %>%
setView(lng = -1.810, lat = 52.555, zoom = 12) %>%
addPolygons(
weight = 0.5, smoothFactor = 0.5,
opacity = 1.0, fillOpacity = 0.2,
highlightOptions = highlightOptions(color = "white", weight = 2, bringToFront = TRUE),
label = ~as.character(WD21NM),
labelOptions = (interactive = TRUE)
)
```
```{js, class.source = "jsvis1", echo=FALSE}
document.getElementById("bhamMap").addEventListener("click", function(e){
console.log("hello");
});

We can use htmlwidgets::onRender to pass custom JS code to the leaflet htmlwidget.
With the help of the eachLayer method we can add an on-click function to each polygon layer:
---
title: "leaflet polygons clicks"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)
library(tidyverse)
library(htmltools)
library(leaflet)
library(sf)
library(htmlwidgets)
```
```{r cars, echo=FALSE}
url <- 'https://opendata.arcgis.com/api/v3/datasets/bf9d32b1aa9941af84e6c2bf0c54b1bb_0/downloads/data?format=geojson&spatialRefId=4326'
wardShapes <- sf::st_read(url) %>%
filter(WD21CD >= "E05011175" & WD21CD <= "E05011181")
leaflet(wardShapes,elementId = "bhamMap",
height = 550,# width = 10,
options = leafletOptions(minZoom = 10, maxZoom = 14)) %>%
addTiles() %>%
setView(lng = -1.810, lat = 52.555, zoom = 12) %>%
addPolygons(
weight = 0.5, smoothFactor = 0.5,
opacity = 1.0, fillOpacity = 0.2,
highlightOptions = highlightOptions(color = "white", weight = 2, bringToFront = TRUE),
label = ~ as.character(WD21NM),
labelOptions = (interactive = TRUE),
options = pathOptions(title = ~ WD21CD, customdata = ~ WD21NM)
) %>% htmlwidgets::onRender("
function(el, x) {
var map = this;
map.eachLayer(function(layer) {
if(layer instanceof L.Polygon){
layer.on('click', function(e){
alert('You clicked on layer._leaflet_id: ' + layer._leaflet_id + '\\nWD21CD: ' + layer.options.title + '\\ncustomdata: ' + layer.options.customdata);
})
.addTo(map)
}
});
}
")
```

Highcharter shiny events - Returning multiple selected points to a dataframe

Is there a way to return all the selected points from a scatter plot in highchart via shiny? The idea is to dynamically exclude or include points to be used for regression. I would like to have the ability to select the desired points, write them to a dataframe and then perform a non-linear regression on them. So far, I'm able to select and deselect points from the chart by using the JavaScript code from here and here. I can't seem to be able to return the selected points to a dataframe.
Please see my attempt below.
#devtools::install_github("jbkunst/highcharter")
library(highcharter)
library(htmlwidgets)
library(shiny)
#http://jsfiddle.net/gh/get/jquery/3.1.1/highcharts/highcharts/tree/master/samples/highcharts/chart/events-selection-points/
# selectPointsByDrag
s1 <- JS("/**
* Custom selection handler that selects points and cancels the default zoom behaviour
*/
function selectPointsByDrag(e) {
// Select points
Highcharts.each(this.series, function (series) {
Highcharts.each(series.points, function (point) {
if (point.x >= e.xAxis[0].min && point.x <= e.xAxis[0].max &&
point.y >= e.yAxis[0].min && point.y <= e.yAxis[0].max) {
point.select(true, true);
}
});
});
// Fire a custom event
Highcharts.fireEvent(this, 'selectedpoints', { points: this.getSelectedPoints() });
return false; // Don't zoom
}")
# unselectByClick
s2 <- JS("/**
* On click, unselect all points
*/
function unselectByClick() {
var points = this.getSelectedPoints();
if (points.length > 0) {
Highcharts.each(points, function (point) {
point.select(false);
});
}
}")
shinyApp(
ui = fluidPage(
uiOutput("selection_ui"),
highchartOutput("plot_hc"),
tableOutput("view")
),
server = function(input, output) {
df <- data.frame(x = 1:50, y = 1:50, otherInfo = letters[11:15])
df_copy <- df
output$plot_hc <- renderHighchart({
highchart() %>%
hc_chart(zoomType = 'xy', events = list(selection = s1, click = s2)) %>%
hc_add_series(df, "scatter") %>%
hc_add_event_point(event = "select")
})
output$view <- renderTable({
data.table(x = input$plot_hc_select$x, y = input$plot_hc_select$y)
})
observeEvent(input$plot_hc, print(paste("plot_hc", input$plot_hc)))
output$selection_ui <- renderUI({
if(is.null(input$plot_hc_select)) return()
wellPanel("Coordinates of selected point: ",input$plot_hc_select$x, input$plot_hc_select$y)
})
}
)
Error: column or argument 1 is NULL

There is no straightforward way to achieve what you want, using only Highcharter or Highcharts (as far as I know). One simple way to do this though would be to store each selected point in an (javascript) array, and to pass it to R. Thanks to Shiny, this can be easily done using Shiny.onInputChange (see example here).
One could rewrite your shiny app like this to make it work:
1) In the s1 function, store the selected points in xArr.
2) Use Shiny.onInputChange to pass xArr to R. xArr will be accessible via input$R_xArr (I chose the name R_xArr, it is not an automatic assignment).
3) Use a reactiveValues to store the selected points on the R side.
4) Update these values with appropriate observers.
#devtools::install_github("jbkunst/highcharter")
library(highcharter)
library(htmlwidgets)
library(shiny)
library(data.table)
# selectPointsByDrag
s1 <- JS("/**
* Custom selection handler that selects points and cancels the default zoom behaviour
*/
function selectPointsByDrag(e) {
var xArr = []
// Select points
Highcharts.each(this.series, function (series) {
Highcharts.each(series.points, function (point) {
if (point.x >= e.xAxis[0].min && point.x <= e.xAxis[0].max &&
point.y >= e.yAxis[0].min && point.y <= e.yAxis[0].max) {
xArr.push(point.x);
point.select(true, true);
}
});
});
Shiny.onInputChange('R_xArr', xArr);
// Fire a custom event
Highcharts.fireEvent(this, 'selectedpoints', { points: this.getSelectedPoints() });
return false; // Don't zoom
}")
# unselectByClick
s2 <- JS("/**
* On click, unselect all points
*/
function unselectByClick() {
var points = this.getSelectedPoints();
if (points.length > 0) {
Highcharts.each(points, function (point) {
point.select(false);
});
}
}")
shinyApp(
ui = fluidPage(
highchartOutput("plot_hc"),
tableOutput("view")
),
server = function(input, output) {
df <- data.frame(x = 1:50, y = 1:50, otherInfo = letters[11:15])
output$plot_hc <- renderHighchart({
highchart() %>%
hc_chart(zoomType = 'xy', events = list(selection = s1, click = s2)) %>%
hc_add_series(df, "scatter") %>%
hc_add_event_point(event = "unselect")
})
selected.points <- reactiveValues(x = NULL, y = NULL)
output$view <- renderTable({
if (is.null(selected.points$x) || is.null(selected.points$y)) {
return(NULL)
} else {
data.table(x = selected.points$x, y = selected.points$y)
}
})
observeEvent(input$R_xArr, {
selected.points$x <- sort(unique(c(selected.points$x, input$R_xArr)))
selected.points$y <- df$y[df$x %in% selected.points$x]
})
observeEvent(input$plot_hc_unselect, {
selected.points$x <- NULL
selected.points$y <- NULL
})
}
)
Hope this helps.

Change a single point in a plotly scatter3d in R shiny

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>

visNetwork + R: show node labels only on select

trying to get node labels to be shown only on nodes that have been selected.
I found a similar question that wanted to only show edge labels on hover. The solution was this:
nodes <- data.frame(id = 1:3, label = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3), label = "Edge label", font.size = 0)
visNetwork(nodes, edges) %>%
visInteraction(hover = T) %>%
visEvents(hoverEdge = "function(e){
this.body.data.edges.update({id: e.edge, font: {size : 14}});
}") %>%
visEvents(blurEdge = "function(e){
this.body.data.edges.update({id: e.edge, font: {size : 0}});
}")
I've tried modifying this but I don't think I'm doing the javascript part right, I know JS hardly at all.
nodes <- data.frame(id = 1:3, label = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3), label = "Edge label", font.size = 0)
visNetwork(nodes, edges) %>%
visInteraction(hover = T) %>%
visEvents(selectNode= "function(e){
this.body.data.nodes.update({id: e.node, font: {size : 14}});
}") %>%
visEvents(deselectNode= "function(e){
this.body.data.nodes.update({id: e.node, font: {size : 0}});
}")
This instead causes a new node to be created every time I select or deselect a node. While sitting and clicking on them was a fun way to crash my Rsession, it unfortunately hasn't solved my problem.
I'm sure this is a simple fix but I've been through the visNetwork documentation and I'm just not finding what I need. Help appreciated!

This should do the trick. This JS is actually creating a variable based off both of the labels in the dataframe. I'm sure there's a more technical method to doing this, but it should still work just fine.
library(visNetwork)
nodes <- data.frame(id = 1:3, label = paste0(""), label_long = c('Label 1','Label 2','Label 3'))
edges <- data.frame(from = c(1,2), to = c(1,3), label = "Edge label", font.size = 0)
net <- visNetwork(nodes, edges) %>%
visInteraction(hover = T) %>%
visEvents(selectNode = "function(e){
var label_info = this.body.data.nodes.get({
fields: ['label', 'label_long'],
filter: function (item) {
return item.id === e.node
},
returnType :'Array'
});
this.body.data.nodes.update({id: e.node, label : label_info[0].label_long, label_long : label_info[0].label});
}") %>%
visEvents(blurNode = "function(e){
var label_info = this.body.data.nodes.get({
fields: ['label', 'label_long'],
filter: function (item) {
return item.id === e.node
},
returnType :'Array'
});
this.body.data.nodes.update({id: e.node, label : label_info[0].label_long, label_long : label_info[0].label});
}")
print(net)

Point coordinates of zoomed area highchart shiny R

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);
}")