Question

我正在尝试在数据表中的不同过滤器之间创建交互。我可以独立操作每个过滤器，但不能一起操作。我研究了不同的主题并尝试了不同的方法，但是显然还存在另一个问题。

这就是我选择的解决方案。


filter1 <- reactive({
    fdt() %>% dplyr::filter(FinalData()$sous.themes %in% input$f_st)
  })

  filter2 <- reactive({
    fdt() %>% dplyr::filter(FinalData()$donnees %in% input$f_don)
  })

  filter3 <- reactive({
    fdt() %>% dplyr::filter(FinalData()$donnees %in% input$f_don) & dplyr::filter(FinalData()$sous.themes %in% input$f_st)
  })

  observe({
    updateSelectInput(session, inputId = "f_st", choices = filter2()$sous.themes)
    updateSelectInput(session, inputId = "f_don", choices = filter1()$donnees)
  })

  filter_final <- reactive({
    if (input$f_st != "Tous"){
    filter1()
    } else if (input$f_don != "Tous"){
    filter2()
    } else if (input$f_st != "Tous" & input$f_don != "Tous"){
    filter3()
    } else fdt()
  })

  #Rendu de la table d'extraction
  output$Synthese <-  DT::renderDT(DT::datatable({

    #Affiche le tableau
    filter_final()

  },

这是完整的代码。


library(DT)
library(readODS)
library(dplyr)
library(shinydashboard)
library(shinyWidgets)
library(shiny)

#Lecture du fichier
base <- read_ods("base.ods")

#Fonction pour l'affichage des fiches de données
createLink <- function(val) {
  sprintf('<a href= "%s" target="_blank" class="btn btn-primary">Fiches données</a>',val)
}

ui <- dashboardPage(
  dashboardHeader(title ="MobiDiag"),

  #Mise de en forme de la Sidebar
  dashboardSidebar(

    #Couleurs de l'entête
    tags$head(tags$style(HTML('.logo {
                                background-color: #8eb06a !important;
                                }
                                .navbar {
                                background-color: #a7cd7f !important;
                                }
                                '
    ))),

    #Texte principal
    h4(strong("Critères de sélection"), align="center"),

    #Liste des critères de sélection
    prettyCheckboxGroup("territoire", "Territoire",
                        thick = TRUE,
                        shape = "curve",
                        animation = "pulse",
                        choices = c("Communes centrales" = "Communes.centrales", "Communes pôles urbain" = "Communes.poles.urbain", "Communes secondaires" = "Communes.secondaires", "Communes rurales" = "Communes.rurales", "Ensemble territoire" = "Ensemble.territoire", "Périmètre élargit" = "Perimetre.elargit")),
    prettyCheckboxGroup("doc", "Documents de planification existants",
                        thick = TRUE,
                        shape = "curve",
                        animation = "pulse",
                        choices = c("Volet mobilité SCOT" = "Volet.mobilite.SCOT", "PDU obligatoire" = "PDU.obligatoire", "PGD volontaire" = "PGD.volontaire", "PLUI","Plan de mobilité rurale" = "Plan.mobilite.rurale", "PCAET", "PLUIHD")),

    #Et le miracle fut !
    actionButton("submit", ("Extraction")),

    br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),

    tags$img(src='logo_dreal.jpg', width = 40, height = 60),
    tags$img(src='inddigo.jpg', width = 40, height = 60)
  ),

  #Mise en forme de la page principale
  dashboardBody(
    fluidPage(

      shinyjs::useShinyjs(),
      tags$style(".btn.disabled {
                                background-color: red;
                                }"),

      #Onglets Extraction et Ajout de données
      mainPanel(width = 12,
                tabsetPanel(

                  #Onglet Extraction
                  tabPanel("Extraction",
                           fluidRow(
                             br(),
                             #Liste des différents filtres possibles sur le résultat
                             column(width=2,
                                    selectInput("f_st",
                                                "Sous-thèmes :",
                                                "")
                             ),
                             column(width=2,
                                    selectInput("f_don",
                                                "Données :",
                                                "")
                             ),
                             column(width=2,
                                    selectInput("f_check",
                                                "Validation :",
                                                "")
                             ),
                             column(width=2,
                                    selectInput("f_doc",
                                                "Documents de planification :",
                                                "")
                             ),
                             column(width=12, DT::dataTableOutput("Synthese"))

                           )
                  )
                )
      ))))

server = function(input, output, session) {


  shinyInput <- function(FUN, len, id, ...) {
    inputs <- character(len)
    for (i in seq_len(len)) {
      inputs[i] <- as.character(FUN(paste0(id, i), ...))
    }
    inputs
  }

  #Création des colonnes bouton
  df <- reactiveValues(data = data.frame(
    validation = shinyInput(actionButton, 1,
                            id = "button_",
                            label = "Check",
                            style = "color: white; background-color: #222D32",
                            onclick = 'Shiny.onInputChange(\"select_button\",  this.id)'),
    lien_fiches = createLink(base$fiches.donnees)[1]
  ))

  #Création de la règle de filtre a partir des critères
  create_rules <- reactive({
    paste(c(input$territoire, input$doc), "== 'Oui'",  collapse = " | ")
  })

  #MExtraction des critères de la base
  FinalData <- eventReactive(input$submit,{
    if(is.null(c(input$territoire, input$doc)))
      return()
    else (base %>% filter_(create_rules()))
  })

  #MAssemblage des deux dataframe
  fdt <- eventReactive(input$submit,{
    tmp_fdt <- cbind(FinalData()[1:2], df$data)
    colnames(tmp_fdt) <- c("Sous-thèmes", "Données", "Validation", "Fiches données")
    tmp_fdt
  })

  filter1 <- reactive({
    fdt() %>% dplyr::filter(FinalData()$sous.themes %in% input$f_st)
  })

  filter2 <- reactive({
    fdt() %>% dplyr::filter(FinalData()$donnees %in% input$f_don)
  })

  filter3 <- reactive({
    fdt() %>% dplyr::filter(FinalData()$donnees %in% input$f_don) & dplyr::filter(FinalData()$sous.themes %in% input$f_st)
  })

  observe({
    updateSelectInput(session, inputId = "f_st", choices = filter2()$sous.themes)
    updateSelectInput(session, inputId = "f_don", choices = filter1()$donnees)
  })

  filter_final <- reactive({
    if (input$f_st != "Tous"){
    filter1()
    } else if (input$f_don != "Tous"){
    filter2()
    } else if (input$f_st != "Tous" & input$f_don != "Tous"){
    filter3()
    } else fdt()
  })

  #Rendu de la table d'extraction
  output$Synthese <-  DT::renderDT(DT::datatable({

    #Affiche le tableau
    filter_final()

  },

  #Argument sans quoi beaucoup de choses ne marchent pas !!!!
  escape = FALSE,
  selection = "none",

  extensions="Buttons",
  options = list(
    pageLength = 10,

    #Couleur du header de l'extraction
    initComplete = JS(
      "function(settings, json) {",
      "$(this.api().table().header()).css({'background-color': '#1A242F', 'color': '#fff'});",
      "}"),

    #Paramètrage des boutons d'export
    dom="Bfrtip",
    buttons =  list(list(
      extend = "collection",
      filename = "Extraction",
      buttons = c("copy", "csv", "excel", "pdf"),
      text = "Télécharger la sélection")
    ),
    language = list(paginate = 
                      list('next'="suivant", 
                           'previous'="précédent"),
                    info = "Pages de _PAGE_ à _PAGES_",
                    search = "Rechercher",
                    infoFiltered = "(filtre des _MAX_ lignes)")
  )
  ))

  #Mise à jour des filtres du tableau
  observeEvent(input$submit, {
    updateSelectInput(session, inputId = "f_st", choices = c("Tous", FinalData()$sous.themes))
    updateSelectInput(session, inputId = "f_don", choices = c("Tous", FinalData()$donnees))
    updateSelectInput(session, inputId = "f_doc", choices = c("Tous", input$doc))
  })

  #Evenement lié au click bouton
  observeEvent(input$select_button, {
    updateSelectInput(session, inputId = "f_check", choices = c("Tous", "Oui"))
    updateActionButton(session, inputId = "button_", label = "Oui")
  })

}

shinyApp(ui, server)

非常感谢您！

Answer 1

如何在同一过滤器中获得它？

filter <- reactive({
    filtered_data <- fdt()
    if (input$f_st != "Tous"){
    filtered_data <- filtered_data %>% dplyr::filter(FinalData()$sous.themes %in% input$f_st)
    }
    if (input$f_st != "Tous"){
    filtered_data <- filtered_data %>% dplyr::filter(FinalData()$donnees %in% input$f_don)
    }
    if (input$f_st != "Tous"){
    filtered_data <- filtered_data %>% dplyr::filter(FinalData()$donnees %in% input$f_don) & dplyr::filter(FinalData()$sous.themes %in% input$f_st)
    }
   return(filtered_data)
  })

您可能需要更改代码的其他一些元素，但是基本上，您需要将过滤器迭代地应用于相同的数据集，而不是每次都应用于原始数据集。

Answer 2

谢谢！我尝试了您的代码，但是没有用（长度有问题），所以我进行了修改

filter <- reactive({
filtered_data <- fdt()
if (input$f_st != "Tous"){
  filtered_data <- filtered_data[FinalData()$sous.themes %in% input$f_st,]
}
if (input$f_don != "Tous"){
  filtered_data <- filtered_data[FinalData()$donnees %in% input$f_don,]
}
if (input$f_st != "Tous" & input$f_don != "Tous"){
  filtered_data <- filtered_data[FinalData()$sous.themes %in% input$f_st & FinalData()$donnees %in% input$f_don,]
}
return(filtered_data)
})

它可以处理我的一些数据，但在某些情况下会失败。

我有两种类型的错误：当我有撇号时，它将返回“无数据”。在其他情况下，它返回“ NA”

数据表中的多个无功选择输入

2 个答案: