Question

我正在尝试在具有Leaflet贴图的Shiny应用程序中制作水平图例。

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

0％-调色板-100％

edit 和非-color- 0％-color- 10％-color- 20％等。

我在CSS中看不到做到这一点的方法，也找不到关于addLegend的足够信息来找到解决方案，

这里是一个代表：

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和一组值（在本示例中使用quakes$mag）为图例生成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)

闪亮的R：如何水平制作传单图例

1 个答案: