3

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)```
Improve this question

1 Answer 1

Reset to default
2

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

enter image description here

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)
Improve this answer

Not the answer you're looking for? Browse other questions tagged or ask your own question.