Leaflet drill down with RStudio package and Shiny

Question

Is it possible with leaflet.js to create drill-down functionality, i.e. similar to http://jvectormap.com/examples/drill-down/? I imagine there is some plugin that would make this possible. If so, could you point me to an example or provide basic code?

I've done some searching on Google and the leaflet documentation, e.g. http://leafletjs.com/reference.html and http://leafletjs.com/plugins.html, but cannot find anything.

Edit: I found this useful post: https://github.com/rstudio/leaflet/issues/41. I'm using the leaflet package in R provided by RStudio. I've got a drill-down choropleth from country to state with an info control. It still needs a ton of work, though. Anyone who cares to help, see https://github.com/efh0888/leafletDrilldown. The README has all the info you'll need. You can also see a live app at https://efh0888.shinyapps.io/leafletDrilldown. Thanks!

Answer 1

See the Choropleth example for how to do the click⇢fit bounds technique with Leaflet.

Answer 2

There is now an R package "leafdown" available on github, which provides drilldown functionality. It can be found here: https://hoga-it.github.io/leafdown/index.html.

A basic example:

devtools::install_github("hoga-it/leafdown")

library(leafdown)
library(leaflet)
library(shiny)
library(dplyr)
library(shinyjs)
ger1 <- raster::getData(country = "Germany", level = 1)
ger2 <- raster::getData(country = "Germany", level = 2)
ger2@data[c(76, 99, 136, 226), "NAME_2"] <- c(
  "Fürth (Kreisfreie Stadt)",
  "München (Kreisfreie Stadt)",
  "Osnabrück (Kreisfreie Stadt)",
  "Würzburg (Kreisfreie Stadt)"
)
spdfs_list <- list(ger1, ger2)

ui <- shiny::fluidPage(
  tags$style(HTML(".leaflet-container {background: #ffffff;}")),
  useShinyjs(),
  actionButton("drill_down", "Drill Down"),
  actionButton("drill_up", "Drill Up"),
  leafletOutput("leafdown", height = 600),
)


# Little helper function for hover labels
create_labels <- function(data, map_level) {
  labels <- sprintf(
    "<strong>%s</strong><br/>%g € per capita</sup>",
    data[, paste0("NAME_", map_level)], data$GDP_2014
  )
  labels %>% lapply(htmltools::HTML)
}


server <- function(input, output) {
  my_leafdown <- Leafdown$new(spdfs_list, "leafdown", input)
  update_leafdown <- reactiveVal(0)
  
  observeEvent(input$drill_down, {
    my_leafdown$drill_down()
    update_leafdown(update_leafdown() + 1)
  })
  
  observeEvent(input$drill_up, {
    my_leafdown$drill_up()
    update_leafdown(update_leafdown() + 1)
  })
  
  output$leafdown <- renderLeaflet({
    update_leafdown()
    meta_data <- my_leafdown$curr_data
    curr_map_level <- my_leafdown$curr_map_level
    if (curr_map_level == 1) {
      data <- meta_data %>% left_join(gdp_2014_federal_states, by = c("NAME_1" = "Federal_State"))
    } else {
      data <- meta_data %>% left_join(gdp_2014_admin_districts, by = c("NAME_2" = "Admin_District"))
    }
    
    my_leafdown$add_data(data)
    labels <- create_labels(data, curr_map_level)
    my_leafdown$draw_leafdown(
      fillColor = ~ colorNumeric("Blues", GDP_2014)(GDP_2014),
      weight = 2, fillOpacity = 0.8, color = "grey", label = labels,
      highlight = highlightOptions(weight = 5, color = "#666", fillOpacity = 0.7)
    ) %>%
      addLegend("topright",
                pal = colorNumeric("Blues", data$GDP_2014),
                values = data$GDP_2014,
                title = "GDP per capita (2014)",
                labFormat = labelFormat(suffix = "€"),
                opacity = 1
      )
  })
}


shinyApp(ui, server)