Shiny R：如何使传单图例水平

Question

我正在尝试使用 Leaflet 地图在 Shiny 应用程序中制作水平图例。

我可以将显示更改为display: flex; 使用 CSS 使图例水平，但我的目标是这样的：

0% - 调色板 - 100%

编辑而不是 -color- 0% -color- 10% - color- 20% 等。

我在 CSS 中没有看到这样做的方法，而且我找不到有关 addLegend 的足够信息来找到解决方案，

这是一个reprex：

library(leaflet)
library(RColorBrewer)

ui <- bootstrapPage(
  tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
  leafletOutput("map", width = "100%", height = "100%"),
  absolutePanel(top = 10, right = 10,
    sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
      value = range(quakes$mag), step = 0.1
    ),
    selectInput("colors", "Color Scheme",
      rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
    ),
    checkboxInput("legend", "Show legend", TRUE)
  )
)

server <- function(input, output, session) {

  # Reactive expression for the data subsetted to what the user selected
  filteredData <- reactive({
    quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
  })

  # This reactive expression represents the palette function,
  # which changes as the user makes selections in UI.
  colorpal <- reactive({
    colorNumeric(input$colors, quakes$mag)
  })

  output$map <- renderLeaflet({
    # Use leaflet() here, and only include aspects of the map that
    # won't need to change dynamically (at least, not unless the
    # entire map is being torn down and recreated).
    leaflet(quakes) %>% addTiles() %>%
      fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
  })

  # Incremental changes to the map (in this case, replacing the
  # circles when a new color is chosen) should be performed in
  # an observer. Each independent set of things that can change
  # should be managed in its own observer.
  observe({
    pal <- colorpal()

    leafletProxy("map", data = filteredData()) %>%
      clearShapes() %>%
      addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
        fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
      )
  })

  # Use a separate observer to recreate the legend as needed.
  observe({
    proxy <- leafletProxy("map", data = quakes)

    # Remove any existing legend, and only if the legend is
    # enabled, create a new one.
    proxy %>% clearControls()
    if (input$legend) {
      pal <- colorpal()
      proxy %>% addLegend(position = "bottomright",
        pal = pal, values = ~mag
      )
    }
  })
}

shinyApp(ui, server)```

Answer 1

看起来不可能操纵传单图例，因为它呈现为<svg>元素和其他一些<divs> 。 我想出了一个潜在的解决方案，涉及使用tags$ul和tags$li生成一个新的图例。

我编写了一个名为legend的新函数，它使用colorNumeric和一些值集（在本例中使用colorNumeric quakes$mag ）为legend生成 html 标记。 标记是一个无序列表<ul> 。 所有列表项都是根据指​​定的bins数量（默认为 7）动态生成的。 用于生成颜色序列的代码改编自 R Leaflet 包： https : //github.com/rstudio/leaflet/blob/master/R/legend.R#L93 。

可以使用输入参数left_label和right_label指定左右标题。 背景颜色是使用style属性定义的。 所有其他样式都使用tags$style定义。

这是一个示例（为了便于阅读，部分代码被剪掉了）。

legend(
    values = quakes$mag,
    palette = "BrBG",
    title = "Magnitude",
    left_label = "0%",
    right_label = "100%"
)
#
# <span class="legend-title">Magnitude</span>
# <ul class="legend">
# <li class="legend-item ..."> 0%</li>
# <li class="legend-item ..." style="background-color: #543005; ..."></li>
# ...

要将图例渲染到应用程序中，您需要在 UI 中创建一个输出元素。 我使用absolutePanel将图例定位到右下角并定义了一个uiOutput元素。

absolutePanel(
    bottom = 20, right = 10, width: "225px;",
    uiOutput("map_legend")
)

在服务器中，我将if (input$colors)的代码替换为：

if (inputs$colors) {
    output$map_legend <- renderUI({
       legend(...)
    })
}

如果未选中该选项，我还添加了一个条件来呈现空白元素。 这是一个屏幕截图，然后是示例。

我唯一想不通的是如何将图例色标与圆圈联系起来。

希望这可以帮助！ 如果您有任何问题，请告诉我。

---

截屏

例子

library(shiny)
library(leaflet)
library(RColorBrewer)

# manually create a legend
legend <- function(values, palette, title, left_label, right_label, bins = 7) {

  # validate args
  stopifnot(!is.null(values))
  stopifnot(!is.null(palette))
  stopifnot(!is.null(title))
  stopifnot(!is.null(left_label))
  stopifnot(!is.null(right_label))

    # generate color palette using Bins (not sure if it's the best approach)
    # @reference: 
    # https://github.com/rstudio/leaflet/blob/c19b0fb9c60d5caf5f6116c9e30dba3f27a5288a/R/legend.R#L93
    pal <- colorNumeric(palette, values)
    cuts <- if (length(bins) == 1) pretty(values, n = bins) else bins
    n <- length(cuts)
    r <- range(values, na.rm = TRUE)
    # pretty cut points may be out of the range of `values`
    cuts <- cuts[cuts >= r[1] & cuts <= r[2]]
    colors <- pal(c(r[1], cuts, r[2]))

  # generate html list object using colors
    legend <- tags$ul(class = "legend")
    legend$children <- lapply(seq_len(length(colors)), function(color) {
      tags$li(
        class = "legend-item legend-color",
        style = paste0(
            "background-color:", colors[color]
          ),
      )
    })

  # add labels to list
  legend$children <- tagList(
    tags$li(
      class = "legend-item legend-label left-label",
      as.character(left_label)
    ),
    legend$children,
    tags$li(
      class = "legend-item legend-label right-label",
      as.character(right_label)
    )
  )

  # render legend with title
  return(
    tagList(
      tags$span(class = "legend-title", as.character(title)),
      legend
    )
  )
}

# ui
ui <- tagList(
    tags$head(
        tags$style(
            "html, body {
                width: 100%;
                height: 100%;
            }",
            ".legend-title {
                display: block;
                font-weight: bold;
            }",
            ".legend {
                list-style: none;
                padding: 0;
                display: flex;
                justify-content: center;
                align-items: center;
            }",
            ".legend-item {
                display: inline-block;
            }",
            ".legend-item.legend-label {
                margin: 0 8px;
            }",
            ".legend-item.legend-color {
                width: 24px;
                height: 16px;
            }"
        )
    ),
    bootstrapPage(
        leafletOutput("map", width = "100%", height = "100%"),
        absolutePanel(
            top = 10, right = 10,
            sliderInput("range", "Magnitudes", min(quakes$mag), max(quakes$mag),
                value = range(quakes$mag), step = 0.1
            ),
            selectInput("colors", "Color Scheme",
                rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
            ),
            checkboxInput("legend", "Show legend", TRUE)
        ),
        absolutePanel(
            bottom = 20,
            right = 10,
            width = "225px",
            uiOutput("map_legend"),
        )
    )
)

server <- function(input, output, session) {

    # Reactive expression for the data subsetted to what the user selected
    filteredData <- reactive({
      quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2],]
    })

    # This reactive expression represents the palette function,
    # which changes as the user makes selections in UI.
    colorpal <- reactive({
      colorNumeric(input$colors, quakes$mag)
    })

    output$map <- renderLeaflet({
        # Use leaflet() here, and only include aspects of the map that
        # won't need to change dynamically (at least, not unless the
        # entire map is being torn down and recreated).
        leaflet(quakes) %>%
            addTiles() %>%
            fitBounds(~min(long), ~min(lat), ~max(long), ~max(lat))
    })

    # Incremental changes to the map (in this case, replacing the
    # circles when a new color is chosen) should be performed in
    # an observer. Each independent set of things that can change
    # should be managed in its own observer.
    observe({
        pal <- colorpal()
        leafletProxy("map", data = filteredData()) %>%
            clearShapes() %>%
            addCircles(radius = ~10^mag/10, weight = 1, color = "#777777",
                       fillColor = ~pal(mag), fillOpacity = 0.7, popup = ~paste(mag)
            )
    })

    # Use a separate observer to recreate the legend as needed.
    observe({
        if (input$legend) {
            output$map_legend <- renderUI({

                # build legend
                legend(
                values = filteredData()[["mag"]],
                palette = as.character(input$colors),
                title = "Mag",
                left_label = "0%",
                right_label = "100%"
                )
            })
        }
        if (!input$legend) {
            output$map_legend <- renderUI({
                tags$div("")
            })
        }
    })
}

shinyApp(ui, server)