Label with multiple elements in Leaflet

[ulfelder]

I'd like to include multiple elements in the marker labels in a Leaflet map I'm creating for a Shiny app. Is there a way to do this without just pasting everything into one big, messy string? Ideally, the elements of these labels would be stacked like a table (albeit without lines or borders).

Here's a toy example. In the code below, I use the message field as the label, but I'd like to be able to show date and count as well. Any thoughts or examples?

library(shiny)
library(dplyr)
library(leaflet)

dat <- data.frame(lat = 39.5,
                  lng = -98.35,
                  message = "Hi, world!",
                  date = Sys.Date(),
                  count = 32,
                  stringsAsFactors = FALSE)

ui <- fluidPage(

  leafletOutput("my_map")  

)

server <- function(input, output) {

  output$my_map <- renderLeaflet({

    leaflet() %>%
      addProviderTiles("Stamen.Toner") %>%
      setView(lat = 39.5, lng = -98.35, zoom = 6) %>%
      addCircleMarkers(data = dat,
                       lat = ~lat, lng = ~lng,
                       label = ~message,
                       radius = 10, fillOpacity = 3/4, stroke = FALSE, color = 'steelblue')

  })

}

shinyApp(ui, server)

[woodward]

I just paste it into one big messy string using html formatting. There's a way of putting a whole formatted table in the popups too but I don't recall it offhand.

[ulfelder]

Thanks. Do you just use "\n " in that string to force line breaks?

[woodward]

It's html so use <br>. I made this poptext in a loop.

poptext = paste(poptext,
                      paste(
                        "<br><b>", 
                        case_when(
                          !is.na(obs_displayname[names(temp)]) ~ unname(obs_displayname[names(temp)]),
                          TRUE ~ names(temp)
                          ), 
                        "</b> = ", 
                        case_when(
                          sapply(temp, is.character) ~ unlist(temp),
                          sapply(temp, is.factor) ~ paste(sapply(temp, as.character), "(mode)"),
                          names(temp) %in% "CHLA92" ~ paste(signif(as_numeric(temp), 3), "(92nd percentile)"),
                          TRUE ~ paste(signif(as_numeric(temp), 3), "(median)")
                        ),
                        collapse = "")
                      )

# This can generate a whole table from the dataframe (this pops up on an AwesomeMarker)

              addAwesomeMarkers(data = df,
                                  ~x, ~y, icon = icons,
                                  popup = ~htmlTable(df[,1:6], rnames = FALSE,
                                                     header = c("Year","M.(GNA/ha)","M.(GNA%)",
                                                                "M.(EQR)", "Soft Mud", "ETI")))

[ulfelder]

Here's a toy version of what I ended up doing, based in part on the helpful guidance from @woodward. The two main parts of the fix were:

1. Creating a new column in the data frame with HTML-ready strings for the complex labels; and
2. Using popup instead of label in the call to addCircleMarkers, because apparently this works better for reasons I don't understand.

library(shiny)
library(dplyr)
library(leaflet)

dat <- data.frame(lat = 39.5,
                  lng = -98.35,
                  message = "Hi, world!",
                  date = Sys.Date(),
                  count = 32,
                  stringsAsFactors = FALSE)

# here's where I make the html-ready compound strings for the labels
dat$label <- with(dat, paste(
  "<p> <b>", message, "</b> </br>",
  date, "</br>",
  "Count:", count,
  "</p>"))


ui <- fluidPage(

  leafletOutput("my_map")  

)

server <- function(input, output) {

  output$my_map <- renderLeaflet({

    leaflet() %>%
      addProviderTiles("Stamen.Toner") %>%
      setView(lat = 39.5, lng = -98.35, zoom = 6) %>%
      addCircleMarkers(data = dat,
                       lat = ~lat, lng = ~lng,
                       popup = ~label,  # and here's where I replaced 'label' with 'popup'
                       radius = 10, fillOpacity = 3/4, stroke = FALSE, color = 'steelblue')

  })

}

shinyApp(ui, server)