Unable to select polygon on a select module after use of leaflet proxy
Fooourche opened this issue · comments
Hello,
First, i would like to thanks fr this package, i though such interaction was impossible with leaflet... but it is.
I've got an issue with a the select module, but maybe i don t get a something :
When i use a leaflet proxy with a selectmodule, the polygon i ve updated with leaflet proxy are not selectable anymore. Here is an example : when you push the push me button, the polygons are styled in red but are not selectable ... Maybe there is something with the layerId but i tried a lot of things and didn't resolved it... if anyone has any ideas
Thanks in advance
Fabien
library(sf)
library(leaflet)
# make the coordinates a numeric matrix
qk_mx <- data.matrix(quakes[,2:1])
# convert the coordinates to a multipoint feature
qk_mp <- st_multipoint(qk_mx)
# convert the multipoint feature to sf
qk_sf <- st_sf(st_cast(st_sfc(qk_mp), "POINT"), quakes, crs=4326)
# make a grid
grd <- st_set_crs(st_make_grid(qk_sf), 4326)
# only keep grid polygons that contain at least one quake point
grd <- grd[which(sapply(st_contains(st_sf(grd), qk_sf),length)>0)]
# library(mapview)
library(mapedit)
library(shiny)
ui <- fluidPage(
fluidRow(
column(
6,
h3("Select Grid"),
# our new select module ui
selectModUI("selectmap")
),
column(
6,
h3("Selected Quakes"),
actionButton(inputId = 'button',label = 'push me'),
plotOutput("selectplot")
)
),
fluidRow(
h3("Magnitude Distribution of Selected Quakes"),
plotOutput("quakestat", height=200)
)
)
server <- function(input, output, session) {
# our new select module
g_sel <- callModule(
selectMod,
"selectmap",
leaflet() %>%
addTiles() %>%
addFeatures(st_sf(grd), layerId = ~seq_len(length(grd)))
)
rv <- reactiveValues(intersect=NULL, selectgrid=NULL)
observe({
# the select module returns a reactive
# so let's use it to find the intersection
# of selected grid with quakes points
gs <- g_sel()
rv$selectgrid <- st_sf(
grd[as.numeric(gs[which(gs$selected==TRUE),"id"])]
)
if(length(rv$selectgrid) > 0) {
rv$intersect <- st_intersection(rv$selectgrid, qk_sf)
} else {
rv$intersect <- NULL
}
})
ns <- shiny::NS("selectmap")
observeEvent(input$button,{
req(g_sel)
if(length(g_sel()$id)>=1)
{
leafletProxy(ns('map')) %>%
#addFeatures(st_sf(grd[as.numeric(g_sel()$id)]), layerId = ~seq_len(length(grd[as.numeric(g_sel()$id)])),color='red',fill=TRUE)
addPolygons(data=st_sf(grd[as.numeric(g_sel()$id)]),
layerId = ~seq_len(length(grd[as.numeric(g_sel()$id)])),
color='red',fillColor = 'red',
fill=TRUE)
}
})
output$selectplot <- renderPlot({
plot(qk_mp, col="gray")
if(!is.null(rv$intersect)) {
plot(rv$intersect, pch=19, col="black", add=TRUE)
}
plot(st_union(rv$selectgrid), add=TRUE)
})
output$quakestat <- renderPlot({
plot(
stats::density(qk_sf$mag), col="gray30", ylim=c(0,1.2),
main = NA
)
if(!is.null(rv$intersect) && nrow(rv$intersect) > 0) {
lines(stats::density(rv$intersect$mag), col="red", lwd=2)
}
})
}
shinyApp(ui, server)
Hello,
As anyone got the same problem, i tried a lot of things and nothing working....
Does anybody has an idea ?
Thanks
Fabien
@Fooourche thanks for the issue. This one is very tricky, and I did not consider this originally. I'll try to think of a solution.
@Fooourche, this doesn't work perfectly, but it gets us a little closer. I'm not sure we should add this to mapedit
, since I think this is an edge case. The code works by adding a layeradd
handler and adding the select behavior to any added layer.
library(sf)
library(leaflet)
library(mapview)
add_select_script_layer_add <- function(
lf,
styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4),
styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7),
ns = ""
) {
## check for existing onRender jsHook?
htmlwidgets::onRender(
lf,
sprintf(
"
function(el,x) {
var lf = this;
var style_obj = {
'false': %s,
'true': %s
}
// 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
}
)
}
return selected;
};
// set up click handler on each layer with a group name
lf.on('layeradd', function(e) {
var lyr = e.layer;
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('click',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
)
)
}
# make the coordinates a numeric matrix
qk_mx <- data.matrix(quakes[,2:1])
# convert the coordinates to a multipoint feature
qk_mp <- st_multipoint(qk_mx)
# convert the multipoint feature to sf
qk_sf <- st_sf(st_cast(st_sfc(qk_mp), "POINT"), quakes, crs=4326)
# make a grid
grd <- st_set_crs(st_make_grid(qk_sf), 4326)
# only keep grid polygons that contain at least one quake point
grd <- grd[which(sapply(st_contains(st_sf(grd), qk_sf),length)>0)]
# library(mapview)
library(mapedit)
library(shiny)
ui <- fluidPage(
fluidRow(
column(
6,
h3("Select Grid"),
# our new select module ui
selectModUI("selectmap")
),
column(
6,
h3("Selected Quakes"),
actionButton(inputId = 'button',label = 'push me'),
plotOutput("selectplot")
)
),
fluidRow(
h3("Magnitude Distribution of Selected Quakes"),
plotOutput("quakestat", height=200)
)
)
server <- function(input, output, session) {
# our new select module
g_sel <- callModule(
selectMod,
"selectmap",
leaflet() %>%
addTiles() %>%
addFeatures(st_sf(grd), layerId = ~seq_len(length(grd))) %>%
add_select_script_layer_add(ns="selectmap")
)
# keep up with sequence so we can add later
nid <- length(grd)
rv <- reactiveValues(intersect=NULL, selectgrid=NULL)
observe({
# the select module returns a reactive
# so let's use it to find the intersection
# of selected grid with quakes points
gs <- g_sel()
rv$selectgrid <- st_sf(
grd[as.numeric(gs[which(gs$selected==TRUE),"id"])]
)
if(length(rv$selectgrid) > 0) {
rv$intersect <- st_intersection(rv$selectgrid, qk_sf)
} else {
rv$intersect <- NULL
}
})
ns <- shiny::NS("selectmap")
observeEvent(input$button,{
req(g_sel)
if(length(g_sel()$id)>=1)
{
leafletProxy(ns('map')) %>%
#addFeatures(st_sf(grd[as.numeric(g_sel()$id)]), layerId = ~seq_len(length(grd[as.numeric(g_sel()$id)])),color='red',fill=TRUE)
addPolygons(data=st_sf(grd[as.numeric(g_sel()$id)]),
layerId = ~nid + seq_len( length(grd[as.numeric(g_sel()$id)]) ),
color='red',fillColor = 'red',
fill=TRUE)
# increment our sequence state by number newly added features
nid <<- nid + length(grd[as.numeric(g_sel()$id)])
}
})
output$selectplot <- renderPlot({
plot(qk_mp, col="gray")
if(!is.null(rv$intersect)) {
plot(rv$intersect, pch=19, col="black", add=TRUE)
}
plot(st_union(rv$selectgrid), add=TRUE)
})
output$quakestat <- renderPlot({
plot(
stats::density(qk_sf$mag), col="gray30", ylim=c(0,1.2),
main = NA
)
if(!is.null(rv$intersect) && nrow(rv$intersect) > 0) {
lines(stats::density(rv$intersect$mag), col="red", lwd=2)
}
})
}
shinyApp(ui, server)
Thanks a lot @timelyportfolio this is working ;))))