在 R + Shiny 中钻取地图答案

【问题标题】：Drill Down Maps In R + Shiny在 R + Shiny 中钻取地图
【发布时间】：2016-09-16 05:21:17
【问题描述】：

我想实现美国的深入研究热图。比如：Highchart link

但我想在给定的向下钻取热图中显示我自己的数据

R + 闪亮。

我无法理解如何让我的数据与给定的示例一起使用。我能够在 R shiny 上实现给定的示例，但我不知道如何获取我自己的 states 和 County 数据。我有想要在地图上显示的 excel 格式的数据。

我对 JS 和 CSS 比较陌生，我认为挑战仅在于这一点。我对AJAX一无所知，如果没有它也能实现，那就太好了。

有人建议我使用 JSON 文件导入自己的数据，但我做不到。

【问题讨论】：

你尝试了什么？你有一些代码要显示吗？
在向下钻取事件中，地图已加载，您可以将数据推送到那里 - see in code。请澄清这里的问题是什么，因为现在它看起来像是对项目的请求。

标签： r highcharts shiny heatmap drilldown

【解决方案1】：

现在 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)

【讨论】：