R Shiny 中的两个依赖过滤器和一个 DataTable

Question

我有两个问题：

我在数据库中有两个依赖过滤器，我想按玩家或他们的 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)

Answer 1

这是我对您问题的解决方案。在代码之后，我在那里解释了几件事。

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)

1. 无需在HTML() 内包装输入标签。
2. 我稍微修改了您选择selectInput() 的方式。在创建数据框时请注意stringsAsFactors = FALSE（在 R >= 4.0.0 中，这不是必需的）。
3. 我不会使用 searchInput 作为 ID，但由于这是您的选择，我将其保留在这里。
4. isTruthy() 函数检查input$id 中的值是否如其名称所述“真实”。基本上它检查它不是NULL，空字符串，NA等。所以，当没有给出ID时，我们使用selectInput()中的名称进行过滤。
5. 过滤可以使用 {dplyr} 完成，但使用 base R 也很容易（只是子集表示法 Database[idx, ]。
6. 我向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()