闪亮的传单不适用于动态菜单
Posted
技术标签:
【中文标题】闪亮的传单不适用于动态菜单【英文标题】：Shiny leaflet doesn't work properly with dynamic menu 【发布时间】：2018-05-29 14:55:41 【问题描述】：我一直在努力解决这个问题一段时间，但没有成功。我想用表格和地图构建一个闪亮的交互式应用程序。它结合了不同的数据集。这个想法是能够选择所需的数据集并过滤该数据集中的数据并将它们呈现在地图上。
我设法构建了一个交互式菜单和反应式过滤功能，但是传单地图有问题。当我在一些数据集之间切换时，它会崩溃。我只能在 localisations-macro 或 localisations-micro 之间切换，但是当我在 micro 和 macro 之间切换时它不会起作用（见下图）。
问题与错误有关：
Warning: Error in sum: invalid 'type' (list) of argument 不过我现在知道如何解决这个问题了。
我也在observerEvent 中尝试过类似的操作
：
if(inpud$data.type=="Localisations").....
else if (input$data.type=="Micro").....
else
但也不行。
以下是应用示例：
library(shiny)
library(leaflet)
library(dplyr)
#### UI
ui <- fluidPage(
titlePanel("Map"),
leafletOutput("map"),
fluidRow(
column(2, offset = 0, style='padding:10px;',
radioButtons("data.type", "Type of data", c("Localisations", "Micro", "Macro"))),
column(2, offset = 0, style='padding:10px;',
uiOutput("position")),
column(2, offset = 0, style='padding:10px;',
uiOutput("kind"))
),
dataTableOutput("table") ## to check the filtering
)
server <- function(input, output, session)
##### data #####
sites <- data.frame(Site=c("Site1", "Site2"),
Lat=c(54, 56),
Long=c(16, 18))
micro <- data.frame(Site=c(rep("Site1",4), rep("Site2", 4)),
Position=c("Micro_pos1","Micro_pos1", "Micro_pos2", "Micro_pos2"),
Kind=rep(c("blue_fiber", "red_fiber"), 4),
Amount=c(5, 46, 64, 32, 54, 38, 29, 31) )
micro <- full_join(micro, sites)
macro <- data.frame(Site=c(rep("Site1",4), rep("Site2", 4)),
Position=c("Macro_pos1","Macro_pos1", "Macro_pos2", "Macro_pos2"),
Kind=rep(c("Cigarretes", "Pellets"), 4),
Amount=c(3, 16, 4, 12, 14, 18, 19, 21) )
macro <- full_join(macro, sites)
#### dynamic menu ####
### position
output$position <- renderUI(
switch(input$data.type,
"Micro"=radioButtons("position", "Micro position:",
choices = c("Micro_pos1", "Micro_pos2")),
"Macro"=radioButtons("position", "Macro position:",
choices = c("Macro_pos1", "Macro_pos2"))
)
)
## kind
output$kind <- renderUI(
switch(input$data.type,
"Micro"=checkboxGroupInput("kind", "kind of micro:",
choices = c("blue_fiber", "red_fiber"),
selected = c("blue_fiber", "red_fiber")),
"Macro"=checkboxGroupInput("kind", "kind of macro:",
choices = c("Cigarretes", "Pellets"),
selected=c("Cigarretes", "Pellets"))
)
)
#### reactive table to filter data to map ####
table <- reactive(
if(input$data.type=="Localisations")
return(sites)
else if (input$data.type=="Micro")
if (is.null(input$position))
return(NULL)
if (!is.null(input$position))
micro <-micro[micro$Position==input$position,]
micro<-micro[micro$Kind %in% input$kind,]
micro <- micro %>%
group_by(Site, Lat, Long, Position)%>%
summarise(Amount=sum(Amount))
micro
else if (input$data.type=="Macro")
if (is.null(input$position))
return(NULL)
if (!is.null(input$position))
macro <-macro[macro$Position==input$position,]
macro<-macro[macro$Kind %in% input$kind,]
macro <- macro %>%
group_by(Site, Lat, Long, Position)%>%
summarise(Amount=sum(Amount))
macro
)
#### table with filtered data ####
output$table <- renderDataTable(
table()
)
#### base map ####
output$map <- renderLeaflet(
leaflet(sites) %>%
setView(lat=55, lng=17, zoom=6) %>%
addProviderTiles(providers$Esri.WorldImagery) %>%
addCircleMarkers(lng=~Long, lat=~Lat, label=~Site,
labelOptions = labelOptions(noHide =T))
)
##### and now it gets complicated :( ####
observeEvent( c( input$data.type, input$position, input$kind),
if(input$data.type=="Localisations")
leafletProxy("map", data=sites) %>%
clearMarkers() %>%
clearShapes()%>%
addCircleMarkers(lng=~Long, lat=~Lat, label=~Site,
labelOptions = labelOptions(noHide =T), fillColor = "red")
else
if (is.null(input$position))
return(NULL)
if (is.null(input$kind))
return(NULL)
leafletProxy("map", data=table()) %>%
clearMarkers() %>%
clearShapes()%>%
addCircles(lng=~Long, lat=~Lat, label=~Site, color="white", fill="white",
labelOptions = labelOptions(noHide =T),
radius = ~Amount*1000) %>%
addLabelOnlyMarkers(lng=~Long, lat=~Lat, label=~as.character(Amount),
labelOptions = labelOptions(noHide = T, direction = 'top', textOnly = T, textsize="20px"))
)
### server end
# Run the application
shinyApp(ui = ui, server = server)
【问题讨论】：
【参考方案1】：问题在于时机：
当您从微切换到宏时，input$kind 仍设置为仅适用于微的值 然后调用 table() 来创建地图。它过滤macro[macro$Kind %in% input$kind,]，这将导致一个空集，因为 input$kind 仍然包含红色和蓝色纤维，而不是“Cigarretes”和“Pellets”
您使用
更新选择框output$kind <- renderUI(
switch(input$data.type,
"Micro"=checkboxGroupInput("kind", "kind of micro:",
choices = c("blue_fiber", "red_fiber"),
selected = c("blue_fiber", "red_fiber")),
"Macro"=checkboxGroupInput("kind", "kind of macro:",
choices = c("Cigarretes", "Pellets"),
selected=c("Cigarretes", "Pellets"))
)
)
但这仅在调用 table() 后对 input$kind 产生影响。
我想到的第一个解决方案是通过提交按钮而不是通过对 input$kind、input$data.type 和 input$position 的每次更改来触发对 table() 的调用。所以 table() 将成为一个非反应性函数，并且创建地图的观察者observeEvent( c( input$data.type, input$position, input$kind), ...) 发生了变化：
所以包括一个操作按钮： ui
leafletOutput("map"),
fluidRow(
column(2, offset = 0, style='padding:10px;',
radioButtons("data.type", "Type of data", c("Localisations",
"Micro", "Macro"))),
column(2, offset = 0, style='padding:10px;',
uiOutput("position")),
column(2, offset = 0, style='padding:10px;',
uiOutput("kind"))
),
actionButton("button", "submit"),
dataTableOutput("table") ## to check the filtering
)
然后改表函数：
table <- function()
if(input$data.type=="Localisations")
return(sites)
else if (input$data.type=="Micro")
if (is.null(input$position))
return(NULL)
if (!is.null(input$position))
micro <-micro[micro$Position==input$position,]
micro<-micro[micro$Kind %in% input$kind,]
micro <- micro %>%
group_by(Site, Lat, Long, Position)%>%
summarise(Amount=sum(Amount))
micro
else if (input$data.type=="Macro")
if (is.null(input$position))
return(NULL)
if (!is.null(input$position))
macro <-macro[macro$Position==input$position,]
macro<-macro[macro$Kind %in% input$kind,]
macro <- macro %>%
group_by(Site, Lat, Long, Position)%>%
summarise(Amount=sum(Amount))
macro
最后调整观察者：
observeEvent( input$button,
if(input$data.type=="Localisations")
leafletProxy("map", data=sites) %>%
clearMarkers() %>%
clearShapes()%>%
addCircleMarkers(lng=~Long, lat=~Lat, label=~Site,
labelOptions = labelOptions(noHide =T), fillColor = "red")
else
if (is.null(input$position))
return(NULL)
if (is.null(input$kind))
return(NULL)
leafletProxy("map", data=table()) %>%
clearMarkers() %>%
clearShapes()%>%
addCircles(lng=~Long, lat=~Lat, label=~Site, color="white", fill="white",
labelOptions = labelOptions(noHide =T),
radius = ~Amount*1000) %>%
addLabelOnlyMarkers(lng=~Long, lat=~Lat, label=~as.character(Amount),
labelOptions = labelOptions(noHide = T, direction = 'top', textOnly = T, textsize="20px"))
)
要使您的数据表具有响应性，您可以这样做：
output$table <- renderDataTable(
input$button
table()
)
【讨论】：
【参考方案2】：非常感谢@ge.org 的努力，但是带有登顶按钮的解决方案不适合我的应用程序，因为在实际应用程序中我有更多的类别，并且用户每次登顶更改都会很尴尬。但是由于您对时间的评论，我设法通过 edditig observeEvent 绕过了这一点。我为每个 data.type 将其拆分为三个单独的条件，而不是在负责 micro 和 macro 的条件中，我添加了新条件以省略错误来自input$kind 的类别。这会在控制台中发出一些警告，但似乎不会影响整个应用程序。
这是新代码：
library(shiny)
library(leaflet)
library(dplyr)
#### UI
ui <- fluidPage(
titlePanel("Map"),
leafletOutput("map"),
fluidRow(
column(2, offset = 0, style='padding:10px;',
radioButtons("data.type", "Type of data", c("Localisations", "Micro", "Macro"))),
column(2, offset = 0, style='padding:10px;',
uiOutput("position")),
column(2, offset = 0, style='padding:10px;',
uiOutput("kind"))
),
dataTableOutput("table"), ## to check the filtering
textOutput("kind.of")
)
server <- function(input, output, session)
##### data #####
sites <- data.frame(Site=c("Site1", "Site2"),
Lat=c(54, 56),
Long=c(16, 18))
micro <- data.frame(Site=c(rep("Site1",4), rep("Site2", 4)),
Position=c("Micro_pos1","Micro_pos1", "Micro_pos2", "Micro_pos2"),
Kind=rep(c("blue_fiber", "red_fiber"), 4),
Amount=c(5, 46, 64, 32, 54, 38, 29, 31) )
micro <- full_join(micro, sites)
macro <- data.frame(Site=c(rep("Site1",4), rep("Site2", 4)),
Position=c("Macro_pos1","Macro_pos1", "Macro_pos2", "Macro_pos2"),
Kind=rep(c("Cigarretes", "Pellets"), 4),
Amount=c(3, 16, 4, 12, 14, 18, 19, 21) )
macro <- full_join(macro, sites)
#### dynamic menu ####
### position
output$position <- renderUI(
switch(input$data.type,
"Micro"=radioButtons("position", "Micro position:",
choices = c("Micro_pos1", "Micro_pos2")),
"Macro"=radioButtons("position", "Macro position:",
choices = c("Macro_pos1", "Macro_pos2"))
)
)
## kind
output$kind <- renderUI(
switch(input$data.type,
"Micro"=checkboxGroupInput("kind", "kind of micro:",
choices = c("blue_fiber", "red_fiber"),
selected = c("blue_fiber", "red_fiber")),
"Macro"=checkboxGroupInput("kind", "kind of macro:",
choices = c("Cigarretes", "Pellets"),
selected=c("Cigarretes", "Pellets"))
)
)
#### reactive table to filter data to map ####
table <- reactive(
if(input$data.type=="Localisations")
return(sites)
else if (input$data.type=="Micro")
if (is.null(input$position))
return(NULL)
if (!is.null(input$position))
micro <-micro[micro$Position==input$position,]
micro<-micro[micro$Kind %in% input$kind,]
micro <- micro %>%
group_by(Site, Lat, Long, Position)%>%
summarise(Amount=sum(Amount))
micro
else if (input$data.type=="Macro")
if (is.null(input$position))
return(NULL)
if (!is.null(input$position))
macro <-macro[macro$Position==input$position,]
macro<-macro[macro$Kind %in% input$kind,]
macro <- macro %>%
group_by(Site, Lat, Long, Position)%>%
summarise(Amount=sum(Amount))
macro
)
#### table with filtered data ####
output$table <- renderDataTable(
table()
)
#### base map ####
output$map <- renderLeaflet(
leaflet(sites) %>%
setView(lat=55, lng=17, zoom=6) %>%
addProviderTiles(providers$Esri.WorldImagery) %>%
addCircleMarkers(lng=~Long, lat=~Lat, label=~Site,
labelOptions = labelOptions(noHide =T))
)
#### updating the map #####
observeEvent( c( input$data.type, input$position, input$kind),
if(input$data.type=="Localisations")
leafletProxy("map", data=sites) %>%
clearMarkers() %>%
clearShapes()%>%
addCircleMarkers(lng=~Long, lat=~Lat, label=~Site,
labelOptions = labelOptions(noHide =T), fillColor = "red")
else if (input$data.type=="Micro")
if (is.null(input$position))
return(NULL)
if (is.null(input$kind))
return(NULL)
###########################################################
####### and here 4 new line that did all the job #########
if (input$position %in% c("Macro_pos1", "Macro_pos2"))
return(NULL) ## new line
if (input$kind %in% c("Cigarretes", "Pellets"))
return(NULL)
####################################################
leafletProxy("map", data=table()) %>%
clearMarkers() %>%
clearShapes()%>%
addCircles(lng=~Long, lat=~Lat, label=~Site, color="white", fill="white",
labelOptions = labelOptions(noHide =T),
radius = ~Amount*1000) %>%
addLabelOnlyMarkers(lng=~Long, lat=~Lat, label=~as.character(Amount),
labelOptions = labelOptions(noHide = T, direction = 'top', textOnly = T, textsize="20px"))
else if(input$data.type=="Macro")
if (is.null(input$position))
return(NULL)
if (is.null(input$kind))
return(NULL)
###########################################################
####### and here 4 new line that did all the job #########
if (input$position %in% c("Micro_pos1", "Micro_pos2"))
return(NULL)
if (input$kind %in% c("blue_fiber", "red_fiber"))
return(NULL)
##############################################
leafletProxy("map", data=table()) %>%
clearMarkers() %>%
clearShapes()%>%
addCircles(lng=~Long, lat=~Lat, label=~Site, color="white", fill="white",
labelOptions = labelOptions(noHide =T),
radius = ~Amount*1000) %>%
addLabelOnlyMarkers(lng=~Long, lat=~Lat, label=~as.character(Amount),
labelOptions = labelOptions(noHide = T, direction = 'top', textOnly = T, textsize="20px"))
)
### server end
# Run the application
shinyApp(ui = ui, server = server)
【讨论】：
以上是关于闪亮的传单不适用于动态菜单的主要内容，如果未能解决你的问题，请参考以下文章