使用 Shiny R 将反应性弹出图/图添加到传单地图 [英] Adding reactive popup graphs/plots to a Leaflet map with Shiny R

问题描述

我已经构建了一个闪亮的仪表板.用户可以从下拉菜单中选择一个自治市，然后下载该自治市的一系列数据并使用 Leaflet 进行可视化.一个主要的用户需求是点击地图上的一个区域会生成一个包含该区域所有分数的弹出图(见下图)

I have built a Shiny dashboard. The user can select a municipality from a dropdown menu, after which a range of data from that municipality are downloaded and visualized with Leaflet. A main user requirement is that clicking an area on the map generates a popup graph with all the scores for that area (see image below)

这是我的一般方法:

1. 将用户点击的区域名称存储为反应值
2. 在生成 ggplot 图的函数中使用反应值
3. 使用leafpop 包中的addPopupGraphs 函数将ggplot 图添加到弹出窗口

这应该不难，但我已经卡了好几天了.我还尝试生成图表列表(市政府中的每个区域一个)，因为我相信这就是leafpop 的工作原理.然而，再次成功.有没有人能解决我的挣扎?

This shouldn't be so hard, but I have been stuck for days. I have also attempted to generate a list of graphs (one for each area in the municipality), since I believe that is how leafpop works. However, once again to success. Does anyone have a solution to my struggle?

可重现的示例:

library(sf)
library(dplyr)
library(shiny)
library(shinydashboard)
library(leaflet)
library(leafpop)
library(ggplot2)
library(reshape2)

# Let's use this municipality in the example
inputMunicipality = "Landgraaf"

# Download municipality geometry
df <-st_read(URLencode(sprintf("https://geo.leefbaarometer.nl/leefbaarometer/wfs?version=1.0.0&cql_filter=gemeente=%s%s%s&request=GetFeature&typeName=leefbaarometer:wijken_2018&srsName=epsg:4326&outputFormat=json",
                                               "'", inputMunicipality, "'")))[c("WK_NAAM", "WK_CODE")]
# Add some fake scores
df$environmentScore <- sample(10, size = nrow(df), replace = TRUE)
df$facilitiesScore <- sample(10, size = nrow(df), replace = TRUE)
df$housingScore <- sample(10, size = nrow(df), replace = TRUE)
df$safetyScore <- sample(10, size = nrow(df), replace = TRUE)


# Define dashboard UI 
ui <- dashboardPage(
  dashboardHeader(title = "Testing reactive popup on click event!"),
  dashboardSidebar(),
  dashboardBody(
    fluidRow(leafletOutput("myMap")
             )
    )
  )


# Define server logic 
server <- function(input, output) {
  
  # When a person clicks the map, the name of the clicked area is saved in this reactive value
  clickValue <- reactiveValues(areaName=NULL)
  # I then want to use the reactive "clickValue$areaName" in this function to generate a reactive ggplot
  # The reactive ggplot should then be shown as a popup with the addPopupGraphs function
  reactivePopup <- reactive ({
    makePopupPlot(clickValue$areaName, df)
    })
  
  output$myMap <- renderLeaflet({
    leaflet() %>% 
      addProviderTiles(providers$nlmaps.grijs) %>%
      addPolygons(data = df, weight = 1, fillOpacity = 0.3,
                  group = "test", layerId = ~WK_CODE, popup = df$WK_NAAM) %>%
      addPopupGraphs(list(nonReactiveExamplePopup), group = "test", width = 500, height = 200) 
  })
  
  
  # Save the name of a clicked area in a reactive variable
  observeEvent(input$map_shape_click, { 
    event <- input$map_shape_click
    clickAreaName <- df$WK_NAAM[df$WK_CODE == event$id]
    clickValue$areaName <- clickAreaName

  })
}

  
# Run the application 
shinyApp(ui = ui, server = server)


# Function for generation a popup based on the area clicked by the user
makePopupPlot <- function (clickedArea, df) {
  # prepare the df for ggplot
  noGeom <- st_drop_geometry(df)
  plotData <- noGeom[c("WK_NAAM", "environmentScore", "facilitiesScore","housingScore", "safetyScore")]
  plotDataSubset <- subset(plotData, plotData['WK_NAAM'] == clickedArea) 
  plotDataMelt = melt(plotDataSubset, id.vars = "WK_NAAM")
  
  popupPlot <- ggplot(data = plotDataMelt,  aes(x = variable, y = value, fill=value)) + 
    geom_bar(position="stack", stat="identity", width = 0.9) +
    scale_fill_steps2(
      low = "#ff0000",
      mid = "#fff2cc",
      high = "#70ad47",
      midpoint = 5) +
    coord_flip() +
    ggtitle(paste0("Score overview in ", clickedArea)) + 
    theme(legend.position = "none")

  return (popupPlot)
}

# Add this graph to addPopupGraphs(list() to see how I want it to work
nonReactiveExamplePopup <- makePopupPlot("Wijk 00 Schaesberg", df)

推荐答案

如果我理解正确:

library(sf)
library(dplyr)
library(shiny)
library(shinydashboard)
library(leaflet)
library(leafpop)
library(ggplot2)
library(reshape2)


set.seed(1)

# Let's use this municipality in the example
inputMunicipality = "Landgraaf"

# Download municipality geometry
df <-st_read(URLencode(sprintf("https://geo.leefbaarometer.nl/leefbaarometer/wfs?version=1.0.0&cql_filter=gemeente=%s%s%s&request=GetFeature&typeName=leefbaarometer:wijken_2018&srsName=epsg:4326&outputFormat=json",
                               "'", inputMunicipality, "'")))[c("WK_NAAM", "WK_CODE")]
# Add some fake scores
df$environmentScore <- sample(10, size = nrow(df), replace = TRUE)
df$facilitiesScore <- sample(10, size = nrow(df), replace = TRUE)
df$housingScore <- sample(10, size = nrow(df), replace = TRUE)
df$safetyScore <- sample(10, size = nrow(df), replace = TRUE)


# Define dashboard UI 
ui <- dashboardPage(
  dashboardHeader(title = "Testing reactive popup on click event!"),
  dashboardSidebar(),
  dashboardBody(
    fluidRow(leafletOutput("myMap")
    )
  )
)


# Define server logic 
server <- function(input, output) {
  
  # Function for generation a popup based on the area clicked by the user
  makePopupPlot <- function (clickedArea, df) {
    # prepare the df for ggplot
    noGeom <- st_drop_geometry(df)
    plotData <- noGeom[c("WK_NAAM", "environmentScore", "facilitiesScore","housingScore", "safetyScore")]
    plotDataSubset <- subset(plotData, plotData['WK_NAAM'] == clickedArea) 
    plotDataMelt = melt(plotDataSubset, id.vars = "WK_NAAM")
    
    popupPlot <- ggplot(data = plotDataMelt,  aes(x = variable, y = value, fill=value)) + 
      geom_bar(position="stack", stat="identity", width = 0.9) +
      scale_fill_steps2(
        low = "#ff0000",
        mid = "#fff2cc",
        high = "#70ad47",
        midpoint = 5) +
      coord_flip() +
      ggtitle(paste0("Score overview in ", clickedArea)) + 
      theme(legend.position = "none") +
      theme(plot.margin = unit(c(0,0.5,0,0), "cm"), plot.title = element_text(size = 10))
    
    return (popupPlot)
  }
  
  # chart list
  p <- as.list(NULL)
  p <- lapply(1:nrow(df), function(i) {
    p[[i]] <- makePopupPlot(df$WK_NAAM[i], df)
  })
  
  output$myMap <- renderLeaflet({
    leaflet() %>% 
      addProviderTiles(providers$nlmaps.grijs) %>%
      addPolygons(data = df, popup = popupGraph(p, type = "svg")) 
  })
}


# Run the application 
shinyApp(ui = ui, server = server)

这篇关于使用 Shiny R 将反应性弹出图/图添加到传单地图的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！