在闪亮的应用程序中过滤数据，但在更新表时将值保留在 selectInput 中

Question

在闪亮的应用程序中过滤数据，但在更新表时将值保留在 selectInput 中

我有一个闪亮的应用程序，要求用户上传的文件（有数据的表格文件），然后将其渲染此文件到表中，用户可以筛选基于一些值numericInput，selectInput和textAreaInput。用户必须选择过滤器，然后按下按钮才能过滤表。

没有顺序过滤，即用户可以填充所有过滤器或仅填充一个。每次用户选择过滤器时，其他过滤器的值都会更新（selectInput输入），这就是我想要的行为。但是，一旦按下过滤器按钮，我就看不到以前的选择，也无法重置过滤器。

我想要实现的是在更新过滤器时保持实际行为，即，一旦我选择一个过滤器并按下过滤器按钮，其他selectInput选择就会自动更新，但我想跟踪过滤器选择，因此用户可以看到他/她选择的过滤器。这正是我所期待的，但每次我按下按钮过滤器时，似乎过滤器选项卡会再次呈现。

这是我的应用程序，

library(shiny)
library(vroom)
library(dplyr)
library(shinycssloaders)
library(shinydashboard)
library(shinydashboardPlus)
library(tidyr)


header <- dashboardHeader()

sidebar <- dashboardSidebar(width = 450,

  sidebarMenu(id="tabs", 
    menuItem("Filtros", tabName="filtros", icon = icon("bar-chart-o")),
      uiOutput("filtros")

  )
)

body <- dashboardBody(

  tabItems(
    tabItem(tabName="filtros",
          fluidRow(
          column(12,dataTableOutput("tabla_julio") %>% withSpinner(color="#0dc5c1"))
        )
    )  
   )
 )

ui <- dashboardPagePlus(enable_preloader = TRUE, sidebar_fullCollapse = TRUE, header, sidebar, body)

server = function(input, output, session) {

    #Create the choices for sample input
    vals <- reactiveValues(data=NULL)
    vals$data <- iris



  output$filtros <- renderUI({

    datos <- vals$data
      conditionalPanel("input.tabs == 'filtros'",
        tagList(        
            div(style="display: inline-block;vertical-align:top; width: 221px;",numericInput(inputId="Sepal.Length", label="Sepal.Length", value=NA, min = NA, max = NA, step = NA)),                      
            div(
              div(style="display: inline-block;vertical-align:top; width: 224px;", selectInput(inputId = "Species", label = "Species", width = "220",  choices=unique(datos$Species), 
              selected = NULL, multiple = TRUE, selectize = TRUE, size = NULL))
              )
            ),
            actionButton("filtrar", "Filter")
          )
    })

# create reactiveValues

  vals <- reactiveValues(data=NULL)
  vals$data <- iris


# Filter data

observeEvent(input$filtrar, {

      tib <- vals$data

      if (!is.na(input$Sepal.Length)){
        tib <- tib %>% dplyr::filter(!Sepal.Length >= input$Sepal.Length)
        print(head(tib))
      } else { tib <- tib }

      # Filter
      if (!is.null(input$Species)){
        toMatch <- paste0("\\b", input$Species, "\\b")
        matches <- unique(grep(paste(toMatch,collapse="|"), tib$Species, value=TRUE))
        tib <- tib %>% dplyr::filter(Species %in% matches)
      } else { tib <- tib}

      tib -> vals$data
      print(head(tib, n=15))

    })


  # Reactive function creating the DT output object
  output$tabla_julio <- DT::renderDataTable({        
      DT::datatable(vals$data) 
    })

}

shinyApp(ui, server)

Run Code Online (Sandbox Code Playgroud)

Answer 1

ism*_*gal 6

另一个更新：

library(shiny)
library(vroom)
library(dplyr)
library(shinycssloaders)
library(shinydashboard)
library(shinydashboardPlus)
library(tidyr)

header <- dashboardHeader()

sidebar <- dashboardSidebar(width = 450,
                            sidebarMenu(id = "tabs",
                                        menuItem(
                                          "Filtros",
                                          tabName = "filtros",
                                          icon = icon("bar-chart-o")
                                        ),
                                        uiOutput("filtros")
                            ))

body <- dashboardBody(tabItems(tabItem(tabName = "filtros",
                                       fluidRow(
                                         column(12,
                                                DT::dataTableOutput("tabla_julio") # %>% withSpinner(color = "#0dc5c1")
                                         )
                                       ))))

ui <-
  dashboardPagePlus(
    enable_preloader = FALSE,
    sidebar_fullCollapse = TRUE,
    header,
    sidebar,
    body
  )

server = function(input, output, session) {

  # Create the choices for sample input
  vals <- reactiveValues(data = iris, filtered_data = iris)

  output$filtros <- renderUI({
    datos <- isolate(vals$data)
    conditionalPanel(
      "input.tabs == 'filtros'",
      tagList(
        div(
          style = "display: inline-block;vertical-align:top; width: 221px;",
          numericInput(
            inputId = "SepalLength",
            label = "Sepal.Length",
            value = NA,
            min = NA,
            max = NA,
            step = NA
          )
        ),
        div(
          div(
            style = "display: inline-block;vertical-align:top; width: 224px;",
            selectInput(
              inputId = "Species",
              label = "Species",
              width = "220",
              choices = unique(isolate(datos$Species)),
              selected = NULL,
              multiple = TRUE,
              selectize = TRUE,
              size = NULL
            )
          )
        )
      ),
      actionButton("filtrar", "Filter", style = "width: 100px;"),
      actionButton("reset", "Reset", style = "width: 100px;")
    )
  })


  # Filter data
  observeEvent(input$filtrar, {
    tib <- vals$data

    if (!is.na(input$SepalLength)) {
      tib <- tib %>% dplyr::filter(Sepal.Length < input$SepalLength)
      print(head(tib))
    } else {
      tib
    }

    # Filter
    if (!is.null(input$Species)) {
      tib <- tib %>% dplyr::filter(Species %in% input$Species)
    } else {
      tib
    }

    print(head(tib, n = 15))

    vals$filtered_data <- tib

    updateSelectInput(session, inputId = "Species", selected = input$Species, choices = unique(vals$filtered_data$Species))

  })

  observeEvent(input$reset, {
    updateNumericInput(session, inputId = "SepalLength", value = NA)
    updateSelectInput(session, inputId = "Species", selected = "")
  })

  # Reactive function creating the DT output object
  output$tabla_julio <- DT::renderDataTable({
    DT::datatable(vals$filtered_data)
  }, server = FALSE)

}

shinyApp(ui, server)

Run Code Online (Sandbox Code Playgroud)

更新：这就是我认为你所追求的。最重要的一步是isolate输入，renderUI这样它们就不会在每次输入更改时重新渲染。

library(shiny)
library(vroom)
library(dplyr)
library(shinycssloaders)
library(shinydashboard)
library(shinydashboardPlus)
library(tidyr)

header <- dashboardHeader()

sidebar <- dashboardSidebar(width = 450,
                            sidebarMenu(id = "tabs",
                                        menuItem(
                                          "Filtros",
                                          tabName = "filtros",
                                          icon = icon("bar-chart-o")
                                        ),
                                        uiOutput("filtros")
                            ))

body <- dashboardBody(tabItems(tabItem(tabName = "filtros",
                                       fluidRow(
                                         column(12,
                                                DT::dataTableOutput("tabla_julio") # %>% withSpinner(color = "#0dc5c1")
                                         )
                                       ))))

ui <-
  dashboardPagePlus(
    enable_preloader = FALSE,
    sidebar_fullCollapse = TRUE,
    header,
    sidebar,
    body
  )

server = function(input, output, session) {

  # Create the choices for sample input
  vals <- reactiveValues(data = iris, filtered_data = iris)

  output$filtros <- renderUI({
    datos <- isolate(vals$data)
    conditionalPanel(
      "input.tabs == 'filtros'",
      tagList(
        div(
          style = "display: inline-block;vertical-align:top; width: 221px;",
          numericInput(
            inputId = "SepalLength",
            label = "Sepal.Length",
            value = NA,
            min = NA,
            max = NA,
            step = NA
          )
        ),
        div(
          div(
            style = "display: inline-block;vertical-align:top; width: 224px;",
            selectInput(
              inputId = "Species",
              label = "Species",
              width = "220",
              choices = unique(isolate(datos$Species)),
              selected = NULL,
              multiple = TRUE,
              selectize = TRUE,
              size = NULL
            )
          )
        )
      ),
      actionButton("filtrar", "Filter", style = "width: 100px;"),
      actionButton("reset", "Reset", style = "width: 100px;")
    )
  })


  # Filter data
  observeEvent(input$filtrar, {
    tib <- vals$data

    if (!is.na(input$SepalLength)) {
      tib <- tib %>% dplyr::filter(Sepal.Length < input$SepalLength)
      print(head(tib))
    } else {
      tib
    }

    # Filter
    if (!is.null(input$Species)) {
      tib <- tib %>% dplyr::filter(Species %in% input$Species)
    } else {
      tib
    }

    print(head(tib, n = 15))

    vals$filtered_data <- tib

  })

  observeEvent(input$reset, {
    updateNumericInput(session, inputId = "SepalLength", value = NA)
    updateSelectInput(session, inputId = "Species", selected = "")
  })

  # Reactive function creating the DT output object
  output$tabla_julio <- DT::renderDataTable({
    DT::datatable(vals$filtered_data)
  }, server = FALSE)

}

shinyApp(ui, server)

Run Code Online (Sandbox Code Playgroud)

初步回答：

我建议使用库中的selectizeGroup-module（shinyWidgets）。

它创造了一个

selectizeInput用于过滤 data.frame 的列的相互依赖组（如在 Excel 中）。

除此之外，它只使用selectizeInput它似乎可以满足您的要求，并使我们免于打字。

这是使用iris数据集的示例：

library(shiny)
library(DT)
library(shinyWidgets)
library(datasets)

DF <- iris
names(DF) <- gsub("\\.", "", names(DF))

ui <- fluidPage(
  fluidRow(
    column(width = 10, offset = 1, tags$h3("Filter data with selectize group")),
    column(width = 3, offset = 1, 
           selectizeGroupUI(
             id = "my-filters",
             params = list(
               SepalLength = list(inputId = "SepalLength", title = "SepalLength:"),
               SepalWidth = list(inputId = "SepalWidth", title = "SepalWidth:"),
               PetalLength = list(inputId = "PetalLength", title = "PetalLength:"),
               PetalWidth = list(inputId = "PetalWidth", title = "PetalWidth:"),
               species = list(inputId = "Species", title = "Species:")
             ),
             inline = FALSE
           )),
    column(
      width = 10, offset = 1,DT::dataTableOutput(outputId = "table")
    )
  )
)

server <- function(input, output, session) {
  filtered_table <- callModule(
    module = selectizeGroupServer,
    id = "my-filters",
    data = DF,
    vars = names(DF)
  )
  output$table <- DT::renderDataTable(filtered_table())
}

shinyApp(ui, server)

Run Code Online (Sandbox Code Playgroud)

归档时间：	5 年，8 月前
查看次数：	1463 次
最近记录：	5 年，8 月前