r - 具有多个图层的形状单击事件
问题描述
我试图通过单击来自两个不同地图的多边形来将数据加载到两个不同的图上。
我希望用户能够通过单击第一个地图的一个多边形来加载第一个选项卡中的绘图。如果他单击第二个选项卡中的一个多边形，也会发生同样的事情。
我的尝试：
###Reprodutible code:
library(shiny)
library(shinydashboard)
library(tidyr)
library(dplyr)
library(rgdal)
library(tidyverse)
library(leaflet)
#Creation of dummy polygon 1:
Sr1 = Polygon(cbind(c(2,4,4,1,2),c(2,3,5,4,2)))
Sr2 = Polygon(cbind(c(5,4,2,5),c(2,3,2,2)))
Srs1 = Polygons(list(Sr1), "s1")
Srs2 = Polygons(list(Sr2), "s2")
SpP = SpatialPolygons(list(Srs1,Srs2), 1:2)
SpPDF <- SpatialPolygonsDataFrame(SpP, data = data.frame(x=1:length(SpP)), match.ID = F)
Extent = extent(SpPDF)
SpPDF$shapefile_ID<-1:nrow(SpPDF)
#Creation of dummy polygon 2:
SrA = Polygon(cbind(c(12,24,25,45,65),c(45,65,41,22,33)))
SrB = Polygon(cbind(c(55,45,25,55),c(25,35,25,25)))
SrsA = Polygons(list(SrA), "sA")
SrsB = Polygons(list(SrB), "sB")
SpP2 = SpatialPolygons(list(SrsA,SrsB), 1:2)
SpPDF2 <- SpatialPolygonsDataFrame(SpP2, data = data.frame(x=1:length(SpP2)), match.ID = F)
Extent = extent(SpPDF2)
SpPDF2$shapefile_ID<-1:nrow(SpPDF2)
#Creation of dummy dataframe 1:
shapefile_ID <- c('1','2')
x<- c(10, 20)
y <- c(145, 412)
test1 <- data.frame(shapefile_ID, x,y)
#Creation of dummy dataframe 1:
shapefile_ID <- c('1','2')
x2<- c(4, 8)
y2 <- c(12, 154)
test2 <- data.frame(shapefile_ID, x2,y2)
ui <- dashboardPage(dashboardHeader(title="test"),dashboardSidebar(sidebarMenu(menuItem("test", tabname="test"))),dashboardBody(
fluidRow(
box(title = "Test",
width = 12,
status = "info",
solidHeader = T,
collapsible = F,
tabBox(id = "window1", width = 12,
tabPanel("tab1", fluidRow(
column(width = 5, leafletOutput(outputId = "test_map", height = 500)),
column(width = 7, plotOutput(outputId = "plot1", height = 500)
),
)),
tabPanel("tab2", fluidRow(
column(width = 5, leafletOutput(outputId = "test_map2", height = 500)),
column(width = 7, plotOutput(outputId = "plot2", height = 500),
))))))))
server <- function(input, output, session) {
### --------------------------------
rv <- reactiveVal()
output$test_map<-renderLeaflet(
leaflet() %>%
setView(1.23, 5.42, zoom = 4) %>%
addTiles() %>%
addPolygons(data=SpPDF,
fillColor = "blue",
weight = 2,
opacity = 1,
color = "blue",
dashArray = "3",
fillOpacity = 0.3,
highlight = highlightOptions(
weight = 5,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE,
layerId = ~shapefile_ID)
))
observeEvent(input$test_map_shape_click, {
rv(input$test_map_shape_click$id)
})
output$test_map2<-renderLeaflet(
leaflet() %>%
setView(5.33, 45.6, zoom = 2) %>%
addTiles() %>%
addPolygons(data=SpPDF2,
fillColor = "blue",
weight = 2,
opacity = 1,
color = "blue",
dashArray = "3",
fillOpacity = 0.3,
highlight = highlightOptions(
weight = 5,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE,
layerId = ~shapefile_ID)))
observeEvent(input$test_map2_shape_click, {
rv(input$test_map2_shape_click$id)
})
output$plot1 <- renderPlot({
if (is.null(rv())) return (NULL)
test1 %>%
filter(shapefile_ID == rv()) %>%
plot(x = x, y = y)
})
output$plot2 <- renderPlot({
if (is.null(rv())) return (NULL)
test2 %>%
filter(shapefile_ID == rv()) %>%
plot(x = x, y = y)
})
}
shinyApp(ui, server)
有人可以帮我吗？
解决方案
事情不工作：
- layerId 应该是 addPolygons() 函数的参数，而不是 highlightOptions()
- plot() 函数不能按原样进入 dplyr 管道（来源）
完整代码
library(shiny)
library(shinydashboard)
library(tidyr)
library(dplyr)
library(rgdal)
library(tidyverse)
library(leaflet)
#Creation of dummy polygon 1:
Sr1 = Polygon(cbind(c(2,4,4,1,2),c(2,3,5,4,2)))
Sr2 = Polygon(cbind(c(5,4,2,5),c(2,3,2,2)))
Srs1 = Polygons(list(Sr1), "s1")
Srs2 = Polygons(list(Sr2), "s2")
SpP = SpatialPolygons(list(Srs1,Srs2), 1:2)
SpPDF <- SpatialPolygonsDataFrame(SpP, data = data.frame(x=1:length(SpP)), match.ID = F)
Extent = extent(SpPDF)
SpPDF$shapefile_ID<-1:nrow(SpPDF)
#Creation of dummy polygon 2:
SrA = Polygon(cbind(c(12,24,25,45,65),c(45,65,41,22,33)))
SrB = Polygon(cbind(c(55,45,25,55),c(25,35,25,25)))
SrsA = Polygons(list(SrA), "sA")
SrsB = Polygons(list(SrB), "sB")
SpP2 = SpatialPolygons(list(SrsA,SrsB), 1:2)
SpPDF2 <- SpatialPolygonsDataFrame(SpP2, data = data.frame(x=1:length(SpP2)), match.ID = F)
Extent = extent(SpPDF2)
SpPDF2$shapefile_ID<-1:nrow(SpPDF2)
#Creation of dummy dataframe 1:
shapefile_ID <- c('1','2')
x<- c(10, 20)
y <- c(145, 412)
test1 <- data.frame(shapefile_ID, x,y)
#Creation of dummy dataframe 1:
shapefile_ID <- c('1','2')
x2<- c(4, 8)
y2 <- c(12, 154)
test2 <- data.frame(shapefile_ID, x2,y2)
ui <- dashboardPage(dashboardHeader(title="test"),dashboardSidebar(sidebarMenu(menuItem("test", tabname="test"))),dashboardBody(
fluidRow(
box(title = "Test",
width = 12,
status = "info",
solidHeader = T,
collapsible = F,
tabBox(id = "window1", width = 12,
tabPanel("tab1", fluidRow(
column(width = 5, leafletOutput(outputId = "test_map", height = 500)),
column(width = 7, plotOutput(outputId = "plot1", height = 500)
),
)),
tabPanel("tab2", fluidRow(
column(width = 5, leafletOutput(outputId = "test_map2", height = 500)),
column(width = 7, plotOutput(outputId = "plot2", height = 500),
))))))))
server <- function(input, output, session) {
### --------------------------------
rv <- reactiveVal()
output$test_map<-renderLeaflet(
leaflet() %>%
setView(1.23, 5.42, zoom = 4) %>%
addTiles() %>%
addPolygons(data=SpPDF,
layerId = ~shapefile_ID,
fillColor = "blue",
weight = 2,
opacity = 1,
color = "blue",
dashArray = "3",
fillOpacity = 0.3,
highlight = highlightOptions(
weight = 5,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE
)
))
observeEvent(input$test_map_shape_click, {
rv(input$test_map_shape_click$id)
})
output$test_map2<-renderLeaflet(
leaflet() %>%
setView(5.33, 45.6, zoom = 2) %>%
addTiles() %>%
addPolygons(data=SpPDF2,
layerId = ~shapefile_ID,
fillColor = "blue",
weight = 2,
opacity = 1,
color = "blue",
dashArray = "3",
fillOpacity = 0.3,
highlight = highlightOptions(
weight = 5,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE)))
observeEvent(input$test_map2_shape_click, {
rv(input$test_map2_shape_click$id)
})
observe(print(rv()))
output$plot1 <- renderPlot({
if (is.null(rv())) return (NULL)
test1 %>%
filter(shapefile_ID == rv()) %>%
with(plot(x = x, y = y))
})
output$plot2 <- renderPlot({
if (is.null(rv())) return (NULL)
test2 %>%
filter(shapefile_ID == rv()) %>%
with(plot(x = x, y = y))
})
}
shinyApp(ui, server)
推荐阅读
- arrays - 如何分隔列中的值并计算出现次数？
- mips - 如何获取 MIPS 中常量的地址？
- mongodb - 客户端 - 代理信息报告错误：“DEVICE_GROUP_NOT_FOUND”
- ios - AVPlayerItemVideoOutput copyPixelBuffer 总是返回 1280x720
- tensorflow - 为什么具有相似 mAP 的两个推理模型在部署中具有完全不同的性能？
- excel - 使用函数打开和更新外部工作簿中的值，但返回源错误
- asp.net-mvc - ViewData 调用时不显示任何数据
- python - 是否有与 Anaconda 一起安装的适用于 Python 3.7 的适当版本的 Pygame？
- castle-dynamicproxy - 如何在 EF CORE 中获取未代理的对象
- c - 警告：赋值使指针从整数而不进行强制转换 [-Wint-conversion]