通过点击图例选择或突出显示地图上的数据

Question

通过单击Rshiny中的图例，是否有任何方法在传单地图上选择或突出显示数据？ 示例代码：

library(shiny) 
library(leaflet) 
library(RColorBrewer) 
library(leafletGeocoderRshiny) 

ui <- fluidPage(
    leafletOutput("map"), 
    p(), 
    actionButton("recalc", "New points") 
) 

server <- function(input, output, session) { 

    df = data.frame(x = rnorm(100), y = rexp(100, 2), z = runif(100)) 
    pal = colorBin('PuOr', df$z, bins = c(0, .1, .4, .9, 1)) 

    output$map <- renderLeaflet({ leaflet(df) %>% 
    addCircleMarkers(~x, ~y, color = ~pal(z)) %>% 
    addLegend(pal = pal, values = ~z) 
    }) 

} 

shinyApp(ui, server) 

Answer 1

最近更新（0.2）到mapedit包可以帮助：http://r-spatial.org/r/2017/06/09/mapedit_0-2-0.html

Answer 2

我接近，但现在已经没有时间。但无论如何，我决定分享，也许别人看到了最后一步的解决方案。

到目前为止它适用于图例中任何矩形的第一次点击。它不适用于任何下面的点击，因为地图被重新绘制，并且onclick监听器被删除。我没有找到一种方法来添加它们到目前为止，...

它的一个hacky aprroach：我添加onclick监听器的框，并决定通过R更新颜色，因为我没有看到在JS中的好方法。

library(shiny) 
library(leaflet) 
library(RColorBrewer) 
library(leafletGeocoderRshiny) 
library(shinyjs) 

colors <- c("#000000", "#222222", "#888888", "#FFFFFF") 

ui <- fluidPage(
    useShinyjs(), 
    leafletOutput("map"), 
    p(), 
    actionButton("recalc", "New points") 
) 

server <- function(input, output, session) { 
    global <- reactiveValues(colors = colors, 
          bins = c(0, .1, .4, .9, 1)) 

    observe({ 
    print(input$interval) 
    isolate({ 
     if(!is.null(input$interval)){ 
     lowerBound <- as.numeric(unlist(input$interval)) 
     global$colors <- colors 
     global$colors[which(global$bins == lowerBound)] <- "#FF0000" 
     } 
    }) 
    }) 

    session$onFlushed(function() { 
    runjs(" 
     var legendButton = document.getElementsByTagName('i') 
     var elem; var interval; 
     for (nr = 0; nr < legendButton.length; nr++) { 
     elem = legendButton[nr] 
     elem.onclick = function(e){ 
      console.log(e.target) 
      interval = e.target.nextSibling.nodeValue.split(' '); 
      Shiny.onInputChange('interval', interval[1]); 
     } 
     } 
    ") 
    }) 


    df = data.frame(x = rnorm(100), y = rexp(100, 2), z = runif(100)) 
    pal = reactive({ 
    colorBin(global$colors, df$z, bins = global$bins) 
    }) 

    output$map <- renderLeaflet({ leaflet(df) %>% 
     addCircleMarkers(~x, ~y, color = ~pal()(z)) %>% 
     addLegend(pal = pal(), values = ~z) 
    }) 

} 

runApp(shinyApp(ui, server), launch.browser = T)