R leaflet - Показать / Скрыть элемент addControl () с групповыми слоями

Question

У меня есть листовка, которая использует пользовательскую легенду с использованием HTML и добавлена ​​с использованием функции addControl (следующая: Leaflet Legend для пользовательских маркеров в R ).

Однако я хочу, чтобы легенда отображалась только при показе одной группы, я попытался использовать аргумент group = "group name", который не работает с функцией addControl. Я также пытался использовать layerId аргументы, но безуспешно.

Есть идеи?

Воспроизводимый пример:

library(leaflet)
# Sample Data
data(quakes)
quakes <- quakes[1:10,]

# Choose Icon:
leafIcons <- icons(
  iconUrl = ifelse(quakes$mag < 4.6,
               "http://leafletjs.com/docs/images/leaf-green.png",
               "http://leafletjs.com/docs/images/leaf-red.png"
 ),
  iconWidth = 38, iconHeight = 95,
  iconAnchorX = 22, iconAnchorY = 94)

html_legend <- "<img src='http://leafletjs.com/docs/images/leaf-
green.png'>green<br/>
<img src='http://leafletjs.com/docs/images/leaf-red.png'>red"

# Produce Map:
leaflet(data = quakes) %>% addTiles() %>%
  addMarkers(~long, ~lat, icon = leafIcons, group = "Group A") %>%
  addMarkers(~long, ~lat, icon = leafIcons, group = "Group B") %>%
  addControl(html = html_legend, position = "bottomleft") %>%
  addLayersControl(position = "topleft", overlayGroups = c("Group A","Group B"))

Где бы я хотел, чтобы элемент addControl html_legend был виден только тогда, когда видима группа А.

Answer 1

Хорошо, теперь я думаю, что понимаю вашу проблему. Ниже приведен еще один пример, который показывает только легенду и контроль над активными группами. Для этого я создал 2 html_legends для группы A и группы B.

library(shiny)
library(leaflet)

html_legend_A <- "<img src='http://leafletjs.com/docs/images/leaf-green.png'>green<br/>"
html_legend_B <- "<img src='http://leafletjs.com/docs/images/leaf-red.png'>red<br/>"

ui <- fluidPage(
  leafletOutput("map")
)
server <- function(input, output, session){
  output$map <- renderLeaflet({
    map <- leaflet(data = quakes) %>% addTiles() %>%
      addMarkers(~long, ~lat, icon = leafIcons, group = "Group A", layerId = "A") %>%
      addMarkers(~long, ~lat, icon = leafIcons, group = "Group B", layerId = "B") %>%
      addLayersControl(position = "topleft", overlayGroups = c("Group A","Group B"))
    map
  })

  observe({
    map <- leafletProxy("map") %>% clearControls()
    if (any(input$map_groups %in% "Group A")) {
      map <- map %>% 
        addControl(html = html_legend_A, layerId = "A", position = "bottomleft") %>% 
        addLegend(title="Group A", position="bottomright", opacity=1, colors="green",labels = "Group A")}
    if (any(input$map_groups %in% "Group B")) {
      map <- map %>% 
        addControl(html = html_legend_B, layerId = "B", position = "bottomleft") %>% 
        addLegend(title="Group B", position="bottomright", opacity=1,colors="red",labels = "Group B")}
  })
}

shinyApp(ui, server)

При использовании аргумента LayerId отображается только 1 маркер на группу. Если вы хотите увидеть все маркеры, аргумент LayerId указывать не следует. Я сделал вам еще один пример. Я думаю, что это должно быть прямо сейчас :) Я также создаю 2 иконки и фильтрую данные о землетрясениях на основе mag-столбца внутри функции renderLeaflet, как вы делаете в назначении иконок.

library(shiny)
library(leaflet)

data(quakes)
quakes <- quakes[1:10,]

leafIcons_A <- icons(
  iconUrl = "https://leafletjs.com/examples/custom-icons/leaf-green.png",
  iconWidth = 38, iconHeight = 95,
  iconAnchorX = 22, iconAnchorY = 94)
leafIcons_B <- icons(
  iconUrl = "https://leafletjs.com/examples/custom-icons/leaf-red.png",
  iconWidth = 38, iconHeight = 95,
  iconAnchorX = 22, iconAnchorY = 94)

html_legend_A <- "<img src='https://leafletjs.com/examples/custom-icons/leaf-green.png'>green<br/>"
html_legend_B <- "<img src='https://leafletjs.com/examples/custom-icons/leaf-red.png'>red<br/>"

ui <- fluidPage(
  leafletOutput("map")
)
server <- function(input, output, session){
  output$map <- renderLeaflet({
    dataA <- quakes[quakes$mag < 4.6,]
    dataB <- quakes[quakes$mag > 4.6,]

    map <- leaflet() %>% addTiles() %>%
      addMarkers(dataA$long, dataA$lat, icon = leafIcons_A, group = "Group A") %>%
      addMarkers(dataB$long, dataB$lat, icon = leafIcons_B, group = "Group B") %>%
      addLayersControl(position = "topleft", overlayGroups = c("Group A","Group B"))
    map
  })

  observe({
    map <- leafletProxy("map") %>% clearControls()
    if (any(input$map_groups %in% "Group A")) {
      map <- map %>%
        addControl(html = html_legend_A, position = "bottomleft") %>%
        addLegend(title="Group A", position="bottomright", opacity=1, colors="green",labels = "Group A")}
    if (any(input$map_groups %in% "Group B")) {
      map <- map %>%
        addControl(html = html_legend_B, position = "bottomleft") %>%
        addLegend(title="Group B", position="bottomright", opacity=1,colors="red",labels = "Group B")}
  })
}

shinyApp(ui, server)

Answer 2

Вы пытаетесь сделать Shiny-App из этого? Я написал что-то похожее для Siny-App, где отображаются только легенды о кликнувших группах.

Если оно не должно быть блестящим приложением, вы можете сделать что-то вроде этого (вы должны назначить карту листовки для переменной (в данном случае «map»). Таким образом, вы можете вызвать ее и впоследствии адаптировать.

map <- leaflet(data = quakes) %>% addTiles() %>%
  addMarkers(~long, ~lat, icon = leafIcons, group = "Group A") %>%
  addMarkers(~long, ~lat, icon = leafIcons, group = "Group B") %>%
  addControl(html = html_legend, position = "bottomleft") %>%
  addLayersControl(position = "topleft", overlayGroups = c("Group A","Group B"))

groups <- map$x$calls[[5]]$args[[2]]
activeGroup <- map$x$calls[[3]]$args[[5]]

if (any(activeGroup %in% "Group A")) {
  map %>% addLegend(title="Group A", position="bottomright", opacity=1, colors="red",
                           labels = "Group A")}

if (any(activeGroup %in% "Group B")) {
   map %>% addLegend(title="Group B", position="bottomright", opacity=1,colors="green",
                           labels = "Group B")} 

Переменная groups хранит все группы, которые находятся под рукой, а activeGroup хранит группы, которые активны в данный момент. Затем вы можете использовать его с некоторыми операторами if-else, чтобы показать только легенду активной группы.

Хотя он не будет интерактивным, как обычный R-скрипт. Вы должны были бы повторно вызвать activeGroup-call, чтобы проверить, какие группы все еще активны. В Shiny эта интерактивность будет дана.

Вот вам реализация блестящего приложения:

ui <- fluidPage(
  leafletOutput("map")
)
server <- function(input, output, session){
  output$map <- renderLeaflet({
    map <- leaflet(data = quakes) %>% addTiles() %>%
      addMarkers(~long, ~lat, icon = leafIcons, group = "Group A") %>%
      addMarkers(~long, ~lat, icon = leafIcons, group = "Group B") %>%
      addControl(html = html_legend, position = "bottomleft")
      addLayersControl(position = "topleft", overlayGroups = c("Group A","Group B"))
    map
  })

  observe({
    map <- leafletProxy("map") %>% clearControls()

    if (any(input$map_groups %in% "Group A")) {
      map <- map %>% addLegend(title="Group A", position="bottomright", opacity=1, colors="red",labels = "Group A")}
    if (any(input$map_groups %in% "Group B")) {
      map <- map %>% addLegend(title="Group B", position="bottomright", opacity=1,colors="green",labels = "Group B")}
  })
}

shinyApp(ui, server)