R Shiny 中带有数据表的两个相关过滤器
Two dependent filters in R Shiny with a DataTable
我有两个问题:
我在数据库中有两个相关的过滤器,我想按玩家或他们的 ID 进行搜索。我还希望第一个过滤器 (SelectInput) 能够响应。
例如,如果我在 ID 中输入数字 2,我希望我的 selectInput 自动显示 Lionel Messi。
这是代码,感谢您的回答
library(DT)
library(shinydashboard)
library(shiny)
library(shinyWidgets)
library(dplyr)
Database<- data.frame(Player=c("Cristiano Ronaldo","Lionel Messi","Neymar Jr","Cristiano Ronaldo"),ID=c(1,2,3,1))
ui<-dashboardPage(title="Application",skin="red",
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
selectInput("player",HTML('Please select your player'),choices=names(table(Database$Player))),
searchInput(inputId = "IDSEARCH", label = HTML('Or Please write the ID player'),
#placeholder = "13850",
btnSearch = icon("search"),
btnReset = icon("remove"),
width = "500px"),
DT::dataTableOutput("mtable2")
))
server <- function(input, output){
mtable2 <- reactive({filter(Database,(Player==input$player|ID==input$IDSEARCH))})
output$mtable2<-DT::renderDataTable({DT::datatable(mtable2())})
}
shinyApp(ui,server)
这是我对您问题的解决方案。在代码之后我解释了几件事。
library(DT)
library(shinydashboard)
library(shiny)
library(shinyWidgets)
Database <- data.frame(
Player = c("Cristiano Ronaldo", "Lionel Messi", "Neymar Jr", "Cristiano Ronaldo"),
ID = c(1, 2, 3, 1),
stringsAsFactors = FALSE
)
ui <- dashboardPage(title = "Application", skin = "red",
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
selectInput(
inputId = "player",
label = "Please select your player",
choices = unique(Database$Player)
),
searchInput(
inputId = "id",
label = "Or Please write the ID player",
btnSearch = icon("search"),
btnReset = icon("remove"),
width = "500px"
),
DT::dataTableOutput("mtable2")
)
)
server <- function(input, output, session) {
mtable2 <- reactive({
if (!isTruthy(input$id)) {
idx <- Database$Player == input$player
} else {
idx <- Database$ID == input$id
}
Database[idx, ]
})
output$mtable2 <- DT::renderDataTable({
DT::datatable(mtable2())
})
observeEvent(input$id, {
req(input$id)
selected_plyr <- unique(Database[Database$ID == input$id, ]$Player)
if (length(selected_plyr) == 0) {
showNotification("There is no player for the given ID", type = "error")
req(FALSE)
}
if (length(selected_plyr) > 1) {
showNotification("There is more than one player for a given ID", type = "error")
req(FALSE)
}
updateSelectInput(
session = session,
inputId = "player",
selected = selected_plyr
)
})
}
shinyApp(ui,server)
- 无需将输入标签包裹在
HTML()
内。
- 我稍微修改了您为
selectInput()
选择选项的方式。在创建数据框时注意 stringsAsFactors = FALSE
(在 R >= 4.0.0 中不需要)。
- 我不会使用
searchInput
作为 ID,但由于这是您的选择,我将其保留在这里。
isTruthy()
函数检查 input$id
中的值是否如其名称所说的那样“真实”。基本上它检查它不是 NULL、空字符串、NA 等。所以,当没有给出 ID 时,我们使用 selectInput()
中的名称来过滤。
- 过滤可以使用 {dplyr} 完成,但使用 base R 也很容易(只是子集符号
Database[idx, ]
。
- 我向
input$id
添加了一个观察者来更新 selectInput()
。请注意,您需要传递 session
,它成为您的服务器函数的参数...
嗯,有什么问题尽管问!
编辑:
要使用 {dplyr},我会更改以下内容
if (!isTruthy(input$id)) {
idx <- Database$Player == input$player
} else {
idx <- Database$ID == input$id
}
Database[idx, ]
将被重写为
if (!isTruthy(input$id)) {
Database %>% filter(Player == input$player)
} else {
Database %>% filter(ID == input$id)
}
并替换
selected_plyr <- unique(Database[Database$ID == input$id, ]$Player)
和
selected_plyr <- Database %>% filter(ID == input$id) %>% pull(Player) %>% unique()
我有两个问题:
我在数据库中有两个相关的过滤器,我想按玩家或他们的 ID 进行搜索。我还希望第一个过滤器 (SelectInput) 能够响应。
例如,如果我在 ID 中输入数字 2,我希望我的 selectInput 自动显示 Lionel Messi。
这是代码,感谢您的回答
library(DT)
library(shinydashboard)
library(shiny)
library(shinyWidgets)
library(dplyr)
Database<- data.frame(Player=c("Cristiano Ronaldo","Lionel Messi","Neymar Jr","Cristiano Ronaldo"),ID=c(1,2,3,1))
ui<-dashboardPage(title="Application",skin="red",
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
selectInput("player",HTML('Please select your player'),choices=names(table(Database$Player))),
searchInput(inputId = "IDSEARCH", label = HTML('Or Please write the ID player'),
#placeholder = "13850",
btnSearch = icon("search"),
btnReset = icon("remove"),
width = "500px"),
DT::dataTableOutput("mtable2")
))
server <- function(input, output){
mtable2 <- reactive({filter(Database,(Player==input$player|ID==input$IDSEARCH))})
output$mtable2<-DT::renderDataTable({DT::datatable(mtable2())})
}
shinyApp(ui,server)
这是我对您问题的解决方案。在代码之后我解释了几件事。
library(DT)
library(shinydashboard)
library(shiny)
library(shinyWidgets)
Database <- data.frame(
Player = c("Cristiano Ronaldo", "Lionel Messi", "Neymar Jr", "Cristiano Ronaldo"),
ID = c(1, 2, 3, 1),
stringsAsFactors = FALSE
)
ui <- dashboardPage(title = "Application", skin = "red",
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
selectInput(
inputId = "player",
label = "Please select your player",
choices = unique(Database$Player)
),
searchInput(
inputId = "id",
label = "Or Please write the ID player",
btnSearch = icon("search"),
btnReset = icon("remove"),
width = "500px"
),
DT::dataTableOutput("mtable2")
)
)
server <- function(input, output, session) {
mtable2 <- reactive({
if (!isTruthy(input$id)) {
idx <- Database$Player == input$player
} else {
idx <- Database$ID == input$id
}
Database[idx, ]
})
output$mtable2 <- DT::renderDataTable({
DT::datatable(mtable2())
})
observeEvent(input$id, {
req(input$id)
selected_plyr <- unique(Database[Database$ID == input$id, ]$Player)
if (length(selected_plyr) == 0) {
showNotification("There is no player for the given ID", type = "error")
req(FALSE)
}
if (length(selected_plyr) > 1) {
showNotification("There is more than one player for a given ID", type = "error")
req(FALSE)
}
updateSelectInput(
session = session,
inputId = "player",
selected = selected_plyr
)
})
}
shinyApp(ui,server)
- 无需将输入标签包裹在
HTML()
内。 - 我稍微修改了您为
selectInput()
选择选项的方式。在创建数据框时注意stringsAsFactors = FALSE
(在 R >= 4.0.0 中不需要)。 - 我不会使用
searchInput
作为 ID,但由于这是您的选择,我将其保留在这里。 isTruthy()
函数检查input$id
中的值是否如其名称所说的那样“真实”。基本上它检查它不是 NULL、空字符串、NA 等。所以,当没有给出 ID 时,我们使用selectInput()
中的名称来过滤。- 过滤可以使用 {dplyr} 完成,但使用 base R 也很容易(只是子集符号
Database[idx, ]
。 - 我向
input$id
添加了一个观察者来更新selectInput()
。请注意,您需要传递session
,它成为您的服务器函数的参数...
嗯,有什么问题尽管问!
编辑:
要使用 {dplyr},我会更改以下内容
if (!isTruthy(input$id)) {
idx <- Database$Player == input$player
} else {
idx <- Database$ID == input$id
}
Database[idx, ]
将被重写为
if (!isTruthy(input$id)) {
Database %>% filter(Player == input$player)
} else {
Database %>% filter(ID == input$id)
}
并替换
selected_plyr <- unique(Database[Database$ID == input$id, ]$Player)
和
selected_plyr <- Database %>% filter(ID == input$id) %>% pull(Player) %>% unique()