Unable to select polygon on a select module after use of leaflet proxy

[Fooourche]

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)

[Fooourche]

Hello,

As anyone got the same problem, i tried a lot of things and nothing working.... Does anybody has an idea ?

Thanks Fabien

[timelyportfolio]

@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.

[timelyportfolio]

@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)

[Fooourche]

Thanks a lot @timelyportfolio this is working ;))))