使用 RStudio 包和 Shiny 深入了解传单答案

【问题标题】：Leaflet drill down with RStudio package and Shiny使用 RStudio 包和 Shiny 深入了解传单
【发布时间】：2015-02-09 23:25:39
【问题描述】：

leaflet.js 是否可以创建向下钻取功能，即类似于http://jvectormap.com/examples/drill-down/？我想有一些插件可以使这成为可能。如果是这样，你能给我举个例子或提供基本代码吗？

我在 Google 和传单文档上进行了一些搜索，例如http://leafletjs.com/reference.html 和 http://leafletjs.com/plugins.html，但找不到任何东西。

编辑：我发现这个有用的帖子：https://github.com/rstudio/leaflet/issues/41。我正在使用 RStudio 提供的 R 中的传单包。我有一个从一个国家到另一个州的向下钻取，带有信息控制。不过，它仍然需要大量的工作。任何愿意提供帮助的人，请参阅https://github.com/efh0888/leafletDrilldown。自述文件包含您需要的所有信息。您还可以在https://efh0888.shinyapps.io/leafletDrilldown 上查看实时应用程序。谢谢！

【问题讨论】：

标签： r shiny leaflet

【解决方案1】：

请参阅Choropleth example，了解如何使用 Leaflet 执行 click⇢fit 边界技术。

【讨论】：

谢谢！这让我走到了一半。你知道有什么方法可以深入到一个新层，例如我点击德克萨斯，它不仅放大了德克萨斯，而且还从州到县层？

【解决方案2】：

现在 github 上提供了一个 R 包“leafdown”，它提供了向下钻取功能。可以在这里找到：https://hoga-it.github.io/leafdown/index.html。

一个基本的例子：

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)

【讨论】：

不要发布工具或库的链接作为答案。在答案本身中展示how it solves the problem。回答edit，并在添加演示后标记为取消删除。