How to display (advanced) customed popups for leaflet in Shiny?

Question

I am using R shiny to build web applications, and some of them are leveraging the great leaflet features.

I would like to create a customed and advanced popup, but I do not know how to proceed.

You can see what I can do in the project I created for this post on github, or directly in shinyapp.io here

The more complex the popup is, the weirdest my code is, as I am sort of combining R and html in a strange way (see the way I define my custompopup'i' in server.R)..

Is there a better way to proceed? What are the good practices to build such popups? If I plan to display a chart depending on the marker being clicked, should I build them all in advance, or is that possible to build them 'on the fly'? How can I do that?

Many thanks in advance for your views on this, please do not hesitate to share your answer here or to directly change my github examples!

Regards

Answer 1

I guess this post still has some relevance. So here is my solution on how to add almost any possible interface output to leaflet popups.

We can achieve this doing the following steps:

• Insert the popup UI element as character inside the leaflet standard popup field. As character means, it is no shiny.tag, but merely a normal div. E.g. the classic uiOutput("myID") becomes <div id="myID" class="shiny-html-output"><div>.

• Popups are inserted to a special div, the leaflet-popup-pane. We add an EventListener to monitor if its content changes. (Note: If the popup disappears, that means all children of this div are removed, so this is no question of visibility, but of existence.)

• When a child is appended, i.e. a popup is appearing, we bind all shiny inputs/outputs inside the popup. Thus, the lifeless uiOutput is filled with content like it's supposed to be. (One would've hoped that Shiny does this automatically, but it fails to register this output, since it is filled in by Leaflets backend.)

• When the popup is deleted, Shiny also fails to unbind it. Thats problematic, if you open the popup once again, and throws an exception (duplicate ID). Once it is deleted from the document, it cannot be unbound anymore. So we basically clone the deleted element to a disposal-div where it can be unbound properly and then delete it for good.

I created a sample app that (I think) shows the full capabilities of this workaround and I hope it is designed easy enough, that anyone can adapt it. Most of this app is for show, so please forgive that it has irrelevant parts.

library(leaflet)
library(shiny)

runApp(
  shinyApp(
    ui = shinyUI(
      fluidPage(

        # Copy this part here for the Script and disposal-div
        uiOutput("script"),
        tags$div(id = "garbage"),
        # End of copy.

        leafletOutput("map"),
        verbatimTextOutput("Showcase")
      )
    ),

    server = function(input, output, session){

      # Just for Show
      text <- NULL
      makeReactiveBinding("text")

      output$Showcase <- renderText({text})

      output$popup1 <- renderUI({
        actionButton("Go1", "Go1")
      })

      observeEvent(input$Go1, {
        text <<- paste0(text, "\n", "Button 1 is fully reactive.")
      })

      output$popup2 <- renderUI({
        actionButton("Go2", "Go2")
      })

      observeEvent(input$Go2, {
        text <<- paste0(text, "\n", "Button 2 is fully reactive.")
      })

      output$popup3 <- renderUI({
        actionButton("Go3", "Go3")
      })

      observeEvent(input$Go3, {
        text <<- paste0(text, "\n", "Button 3 is fully reactive.")
      })
      # End: Just for show

      # Copy this part.
      output$script <- renderUI({
        tags$script(HTML('
          var target = document.querySelector(".leaflet-popup-pane");

          var observer = new MutationObserver(function(mutations) {
            mutations.forEach(function(mutation) {
              if(mutation.addedNodes.length > 0){
                Shiny.bindAll(".leaflet-popup-content");
              };
              if(mutation.removedNodes.length > 0){
                var popupNode = mutation.removedNodes[0].childNodes[1].childNodes[0].childNodes[0];

                var garbageCan = document.getElementById("garbage");
                garbageCan.appendChild(popupNode);

                Shiny.unbindAll("#garbage");
                garbageCan.innerHTML = "";
              };
            });    
          });

          var config = {childList: true};

          observer.observe(target, config);
        '))
      })
      # End Copy

      # Function is just to lighten code. But here you can see how to insert the popup.
      popupMaker <- function(id){
        as.character(uiOutput(id))
      }

      output$map <- renderLeaflet({
        leaflet() %>% 
          addTiles() %>%
          addMarkers(lat = c(10, 20, 30), lng = c(10, 20, 30), popup = lapply(paste0("popup", 1:3), popupMaker))
      })
    }
  ), launch.browser = TRUE
)

Note: One might wonder, why the Script is added from the server side. I encountered, that otherwise, adding the EventListener fails, because the Leaflet map is not initialized yet. I bet with some jQuery knowledge there is no need to do this trick.

Solving this has been a tough job, but I think it was worth the time, now that Leaflet maps got some extra utility. Have fun with this fix and please ask, if there are any questions about it!

Answer 2

The answer from K. Rohde is great, and the edit that @krlmlr mentioned should also be used.

I'd like to offer two small improvements over the code that K. Rohde provided (full credit still goes to K. Rohde for coming up with the hard stuff!). Here is the code, and the explanation of the changes will come after:

library(leaflet)
library(shiny)

ui <- fluidPage(
  tags$div(id = "garbage"),  # Copy this disposal-div
  leafletOutput("map"),
  div(id = "Showcase")
)

server <- function(input, output, session) {

  # --- Just for Show ---

  output$popup1 <- renderUI({
    actionButton("Go1", "Go1")
  })

  observeEvent(input$Go1, {
    insertUI("#Showcase", where = "beforeEnd",
             div("Button 1 is fully reactive."))
  })

  output$popup2 <- renderUI({
    actionButton("Go2", "Go2")
  })

  observeEvent(input$Go2, {
    insertUI("#Showcase", where = "beforeEnd", div("Button 2 is fully reactive."))
  })

  output$popup3 <- renderUI({
    actionButton("Go3", "Go3")
  })

  observeEvent(input$Go3, {
    insertUI("#Showcase", where = "beforeEnd", div("Button 3 is fully reactive."))
  })

  # --- End: Just for show ---

  # popupMaker is just to lighten code. But here you can see how to insert the popup.
  popupMaker <- function(id) {
    as.character(uiOutput(id))
  }

  output$map <- renderLeaflet({
    input$aaa
    leaflet() %>%
      addTiles() %>%
      addMarkers(lat = c(10, 20, 30),
                 lng = c(10, 20, 30),
                 popup = lapply(paste0("popup", 1:3), popupMaker)) %>%

      # Copy this part - it initializes the popups after the map is initialized
      htmlwidgets::onRender(
'function(el, x) {
  var target = document.querySelector(".leaflet-popup-pane");

  var observer = new MutationObserver(function(mutations) {
    mutations.forEach(function(mutation) {
      if(mutation.addedNodes.length > 0){
        Shiny.bindAll(".leaflet-popup-content");
      }
      if(mutation.removedNodes.length > 0){
        var popupNode = mutation.removedNodes[0];

        var garbageCan = document.getElementById("garbage");
        garbageCan.appendChild(popupNode);

        Shiny.unbindAll("#garbage");
        garbageCan.innerHTML = "";
      }
    }); 
  });

  var config = {childList: true};

  observer.observe(target, config);
}')
  })
}

shinyApp(ui, server)

The two main changes:

1. The original code would only work if the leaflet map is initialized when the app first starts. But if the leaflet map is initialized later, or inside a tab that isn't initially visible, or if the map gets created dynamically (for example, because it uses some reactive value), then the popups code won't work. In order to fix this, the javasript code needs to be run in htmlwidgets:onRender() that gets called on the leaflet map, as you can see in the code above.

2. This isn't about leaflet, but more of a general good practice: I wouldn't use makeReactiveBinding() + <<- generally. In this case it's being used correctly, but it's easy for people to abuse <<- without understanding what it does so I prefer to stay away from it. An easy almost drop-in replacement for that can be to use text <- reactiveVal(), which would be a better approach in my opinion. But even better than that in this case is instead of using a reactive variable, it's simpler to just use insertUI() like I do above.