Shiny中如何循环生成observeEvent实现Leaflet点击多边形改样式

解决方案 #

核心思路是通过循环批量生成observeEvent事件监听，配合force()函数锁定每次循环的索引值，解决R语言惰性求值导致的索引绑定错误问题。

核心修改点 #

删除原有手动编写的单张地图点击监听逻辑，在server函数中添加以下循环代码，最多支持99张地图的自动绑定：

# 批量绑定所有地图的点击事件
lapply(1:99, function(i) {
  # 锁定当前循环的索引值，避免惰性求值导致所有事件共用最后一个索引
  force(i)
  # 拼接当前地图的ID和点击事件ID
  cur_map_id <- paste0("plot_", i)
  cur_click_id <- paste0(cur_map_id, "_shape_click")

  # 未点击状态下点击事件：切换为黄色
  observeEvent(input[[cur_click_id]], {
    req(input[[cur_click_id]]$group == "unclicked_poly")
    hit_data <- rv$df[rv$df$ID == input[[cur_click_id]]$id, ]
    change_color(
      map = cur_map_id,
      id_to_remove = input[[cur_click_id]]$id,
      data = hit_data,
      colour = "yellow",
      new_group = "clicked1_poly"
    )
  })

  # 已点击状态下点击事件：恢复默认样式
  observeEvent(input[[cur_click_id]], {
    req(input[[cur_click_id]]$group == "clicked1_poly")
    hit_data <- rv$df[rv$df$ID == input[[cur_click_id]]$id, ]
    leafletProxy(cur_map_id) %>%
      removeShape(input[[cur_click_id]]$id) %>%
      addPolygons(
        data = hit_data,
        label = as.character(hit_data$display),
        layerId = hit_data$ID,
        group = "unclicked_poly"
      )
  })
})

完整可运行代码 #

library(leaflet)
library(sp)

## 创建两个方形多边形
Sr1 <- Polygon(cbind(c(1, 2, 2, 1, 1), c(1, 1, 2, 2, 1)))
Sr2 <- Polygon(cbind(c(2, 3, 3, 2, 2), c(1, 1, 2, 2, 1)))
Srs1 <- Polygons(list(Sr1), "s1")
Srs2 <- Polygons(list(Sr2), "s2")
SpP <- SpatialPolygons(list(Srs1, Srs2), 1:2)

ui <- fluidPage(
  sliderInput("nomaps", "Number of maps:",
              min = 1, max = 5, value = 1
  ),
  uiOutput("plots")
)

change_color <- function(map, id_to_remove, data, colour, new_group){
  leafletProxy(map) %>%
    removeShape(id_to_remove) %>% # 移除原有多边形
    addPolygons(
      data = data,
      label = data$display,
      layerId = data$ID,
      group = new_group, # 切换分组
      fillColor = colour)
}

server <- function(input,output,session){
  
  ## 多边形数据存储
  rv <- reactiveValues(
    df = SpatialPolygonsDataFrame(SpP, data = data.frame(
      ID = c("1", "2"),
      display = c("1", "1")
    ), match.ID = FALSE)
  )
  
  # 动态生成对应数量的地图
  observe({
    data <- rv$df
    lapply(1:input$nomaps, function(i) {
      output[[paste("plot", i, sep = "_")]] <- renderLeaflet({
        leaflet(options = leafletOptions( zoomControl = FALSE, minZoom = 6.2, maxZoom = 6.2, dragging = FALSE))%>%
          addPolygons(
            data = data,
            label = data$display,
            layerId = data$ID,
            group = "unclicked_poly")
      })
    })
  })
  
  # 生成地图UI列表
  output$plots <- renderUI({
    plot_output_list <- lapply(1:input$nomaps, function(i) {
      plotname <- paste("plot", i, sep = "_")
      leafletOutput(plotname)
    })
    do.call(tagList, plot_output_list)
  })

  # 批量绑定所有地图的点击事件
  lapply(1:99, function(i) {
    force(i)
    cur_map_id <- paste0("plot_", i)
    cur_click_id <- paste0(cur_map_id, "_shape_click")
  
    observeEvent(input[[cur_click_id]], {
      req(input[[cur_click_id]]$group == "unclicked_poly")
      hit_data <- rv$df[rv$df$ID == input[[cur_click_id]]$id, ]
      change_color(
        map = cur_map_id,
        id_to_remove = input[[cur_click_id]]$id,
        data = hit_data,
        colour = "yellow",
        new_group = "clicked1_poly"
      )
    })
  
    observeEvent(input[[cur_click_id]], {
      req(input[[cur_click_id]]$group == "clicked1_poly")
      hit_data <- rv$df[rv$df$ID == input[[cur_click_id]]$id, ]
      leafletProxy(cur_map_id) %>%
        removeShape(input[[cur_click_id]]$id) %>%
        addPolygons(
          data = hit_data,
          label = as.character(hit_data$display),
          layerId = hit_data$ID,
          group = "unclicked_poly"
        )
    })
  })
}

shinyApp(ui, server)

注意事项 #

• force(i)是必须的，否则所有事件绑定的索引都会指向循环结束的最终值，导致逻辑异常
• 提前绑定1-99的事件监听不会占用过多性能，Shiny只会在对应输入存在时才会触发对应逻辑
• 若需要调整支持的最大地图数量，只需修改循环上限的99为对应数值即可

内容的提问来源于stack exchange，提问作者Brooke Gibbons