[英]Shiny R: How to make a Leaflet legend horizontal
我正在嘗試使用 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)```
看起來不可能操縱傳單圖例,因為它呈現為<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)
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.