如何在闪亮中循环观察事件？单击多边形时更改传单中的样式

Posted 2023-03-24

【中文标题】如何在闪亮中循环观察事件？单击多边形时更改传单中的样式

【英文标题】：How do I loop an observeEvent in shiny? to change style in leaflet when polygons are clicked

【发布时间】：2021-12-26 08:20:13

【问题描述】：

我有一个项目，我正在为之构建一个闪亮的项目。我需要根据输入创建 n 个地图（最多 99 个）。相同的多边形将显示在每张地图上，当用户点击一个多边形时，它会改变多边形的颜色。

到目前为止，我可以根据输入值创建地图数量，但我正在努力研究如何将 observeEvent 放入每个地图的循环中。

下面的例子有效，但我必须写出这两个观察事件 99 次。 请帮忙！

library(leaflet)

## create two square polygons
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) %>% # remove previous occurrence
    addPolygons(
      data = data,
      label = data$display,
      layerId = data$ID,
      group = new_group, # change group
      fillColor = colour)


server <- function(input,output,session)
  
  ## Polygon data
  rv <- reactiveValues(
    df = SpatialPolygonsDataFrame(SpP, data = data.frame(
      ID = c("1", "2"),
      display = c("1", "1")
    ), match.ID = FALSE)
  )
  
  # initialization
  output$map <- renderLeaflet(
    leaflet(options = leafletOptions( zoomControl = FALSE, minZoom = 6.2, maxZoom = 6.2, dragging = 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")
          
        )
      )
  )
  
  # Create plot tag list
  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)
    
  )
  
  
  #first click
  observeEvent(input$plot_1_shape_click, 
    
    # execute only if the polygon has never been clicked
    req(input$plot_1_shape_click$group == "unclicked_poly")
    
    # filter data
    data <- rv$df[rv$df$ID==input$plot_1_shape_click$id,]
    
    change_color(map = "plot_1", 
                 id_to_remove =  input$plot_1_shape_click$id, 
                 data = data, 
                 colour = "yellow", 
                 new_group = "clicked1_poly")
  )

  
  
  #back to normal
  observeEvent(input$plot_1_shape_click, 
    req(input$plot_1_shape_click$group == "clicked1_poly")
    
    data <- rv$df[rv$df$ID==input$plot_1_shape_click$id,]
    
    # back to normal
    leafletProxy("plot_1") %>%
      removeShape(input$plot_1_shape_click$id) %>% # remove previous occurrence
      addPolygons(
        data = data,
        label = as.character(data$display),
        layerId = data$ID,
        group = "unclicked_poly") # back to initialize group
  )


shinyApp(ui, server)

【问题讨论】：

使用lapply(...) 并且只包含一个observeEvent()。您可以在观察者内部使用条件语句。

@YBS 我试过 lapply 但我无法让它工作，你有任何示例代码吗？

【参考方案1】：

 observe (
    lapply(1:input$nomaps, function(i) 
    
      observeEvent(input[[paste0("plot_", i,"_shape_click",sep="")]], 
        # execute only if the polygon has never been clicked
        if (input[[paste0("plot_", i,"_shape_click",sep="")]]$group == "unclicked_poly") 
        
        selected.id <- input[[paste0("plot_", i,"_shape_click",sep="")]]
        
        data <- rv$df[rv$df$ID==selected.id$id,]
        
        change_color(map = paste0("plot_", i, sep=""),
                     id_to_remove =  selected.id$id,
                     data = data,
                     colour = "yellow",
                     new_group = "clicked1_poly") 
         else 
          
          selected.id <- input[[paste0("plot_", i,"_shape_click",sep="")]]
          
          data <- rv$df[rv$df$ID==selected.id$id,]
          
              leafletProxy(paste0("plot_", i, sep="")) %>%
                removeShape(selected.id$id) %>% # remove previous occurrence
                addPolygons(
                  data = data,
                  label = as.character(data$display),
                  layerId = data$ID,
                  group = "unclicked_poly") # back to initialize group
        
      )
    )
    )

【参考方案2】：

试试这个

observe(
    lapply(1:input$nomaps, function(i) 

      observeEvent(input[[paste0("plot_", i,"_shape_click")]], 
        # execute only if the polygon has never been clicked
        selected.id <- input[[paste0("plot_", i,"_shape_click")]]
        data <- rv$df[rv$df$ID==selected.id$id,]
        
        if (selected.id$group == "unclicked_poly") 
          change_color(map = paste0("plot_", i),
                       id_to_remove =  selected.id$id,
                       data = data,
                       colour = "yellow",
                       new_group = "clicked1_poly")
         else 
          leafletProxy(paste0("plot_", i)) %>%
            removeShape(selected.id$id) %>% # remove previous occurrence
            addPolygons(
              data = data,
              label = as.character(data$display),
              layerId = data$ID,
              group = "unclicked_poly") # back to initialize group
        
      )
    )
  )