фильтровать данные в блестящем приложении, но сохранять значения в selectInput при обновлении таблицы

Question

У меня есть блестящее приложение, которое просит пользователя загрузить файл (табличный файл с данными), затем оно отображает этот файл в таблицу, и пользователь может фильтровать некоторые значения на основе numericInput, selectInput и textAreaInput. Пользователь должен выбрать фильтры, а затем нажать кнопку, чтобы отфильтровать таблицу.

Последовательная фильтрация отсутствует, т. Е. Пользователь может заполнить все фильтры или только один. Каждый раз, когда пользователь выбирает фильтр, обновляются значения других фильтров (selectInput входы), и это поведение, которое я хочу. Однако после нажатия кнопки Filter я не могу увидеть предыдущий выбор, а также не могу сбросить фильтры.

Чего я хотел бы добиться, так это поддерживать фактическое поведение при обновлении фильтров, т. Е. После выбора фильтра и нажатия кнопки фильтра остальные параметры 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)

Answer 1

Другое обновление:

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)

---

Обновление: Вот то, что я думаю, что вы после. Наиболее важным шагом является 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)

---

Первоначальный ответ:

Я бы рекомендовал использовать selectizeGroup-модуль из библиотеки (inyWidgets ).

Создает

Группа взаимозависимых 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)

Answer 2

Если я правильно понимаю ваш вопрос, вы почти достигли своей цели. В этом случае вы перезаписываете свои данные во время выполнения. Это приводит к тому, что фильтр становится недействительным, и реактивный пользовательский интерфейс проверяет это при каждом нажатии.

Простое решение - хранить исходные и отфильтрованные наборы данных отдельно. Альтернативой является сохранение фильтров в реактивном значении и повторное отображение DataTable во время выполнения, используя фильтры в исходной таблице. Здесь я go для первого примера.

Ниже я изменил следующее:

1. Добавлены data_print и filters в качестве реактивных значений для печати и фильтров
2. Изменен метод фильтрации для фильтра , используя data_print, добавив некоторое форматирование и изменив несколько строк кода, в качестве примера кода, который может быть легче адаптировать к данному пользовательскому вводу
3. удалил некоторый ненужный код (renderDataTable изменено ввод в DT автоматически)

server = function(input, output, session) {
  #Create the choices for sample input
  vals <- reactiveValues(
                         #raw data
                         data = iris,
                         #Exists only in order to print.
                         data_print = iris,
                         #for filtering data
                         filters = list(Species = c(), 
                                        Sepal.Length = c()
                                        )
                         )
  #in case of many filters, or filters expanding depending on input data, it might be worth adding this to reactiveValues
  ## Unchanged
  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")
    )
  })

  # Filter data
  observeEvent(input$filtrar, {
    nm <- names(vals$filters)
    for(i in nm){
      if(is.na(input[[i]]) || is.null(input[[i]]))
        vals$filters[[i]] <- unique(vals$data[[i]]) #If unfiltered use all values
      else
        vals$filters[[i]] <- input[[i]] #if filtered choose the filtered value
    }
    #Overwrite data_print instead of data. Creds to https://stackoverflow.com/a/47171513/10782538 
    vals$data_print <- vals$data %>% dplyr::filter((!!as.symbol(nm[1])) %in% vals$filters[[1]], 
                                         (!!as.symbol(nm[2]) %in% vals$filters[[2]]))

  })

  # Reactive function creating the DT output object
  output$tabla_julio <- DT::renderDataTable(        
    vals$data_print #<====renderDataTable changes to data.
  )
}