How to make a Leaflet legend horizontal
I'm trying to make a horizontal legend in a Shiny app with a Leaflet map.
I can change the display to display: flex; using CSS which makes the legend horizontal but what I'm aiming at is something like:
0% - a palette of colors - 100%
edit and NOT -color- 0% -color- 10% - color- 20% etc.
I don't see a way to do that in CSS and I can't find enough info about addLegend to find a solution,
Here's a 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)```
It does not look like it's possible to manipulate the leaflet legend as it's rendered as an <svg> element and a few other <divs>. I came up with a potential solution that involved generating a new legend using tags$ul and tags$li.
I wrote a new function called legend which generates the html markup for a legend using colorNumeric and some set of values (using quakes$mag in this example). The markup is an unordered list <ul>. All list items are generated dynamically based on the number of bins specified (the default is 7). The code used to generate a sequence of colors is adapted from the R Leaflet package: https://github.com/rstudio/leaflet/blob/master/R/legend.R#L93.
Left and right titles can be specified by using the input arguments left_label and right_label. Background colors are defined using the style attribute. All other styles are defined using tags$style.
Here's an example (some of the code is clipped for readability).
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>
# ...
To render the legend into the app, you will need to create an output element in the UI. I used absolutePanel to position the legend into the bottom right corner and defined a uiOutput element.
absolutePanel(
bottom = 20, right = 10, width: "225px;",
uiOutput("map_legend")
)
In the server, I replaced the code in the if (input$colors) with:
if (inputs$colors) {
output$map_legend <- renderUI({
legend(...)
})
}
I also added a condition to render a blank element should the option be unticked. Here's a screenshot followed by the example.
The only thing I couldn't figure out is how to link the legend color scale with the circles.
Hope this helps! Let me know if you have any questions.
Screenshot
Example
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)