Shiny Leaflet 地图在切换输入时呈现两次
Shiny Leaflet map renders twice on switching input
我正在尝试使用 Leaflet 制作一个闪亮的应用程序，它根据不同的输入标准呈现等值线图。该地图显示不同类型 (input$type) 和背景 (input$background) 的事件。指定其他类型或背景时，多边形将填充更新的事件数据。它可以正常工作，但有一个障碍。当我将日期输入从日期范围 (input$dateInput) 切换到总统任期 (input$president) 时，总统任期的等值线渲染一次，显示没有数据的多边形，然后再次显示填充有预选期间 ("President1") 的正确数据。如何避免在按下 Presidency 选项卡时出现两次这样的地图渲染？
问题也在 RStudio 社区 here 中列出。
使用的原始数据和shapefile可以在这里访问：https://github.com/cjbarrie/shiny_egy.
工作示例：
原始数据名称：wikiraw
形状文件的名称：shapefile
全球：
library(shiny)
library(shinydashboard)
library(shinythemes)
library(leaflet)
library(rgdal)
library(rmapshaper)
library(sp)
library(dplyr)
library(lubridate)
wikiraw <-read.csv("~/wikisample_SO.csv")
shapefile <- readOGR("~/EGY_adm2.shp")
shapefile<-spTransform(shapefile, CRS("+init=epsg:4326"))
## Simplify shapefile to speed up rendering
shapefile <- ms_simplify(shapefile, keep = 0.01, keep_shapes = TRUE)
wikbounds<-bbox(shapefile)
wikiraw$incident_date <- as.Date(wikiraw$incident_date,
format = "%m/%d/%Y")
wikiraw$presidency <- rep(NA, nrow(wikiraw))
wikiraw$incident_date1 <- as.numeric(wikiraw$incident_date)
wikiraw$event <- rep(1,nrow(wikiraw))
## Generate presidency categorical var.
wikiraw$presidency <- cut(wikiraw$incident_date1,
breaks = c(-Inf, 15016, 15521, 15889, 16229, Inf),
labels = c("President1", "President2", "President3", "President4", "President5"),
right = FALSE)
data.frame 的片段 wikiraw:
ID_2 incident_date incident_background incident_type presidency event
1 168 2013-11-26 Cultural Group President4 1
2 133 2013-11-29 Cultural Group President4 1
3 137 2014-01-25 Cultural Group President4 1
4 168 2011-01-28 Cultural Collective President1 1
5 168 2016-04-25 Cultural Group President5 1
6 163 2015-02-08 Political Individual President5 1
UI:
ui <- dashboardPage(
dashboardHeader(title = "Map tool"),
dashboardSidebar(sidebarMenu(menuItem("Map", tabName = "map"),
selectInput("input_type", "Date input type",
c("Date", "Presidency")),
uiOutput("dateSelect"),
uiOutput("typeSelect"),
uiOutput("backgroundSelect"),
uiOutput("presidentSelect"))),
dashboardBody(tabItems(
tabItem(tabName = "map",
leafletOutput("mymap", height=500)))))
服务器：
server <- function(input, output, session) {
output$dateSelect <- renderUI({
switch(input$input_type,
"Date" = dateRangeInput("dateInput", "Dates:",
min=min(wikiraw$incident_date), max = max(wikiraw$incident_date),
start = min(wikiraw$incident_date), end = max(wikiraw$incident_date)),
"Presidency" = checkboxGroupInput("president", "Presidency",
choices = levels(wikiraw$presidency),
selected = "President1"))
})
output$typeSelect <- renderUI({
selectInput("type", "Incident type",
choices = unique(wikiraw$incident_type), multiple = TRUE,
selected = wikiraw$incident_type[1])})
output$backgroundSelect <- renderUI({
checkboxGroupInput("background", "Incident background",
choices = unique(wikiraw$incident_background),
selected = wikiraw$incident_background[1])})
selected <- reactive({
wikiagg <- wikiraw %>% group_by(ID_2, incident_date, incident_type, incident_background, presidency) %>%
summarize(sum_event = sum(event))
if(input$input_type=="Date"){wikiagg <- filter(wikiagg,
incident_date >= min(input$dateInput),
incident_date <= max(input$dateInput),
incident_type%in%input$type,
incident_background%in%input$background)}
if(input$input_type=="Presidency"){wikiagg <- filter(wikiagg,
incident_type%in%input$type,
incident_background%in%input$background,
presidency%in%input$president)}
wikiagg <- wikiagg %>% group_by(ID_2) %>%
summarize(sum_event = sum(sum_event))
wikiagg
})
output$mymap <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(mean(wikbounds[1,]),
mean(wikbounds[2,]),
zoom=6
)
})
observe({
if(!is.null(input$dateInput)){
shapefile@data <- left_join(shapefile@data, selected(), by="ID_2")
##Define palette across range of data
wikiaggpal <- wikiraw %>% group_by(ID_2) %>%
summarize(sum_event = sum(event))
pal <- colorBin("YlOrRd", wikiaggpal$sum_event, bins=5, na.color = "#bdbdbd")
leafletProxy("mymap", data = shapefile) %>%
addTiles() %>%
clearShapes() %>%
addPolygons(data = shapefile, fillColor = ~pal(sum_event), fillOpacity = 0.7,
color = "white", weight = 2)
}})
}
shinyApp(ui, server)
问题动图：
如有任何帮助，我们将不胜感激！
如果将 reactive 更改为 reactiveValue 并在 observe 中分配数据会怎样？我不知道它是否正常工作，因为我不知道应该使用哪种形状和颜色，但我再也看不到双重渲染了。
(使用问题中的数据和准备)
library(shiny)
library(shinydashboard)
library(shinythemes)
library(leaflet)
library(rgdal)
library(rmapshaper)
library(sp)
library(dplyr)
library(lubridate)
ui <- dashboardPage(
dashboardHeader(title = "Map tool"),
dashboardSidebar(sidebarMenu(menuItem("Map", tabName = "map"),
selectInput("input_type", "Date input type",
c("Date", "Presidency")),
uiOutput("dateSelect"),
uiOutput("typeSelect"),
uiOutput("backgroundSelect"),
uiOutput("presidentSelect"))),
dashboardBody(tabItems(
tabItem(tabName = "map",
leafletOutput("mymap", height=500)))))
server <- function(input, output, session) {
output$dateSelect <- renderUI({
switch(input$input_type,
"Date" = dateRangeInput("dateInput", "Dates:",
min=min(wikiraw$incident_date), max = max(wikiraw$incident_date),
start = min(wikiraw$incident_date), end = max(wikiraw$incident_date)),
"Presidency" = checkboxGroupInput("president", "Presidency",
choices = levels(wikiraw$presidency),
selected = "President1"))
})
output$typeSelect <- renderUI({
selectInput("type", "Incident type",
choices = unique(wikiraw$incident_type), multiple = TRUE,
selected = wikiraw$incident_type[1])})
output$backgroundSelect <- renderUI({
checkboxGroupInput("background", "Incident background",
choices = unique(wikiraw$incident_background),
selected = wikiraw$incident_background[1])})
sel_reactval = reactiveValues(s = NULL)
# selected <- reactive({
observe({
wikiagg <- wikiraw %>% group_by(ID_2, incident_date, incident_type, incident_background, presidency) %>%
summarize(sum_event = sum(event))
if(input$input_type=="Date"){wikiagg <- filter(wikiagg,
incident_date >= min(input$dateInput),
incident_date <= max(input$dateInput),
incident_type%in%input$type,
incident_background%in%input$background)}
if(input$input_type=="Presidency"){wikiagg <- filter(wikiagg,
incident_type%in%input$type,
incident_background%in%input$background,
presidency%in%input$president)}
wikiagg <- wikiagg %>% group_by(ID_2) %>%
summarize(sum_event = sum(sum_event))
sel_reactval$s = wikiagg
# wikiagg
})
output$mymap <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(mean(wikbounds[1,]),
mean(wikbounds[2,]),
zoom=6
)
})
observe({
req(!is.null(input$dateInput))
req(nrow(as.data.frame(sel_reactval$s))!=0)
# if(!is.null(input$dateInput)){
# shapefile@data <- left_join(shapefile@data, selected(), by="ID_2")
shapefile@data <- left_join(shapefile@data, sel_reactval$s, by="ID_2")
##Define palette across range of data
wikiaggpal <- wikiraw %>% group_by(ID_2) %>%
summarize(sum_event = sum(event))
pal <- colorBin("YlOrRd", wikiaggpal$sum_event, bins=5, na.color = "#bdbdbd")
leafletProxy("mymap") %>%
addTiles() %>%
clearShapes() %>%
addPolygons(data = shapefile, fillColor = ~pal(sum_event), fillOpacity = 1,
color = "white", weight = 2)
# }
})
}
shinyApp(ui, server)
我正在尝试使用 Leaflet 制作一个闪亮的应用程序，它根据不同的输入标准呈现等值线图。该地图显示不同类型 (input$type) 和背景 (input$background) 的事件。指定其他类型或背景时，多边形将填充更新的事件数据。它可以正常工作，但有一个障碍。当我将日期输入从日期范围 (input$dateInput) 切换到总统任期 (input$president) 时，总统任期的等值线渲染一次，显示没有数据的多边形，然后再次显示填充有预选期间 ("President1") 的正确数据。如何避免在按下 Presidency 选项卡时出现两次这样的地图渲染？
问题也在 RStudio 社区 here 中列出。
使用的原始数据和shapefile可以在这里访问：https://github.com/cjbarrie/shiny_egy.
工作示例：
原始数据名称：wikiraw
形状文件的名称：shapefile
全球：
library(shiny)
library(shinydashboard)
library(shinythemes)
library(leaflet)
library(rgdal)
library(rmapshaper)
library(sp)
library(dplyr)
library(lubridate)
wikiraw <-read.csv("~/wikisample_SO.csv")
shapefile <- readOGR("~/EGY_adm2.shp")
shapefile<-spTransform(shapefile, CRS("+init=epsg:4326"))
## Simplify shapefile to speed up rendering
shapefile <- ms_simplify(shapefile, keep = 0.01, keep_shapes = TRUE)
wikbounds<-bbox(shapefile)
wikiraw$incident_date <- as.Date(wikiraw$incident_date,
format = "%m/%d/%Y")
wikiraw$presidency <- rep(NA, nrow(wikiraw))
wikiraw$incident_date1 <- as.numeric(wikiraw$incident_date)
wikiraw$event <- rep(1,nrow(wikiraw))
## Generate presidency categorical var.
wikiraw$presidency <- cut(wikiraw$incident_date1,
breaks = c(-Inf, 15016, 15521, 15889, 16229, Inf),
labels = c("President1", "President2", "President3", "President4", "President5"),
right = FALSE)
data.frame 的片段 wikiraw:
ID_2 incident_date incident_background incident_type presidency event
1 168 2013-11-26 Cultural Group President4 1
2 133 2013-11-29 Cultural Group President4 1
3 137 2014-01-25 Cultural Group President4 1
4 168 2011-01-28 Cultural Collective President1 1
5 168 2016-04-25 Cultural Group President5 1
6 163 2015-02-08 Political Individual President5 1
UI:
ui <- dashboardPage(
dashboardHeader(title = "Map tool"),
dashboardSidebar(sidebarMenu(menuItem("Map", tabName = "map"),
selectInput("input_type", "Date input type",
c("Date", "Presidency")),
uiOutput("dateSelect"),
uiOutput("typeSelect"),
uiOutput("backgroundSelect"),
uiOutput("presidentSelect"))),
dashboardBody(tabItems(
tabItem(tabName = "map",
leafletOutput("mymap", height=500)))))
服务器：
server <- function(input, output, session) {
output$dateSelect <- renderUI({
switch(input$input_type,
"Date" = dateRangeInput("dateInput", "Dates:",
min=min(wikiraw$incident_date), max = max(wikiraw$incident_date),
start = min(wikiraw$incident_date), end = max(wikiraw$incident_date)),
"Presidency" = checkboxGroupInput("president", "Presidency",
choices = levels(wikiraw$presidency),
selected = "President1"))
})
output$typeSelect <- renderUI({
selectInput("type", "Incident type",
choices = unique(wikiraw$incident_type), multiple = TRUE,
selected = wikiraw$incident_type[1])})
output$backgroundSelect <- renderUI({
checkboxGroupInput("background", "Incident background",
choices = unique(wikiraw$incident_background),
selected = wikiraw$incident_background[1])})
selected <- reactive({
wikiagg <- wikiraw %>% group_by(ID_2, incident_date, incident_type, incident_background, presidency) %>%
summarize(sum_event = sum(event))
if(input$input_type=="Date"){wikiagg <- filter(wikiagg,
incident_date >= min(input$dateInput),
incident_date <= max(input$dateInput),
incident_type%in%input$type,
incident_background%in%input$background)}
if(input$input_type=="Presidency"){wikiagg <- filter(wikiagg,
incident_type%in%input$type,
incident_background%in%input$background,
presidency%in%input$president)}
wikiagg <- wikiagg %>% group_by(ID_2) %>%
summarize(sum_event = sum(sum_event))
wikiagg
})
output$mymap <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(mean(wikbounds[1,]),
mean(wikbounds[2,]),
zoom=6
)
})
observe({
if(!is.null(input$dateInput)){
shapefile@data <- left_join(shapefile@data, selected(), by="ID_2")
##Define palette across range of data
wikiaggpal <- wikiraw %>% group_by(ID_2) %>%
summarize(sum_event = sum(event))
pal <- colorBin("YlOrRd", wikiaggpal$sum_event, bins=5, na.color = "#bdbdbd")
leafletProxy("mymap", data = shapefile) %>%
addTiles() %>%
clearShapes() %>%
addPolygons(data = shapefile, fillColor = ~pal(sum_event), fillOpacity = 0.7,
color = "white", weight = 2)
}})
}
shinyApp(ui, server)
问题动图：
如有任何帮助，我们将不胜感激！
如果将 reactive 更改为 reactiveValue 并在 observe 中分配数据会怎样？我不知道它是否正常工作，因为我不知道应该使用哪种形状和颜色，但我再也看不到双重渲染了。
(使用问题中的数据和准备)
library(shiny)
library(shinydashboard)
library(shinythemes)
library(leaflet)
library(rgdal)
library(rmapshaper)
library(sp)
library(dplyr)
library(lubridate)
ui <- dashboardPage(
dashboardHeader(title = "Map tool"),
dashboardSidebar(sidebarMenu(menuItem("Map", tabName = "map"),
selectInput("input_type", "Date input type",
c("Date", "Presidency")),
uiOutput("dateSelect"),
uiOutput("typeSelect"),
uiOutput("backgroundSelect"),
uiOutput("presidentSelect"))),
dashboardBody(tabItems(
tabItem(tabName = "map",
leafletOutput("mymap", height=500)))))
server <- function(input, output, session) {
output$dateSelect <- renderUI({
switch(input$input_type,
"Date" = dateRangeInput("dateInput", "Dates:",
min=min(wikiraw$incident_date), max = max(wikiraw$incident_date),
start = min(wikiraw$incident_date), end = max(wikiraw$incident_date)),
"Presidency" = checkboxGroupInput("president", "Presidency",
choices = levels(wikiraw$presidency),
selected = "President1"))
})
output$typeSelect <- renderUI({
selectInput("type", "Incident type",
choices = unique(wikiraw$incident_type), multiple = TRUE,
selected = wikiraw$incident_type[1])})
output$backgroundSelect <- renderUI({
checkboxGroupInput("background", "Incident background",
choices = unique(wikiraw$incident_background),
selected = wikiraw$incident_background[1])})
sel_reactval = reactiveValues(s = NULL)
# selected <- reactive({
observe({
wikiagg <- wikiraw %>% group_by(ID_2, incident_date, incident_type, incident_background, presidency) %>%
summarize(sum_event = sum(event))
if(input$input_type=="Date"){wikiagg <- filter(wikiagg,
incident_date >= min(input$dateInput),
incident_date <= max(input$dateInput),
incident_type%in%input$type,
incident_background%in%input$background)}
if(input$input_type=="Presidency"){wikiagg <- filter(wikiagg,
incident_type%in%input$type,
incident_background%in%input$background,
presidency%in%input$president)}
wikiagg <- wikiagg %>% group_by(ID_2) %>%
summarize(sum_event = sum(sum_event))
sel_reactval$s = wikiagg
# wikiagg
})
output$mymap <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(mean(wikbounds[1,]),
mean(wikbounds[2,]),
zoom=6
)
})
observe({
req(!is.null(input$dateInput))
req(nrow(as.data.frame(sel_reactval$s))!=0)
# if(!is.null(input$dateInput)){
# shapefile@data <- left_join(shapefile@data, selected(), by="ID_2")
shapefile@data <- left_join(shapefile@data, sel_reactval$s, by="ID_2")
##Define palette across range of data
wikiaggpal <- wikiraw %>% group_by(ID_2) %>%
summarize(sum_event = sum(event))
pal <- colorBin("YlOrRd", wikiaggpal$sum_event, bins=5, na.color = "#bdbdbd")
leafletProxy("mymap") %>%
addTiles() %>%
clearShapes() %>%
addPolygons(data = shapefile, fillColor = ~pal(sum_event), fillOpacity = 1,
color = "white", weight = 2)
# }
})
}
shinyApp(ui, server)