如果使用 updateselectInput()，DT 会快速刷新

Question

在闪亮的应用程序中，selectInput() 的选择根据 Grade[=22] 列的值进行更新=] 在数据框 df 中。我需要根据等级的唯一值显示 DT table。

ui <- uiOutput('mainPage')


server <- function(input, output, session) {

  grade <- c("All",9,10,11,12)

  output$mainPage <- renderUI({
    fluidPage(

      selectInput(inputId = "grade",shiny::HTML
                  ("<span style='color: white'>Designation</span>"),
                  choices = grade),
      DTOutput('table')
    )
  })


  output$table <- renderDT({

    df <-  data.frame("Name" = c('Arun','Ram','Krishna','Rama','Ashwin'),
                      "Grade" = c(10,11,10,12,11),
                      "StressLevel" = c('Stressful','Very stressful','Very stressful','Stressful','Stressful'))

    df$Name<-as.character(df$Name)

    rownames(df) <- c()

    selectedGrade <- as.list(unique(df[,"Grade"]))

    updateSelectInput(session,inputId = "grade",
                      choices = c("All",selectedGrade))


    if(input$grade == "All"){

      dataSelected <- df[,c(1,3)]

      stressCount <- length(unique(dataSelected$StressLevel))
      if(stressCount == 2){
        color = c('#ff684c','#e03426')
      }else{
        color = c('#ff684c')
      }
      if(stressCount == 0){
        color = c()
      }



      datatable(dataSelected, options = list(pageLenth = 5, searching = FALSE,
                                             lengthMenu = c(5, 10, 15, 20),lengthChange = FALSE,
                                             scrollX = T, autoWidth = TRUE,
                                             initComplete = JS(
                                               "function(settings, json) {",
                                               "$(this.api().table().header()).css({ 
                                               'color': '#fff'});",
                                               "}")))%>% formatStyle(
                                                 'StressLevel',
                                                 Color = styleEqual(unique(dataSelected$StressLevel), 
                                                                    color))


  }else{

    dataSelected <- df %>% filter(Grade == input$grade)

    dataSelected <- dataSelected[,c(1,3)]

    stressCount <- length(unique(dataSelected$StressLevel))
    if(stressCount == 2){
      color = c('#ff684c','#e03426')
    }else{
      color = c('#ff684c')
    }

    if(stressCount == 0){
      color = c()
    }

    datatable(dataSelected, options = list(pageLenth = 5, searching = FALSE,
                                           lengthMenu = c(5, 10, 15, 20),lengthChange = FALSE,
                                           scrollX = T, autoWidth = TRUE,
                                           initComplete = JS(
                                             "function(settings, json) {",
                                             "$(this.api().table().header()).css({ 
                                             'color': '#fff'});",
                                             "}"))) %>% formatStyle(
                                               'StressLevel',
                                               Color = styleEqual(unique(dataSelected$StressLevel),color))     
}
})
}

shinyApp(ui = ui, server = server)

最初，数据table 显示为选择全部 作为值。如果我 select 其他选择，例如 10，DT 显示与 10 年级相关的数据，但它会快速刷新。面临的后果是，所有以外的年级数据无法查看

任何人都可以为这个问题提供 suitable 解决方案吗？

Answer 1

您需要设置 updateSelectInput() 的 selected 参数以保留当前选择：

library(shiny)
library(DT)
library(dplyr)

ui <- uiOutput('mainPage')

server <- function(input, output, session) {
  grade <- c("All", 9, 10, 11, 12)

  output$mainPage <- renderUI({
    fluidPage(selectInput(
      inputId = "grade",
      shiny::HTML
      ("<span style='color: white'>Designation</span>"),
      choices = grade
    ),
    DTOutput('table'))
  })


  output$table <- renderDT({
    DF <-
      data.frame(
        "Name" = c('Arun', 'Ram', 'Krishna', 'Rama', 'Ashwin'),
        "Grade" = c(10, 11, 10, 12, 11),
        "StressLevel" = c(
          'Stressful',
          'Very stressful',
          'Very stressful',
          'Stressful',
          'Stressful'
        )
      )

    DF$Name <- as.character(DF$Name)

    rownames(DF) <- c()

    selectedGrade <- as.list(unique(DF[, "Grade"]))

    updateSelectInput(
      session,
      inputId = "grade",
      choices = c("All", selectedGrade),
      selected = isolate({
        input$grade
      })
    )


    if (input$grade == "All") {
      dataSelected <- DF[, c(1, 3)]

      stressCount <- length(unique(dataSelected$StressLevel))
      if (stressCount == 2) {
        color = c('#ff684c', '#e03426')
      } else{
        color = c('#ff684c')
      }
      if (stressCount == 0) {
        color = c()
      }



      datatable(
        dataSelected,
        options = list(
          pageLenth = 5,
          searching = FALSE,
          lengthMenu = c(5, 10, 15, 20),
          lengthChange = FALSE,
          scrollX = T,
          autoWidth = TRUE,
          initComplete = JS(
            "function(settings, json) {",
            "$(this.api().table().header()).css({
                                               'color': '#fff'});",
            "}"
          )
        )
      ) %>% formatStyle('StressLevel',
                        Color = styleEqual(unique(dataSelected$StressLevel),
                                           color))


    } else{
      dataSelected <- DF %>% filter(Grade == input$grade)

      dataSelected <- dataSelected[, c(1, 3)]

      stressCount <- length(unique(dataSelected$StressLevel))
      if (stressCount == 2) {
        color = c('#ff684c', '#e03426')
      } else{
        color = c('#ff684c')
      }

      if (stressCount == 0) {
        color = c()
      }

      datatable(
        dataSelected,
        options = list(
          pageLenth = 5,
          searching = FALSE,
          lengthMenu = c(5, 10, 15, 20),
          lengthChange = FALSE,
          scrollX = T,
          autoWidth = TRUE,
          initComplete = JS(
            "function(settings, json) {",
            "$(this.api().table().header()).css({
                                             'color': '#fff'});",
            "}"
          )
        )
      ) %>% formatStyle('StressLevel',
                        Color = styleEqual(unique(dataSelected$StressLevel), color))
    }
  }, server = FALSE)
}

shinyApp(ui = ui, server = server)

此外，我为renderDT()设置了server = FALSE，以防止数据表为re-rendered时"processing..."消息的闪烁。