Выберите несколько элементов, используя map_click в буклете, связанный с selectizeInput() в блестящем приложении (R)

Я хотел бы создать карту листовок, где вы можете выбрать несколько полигонов, и это обновит selectizeInput() в блестящем приложении. Это включает в себя удаление выбранного полигона, когда он удаляется в selectizeInput().

Я немного изменил/обновил код из ответ здесь (использование sf вместо sp и больше dplyr, где я мог бы определить, что такое база R).

Полигоны, вероятно, могут быть обновлены с помощью observeEvent, связанного с input$clicked_locations, но не знаю, как именно.

Вот код:

library(shiny)
library(leaflet)
library(sf)
library(dplyr)

#load shapefile
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>%
  st_transform(4326)

shinyApp(
  ui = fluidPage(
    
    "Update selectize input by clicking on the map",
    
    leafletOutput("map"),
    "I would like the selectize input to update to show all the locations clicked,",
    "but also when items are removed here, they are removed on the map too, so linked to the map.",
    selectizeInput(inputId = "clicked_locations",
                   label = "Clicked",
                   choices = nc$NAME,
                   selected = NULL,
                   multiple = TRUE)
  ),
  
  server <- function(input, output, session){
    
    #create empty vector to hold all click ids
    clicked_ids <- reactiveValues(ids = vector())
    
    #initial map output
    output$map <- renderLeaflet({
      leaflet() %>%
        addTiles() %>%
        addPolygons(data = nc,
                    fillColor = "white",
                    fillOpacity = 0.5,
                    color = "black",
                    stroke = TRUE,
                    weight = 1,
                    layerId = ~NAME,
                    group = "regions",
                    label = ~NAME)
    }) #END RENDER LEAFLET
    
    observeEvent(input$map_shape_click, {
      
      #create object for clicked polygon
      click <- input$map_shape_click
      
      #define leaflet proxy for second regional level map
      proxy <- leafletProxy("map")
      
      #append all click ids in empty vector
      clicked_ids$ids <- c(clicked_ids$ids, click$id) # name when clicked, id when unclicked
      
      #shapefile with all clicked polygons - original shapefile subsetted by all admin names from the click list
      clicked_polys <- nc %>%
        filter(NAME %in% clicked_ids$ids)
      
      #if the current click ID [from CNTY_ID] exists in the clicked polygon (if it has been clicked twice)
      if(click$id %in% clicked_polys$CNTY_ID){
        
        #define vector that subsets NAME that matches CNTY_ID click ID - needs to be different to above
        name_match <- clicked_polys$NAME[clicked_polys$CNTY_ID == click$id]
        
        #remove the current click$id AND its name match from the clicked_polys shapefile
        clicked_ids$ids <- clicked_ids$ids[!clicked_ids$ids %in% click$id]
        clicked_ids$ids <- clicked_ids$ids[!clicked_ids$ids %in% name_match]
        
        # just to see
        print(clicked_ids$ids)
        
        # update
        updateSelectizeInput(session,
                             inputId = "clicked_locations",
                             label = "",
                             choices = nc$NAME,
                             selected = clicked_ids$ids)
        
        #remove that highlighted polygon from the map
        proxy %>% removeShape(layerId = click$id)
        
      } else {
        
        #map highlighted polygons
        proxy %>% addPolygons(data = clicked_polys,
                              fillColor = "red",
                              fillOpacity = 0.5,
                              weight = 1,
                              color = "black",
                              stroke = TRUE,
                              layerId = clicked_polys$CNTY_ID)
        
        # just to see
        print(clicked_ids$ids)
        
        # update
        updateSelectizeInput(session,
                             inputId = "clicked_locations",
                             label = "",
                             choices = nc$NAME,
                             selected = clicked_ids$ids)
        
      } #END CONDITIONAL
    }) #END OBSERVE EVENT
  }) #END SHINYAPP

Это также опубликовано здесь, где вы также можете найти отредактированную версию кода из ответа (первоначально набор данных sp), который работает. Этот код для набора данных nc мне кажется таким же, но не работает, хотя обновления полигонов на основе selectizeInput() там нет.

Любые идеи по этому поводу?

введите здесь описание изображения


person william3031    schedule 25.01.2021    source источник


Ответы (1)


См. следующий обходной путь:

Я добавляю все полигоны при рендеринге карты и скрываю красное наложение. Кроме того, каждый из красных полигонов относится к своей группе. При щелчке по соответствующей группе полигон отображается/скрывается.

library(shiny)
library(leaflet)
library(sf)
library(dplyr)

#load shapefile
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>%
  st_transform(4326)

shinyApp(
  ui = fluidPage(
    
    "Update selectize input by clicking on the map",
    
    leafletOutput("map"),
    "I would like the selectize input to update to show all the locations selected,",
    "but also when items are removed here, they are removed on the map too, so linked to the map.",
    selectizeInput(inputId = "selected_locations",
                   label = "selected",
                   choices = nc$NAME,
                   selected = NULL,
                   multiple = TRUE)
  ),
  
  server <- function(input, output, session){
    
    #create empty vector to hold all click ids
    selected_ids <- reactiveValues(ids = vector())
    
    #initial map output
    output$map <- renderLeaflet({
      leaflet() %>%
        addTiles() %>%
        addPolygons(data = nc,
                    fillColor = "white",
                    fillOpacity = 0.5,
                    color = "black",
                    stroke = TRUE,
                    weight = 1,
                    layerId = ~NAME,
                    group = "regions",
                    label = ~NAME) %>%
        addPolygons(data = nc,
                    fillColor = "red",
                    fillOpacity = 0.5,
                    weight = 1,
                    color = "black",
                    stroke = TRUE,
                    layerId = ~CNTY_ID,
                    group = ~NAME) %>%
        hideGroup(group = nc$NAME) # nc$CNTY_ID
    }) #END RENDER LEAFLET
    
    #define leaflet proxy for second regional level map
    proxy <- leafletProxy("map")
    
    #create empty vector to hold all click ids
    selected <- reactiveValues(groups = vector())
    
    observeEvent(input$map_shape_click, {
      if(input$map_shape_click$group == "regions"){
        selected$groups <- c(selected$groups, input$map_shape_click$id)
        proxy %>% showGroup(group = input$map_shape_click$id)
      } else {
        selected$groups <- setdiff(selected$groups, input$map_shape_click$group)
        proxy %>% hideGroup(group = input$map_shape_click$group)
      }
      updateSelectizeInput(session,
                           inputId = "selected_locations",
                           label = "",
                           choices = nc$NAME,
                           selected = selected$groups)
    })
    
    observeEvent(input$selected_locations, {
      removed_via_selectInput <- setdiff(selected$groups, input$selected_locations)
      added_via_selectInput <- setdiff(input$selected_locations, selected$groups)
      
      if(length(removed_via_selectInput) > 0){
        selected$groups <- input$selected_locations
        proxy %>% hideGroup(group = removed_via_selectInput)
      }
      
      if(length(added_via_selectInput) > 0){
        selected$groups <- input$selected_locations
        proxy %>% showGroup(group = added_via_selectInput)
      }
    }, ignoreNULL = FALSE)
    
  })

результат


Изменить: относительно вашего первоначального подхода к адаптации этот ответ вам нужно будет передать layerId как character, чтобы все снова заработало:

    proxy %>% removeShape(layerId = as.character(click$id))
    
    proxy %>% addPolygons(data = clicked_polys,
                          fillColor = "red",
                          fillOpacity = 0.5,
                          weight = 1,
                          color = "black",
                          stroke = TRUE,
                          layerId = as.character(clicked_polys$CNTY_ID))

Я отправил проблему по этому поводу.

Тем не менее, я бы все же предпочел описанный выше подход с отображением/скрытием, поскольку я думаю, что он более эффективен, чем добавление и удаление полигонов.

person ismirsehregal    schedule 28.01.2021
comment
Это отлично. Спасибо. Я также добавлю награду, когда мне будет позволено. - person william3031; 29.01.2021
comment
Одно примечание: вы можете удалить все элементы из selectizeInput (вместо того, чтобы не щелкнуть мышью), но последний полигон останется на карте. - person william3031; 29.01.2021
comment
Ах, я вижу - нам нужно установить ignoreNULL = FALSE для наблюдателя selectize, иначе последнее удаление будет проигнорировано. Пожалуйста, смотрите мое редактирование. Ваше здоровье - person ismirsehregal; 29.01.2021
comment
Отлично. Спасибо за вашу помощь. - person william3031; 29.01.2021