html - Shiny R:如何使传单图例水平
问题描述
我正在尝试在带有 Leaflet 地图的 Shiny 应用程序中制作水平图例。
我可以将显示更改为display: flex;
使用使图例水平的 CSS,但我的目标是:
0% - 调色板 - 100%
编辑而不是 -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)```
解决方案
看起来不可能操纵传单图例,因为它被渲染为<svg>
元素和其他一些<divs>
. 我想出了一个潜在的解决方案,其中涉及使用tags$ul
和生成一个新的图例tags$li
。
我编写了一个名为的新函数,它使用和一组值(在本例中使用)legend
为图例生成 html 标记。标记是一个无序列表。所有列表项都是根据指定的数量动态生成的(默认为 7)。用于生成颜色序列的代码改编自 R Leaflet 包:https ://github.com/rstudio/leaflet/blob/master/R/legend.R#L93 。colorNumeric
quakes$mag
<ul>
bins
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)
推荐阅读
- python - 用数据值注释折线图
- python - 如何修复“消息:过时的元素引用:元素未附加到页面文档”
- html - 如何阻止机器人抓取或索引 Angular 应用程序
- spring - 无法使用 Spring 运行 JUnit 测试
- elasticsearch - 在 Elasticsearch 的所有可用索引中搜索特定文档 ID
- php - PHP CodeIgniter 多个 LEFT OUTER 加入查询
- javascript - 下拉项 onClick 未正确显示叠加层
- terminal - 如何从终端打开 2 个铬窗?
- mysql - 尽管我已经有一个 UNIQUE 列,但我应该使用自动增量主键吗?
- assembly - Kernel.c 没有执行完整的代码 [操作系统从头开始]