利用传单中的点击事件动态显示分组总和

Question

我正在开发一个闪亮的应用程序，具有如下基本功能：

library(sf)
library(DT)
library(leaflet)
library(shiny)
library(tidyverse)

nc <- st_read(system.file("shape/nc.shp", package = "sf"), quiet = T) %>% 
  st_transform(4326) %>% 
  select(NAME, geometry, id = CNTY_ID) %>% 
  mutate(x = rnorm(n = nrow(.), mean = 100, sd = 20),
         fill = sample(c("green", "red"), n(), replace = T),
         fill_2 = if_else(fill == "green", "red", "green"))

# Function to change fill color on click event (taken from https://stackoverflow.com/a/69618323)

change_color <- function(map, id_to_remove, data, colour, new_group){
  leafletProxy(map) %>%
    removeShape(id_to_remove) %>% # remove previous occurrence
    addPolygons(
      data = data,
      layerId = data$id,
      group = new_group, # change group
      fillColor = colour, 
      color = "black", 
      weight = 1,
      fillOpacity = 1)
}


## UI
ui <- fluidPage(
  leafletOutput("map"),
  DT::dataTableOutput("table")
)


## Server
server <- function(input,output,session){
  
# Reactives
rv <- reactiveValues(
    df = nc,
    df.tab = as.data.frame(nc)
  )
  
# Initial map

output$map <- renderLeaflet({
  leaflet() %>% 
    setView(-79.99, 35.52, zoom = 7)
})


observe({
  data <- rv$df
  leafletProxy("map") %>%
    addPolygons(
      data = data,
      weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill, 
      layerId = data$id, 
      group = "unclicked_poly") 
})

#first click
observeEvent(input$map_shape_click, {
  
  # execute only if the polygon has never been clicked
  req(input$map_shape_click$group == "unclicked_poly")
  
  
  # filter data
  data <- rv$df[rv$df$id==input$map_shape_click$id,]
  
  change_color(map = "map", 
               id_to_remove =  input$map_shape_click$id, 
               data = data, 
               colour = ~fill_2, 
               new_group = "clicked1_poly")
  
  
  
})

#second click: reverse first click
observeEvent(input$map_shape_click, {
  req(input$map_shape_click$group == "clicked1_poly")
  
  data <- rv$df[rv$df$id==input$map_shape_click$id,]

  leafletProxy("map") %>%
  removeShape(input$map_shape_click$id) %>% # remove previous occurrence
  addPolygons(
    data = data,
    weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill,
    layerId = data$id,
    group = "unclicked_poly") # back to initialize group
})

output$table <- DT::renderDataTable({
  rv$df.tab %>% 
    group_by(fill) %>% 
    summarise(x = sum(x))

})

}

shinyApp(ui, server)

这里的想法是用户可以通过单击按钮来更改多边形的填充颜色。这按原样工作。但是，我还想在传单地图下方的数据表中动态显示

x

的填充特定总和。目前，该表显示根据初始数据框分组的总和。但是，当用户将多边形从绿色更改为红色时，应该重新进行计算。

我尝试使用类似于

observeEvents()

中的

output(map)

的逻辑来实现这个想法，但这里的问题是我只能访问最后一次点击，因此之前的点击不会影响分组总和计算（

group_by(fill) %>% summarise(x = sum(x)) 

）。理想情况下，我希望获得有关所有多边形的当前填充情况的信息，以便数据表反映用户的输入。

Answer 1

我最终通过四个步骤解决了这个问题：

1. 使用

   reactiveValues(Clicks=vector())

记录多边形上的每次点击
2. 将向量转换为数据框，点击频率由

   table()

决定
3. 使用

   %%

   运算符对点击次数进行模除来确定地图上当前的填充颜色（填充选项的数量远高于我的实际应用程序中的两个）
4. 合并单击和未单击的多边形以获得当前地图状态并使用

   DT::dataTableProxy()

   更新表格

应用程序现在正在按预期运行。代码：

library(sf)
library(DT)
library(leaflet)
library(shiny)
library(tidyverse)

nc <- st_read(system.file("shape/nc.shp", package = "sf"), quiet = T) %>% 
  st_transform(4326) %>% 
  select(NAME, geometry, id = CNTY_ID) %>% 
  mutate(x = rnorm(n = nrow(.), mean = 100, sd = 20),
         fill = sample(c("green", "red"), n(), replace = T),
         fill_2 = if_else(fill == "green", "red", "green"))

# Function to change fill color on click event (taken from https://stackoverflow.com/a/69618323)

change_color <- function(map, id_to_remove, data, colour, new_group){
  leafletProxy(map) %>%
    removeShape(id_to_remove) %>% # remove previous occurrence
    addPolygons(
      data = data,
      layerId = data$id,
      group = new_group, # change group
      fillColor = colour, 
      color = "black", 
      weight = 1,
      fillOpacity = 1)
}


## UI
ui <- fluidPage(
  leafletOutput("map"),
  DT::dataTableOutput("table")
)


## Server
server <- function(input,output,session){
  
# Reactives
rv <- reactiveValues(
    df = nc,
    df.tab = as.data.frame(nc)
  )
  
# Initial map

output$map <- renderLeaflet({
  leaflet() %>% 
    setView(-79.99, 35.52, zoom = 7)
})


observe({
  data <- rv$df
  leafletProxy("map") %>%
    addPolygons(
      data = data,
      weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill, 
      layerId = data$id, label = ~id,
      group = "unclicked_poly") 
})

#first click
observeEvent(input$map_shape_click, {
  
  # execute only if the polygon has never been clicked
  req(input$map_shape_click$group == "unclicked_poly")
  
  
  # filter data
  data <- rv$df[rv$df$id==input$map_shape_click$id,]
  
  change_color(map = "map", 
               id_to_remove =  input$map_shape_click$id, 
               data = data, 
               colour = ~fill_2, 
               new_group = "clicked1_poly")
  
  
  
})

#second click: reverse first click
observeEvent(input$map_shape_click, {
  req(input$map_shape_click$group == "clicked1_poly")
  
  data <- rv$df[rv$df$id==input$map_shape_click$id,]

  leafletProxy("map") %>%
  removeShape(input$map_shape_click$id) %>% # remove previous occurrence
  addPolygons(
    data = data,
    weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill,
    layerId = data$id, label = ~id,
    group = "unclicked_poly") # back to initialize group
})

output$table <- DT::renderDataTable({
  rv$df.tab %>% 
    group_by(fill) %>% 
    summarise(x = sum(x)) -> sum
  
  sum

})

proxy <- DT::dataTableProxy("table")

RV<-reactiveValues(Clicks=vector())

  observeEvent(input$map_shape_click, {
    
    #create object for clicked polygon
    click <- input$map_shape_click
    RV$Clicks<- c(RV$Clicks,click$id)
    test <- as.data.frame(table(RV$Clicks)) %>% 
      mutate(current = Freq %% 2,
             id = as.double(as.character(Var1)))
    

    rv$df.tab %>% 
      full_join(test, by = "id") %>% 
      mutate(fill = case_when(current == 1 ~ fill_2, 
                                  TRUE ~ fill)) %>% 
      group_by(fill) %>% 
      summarise(x = sum(x)) -> sum
    

    proxy %>%  replaceData(sum)
  }) 

}

shinyApp(ui, server)