R Shiny: fonctions d'observation imbriquées

Question

Pour l'exemple de jeu de données mtcars, nous souhaitons utiliser "cyl","am","carb","gear" comme filtres candidats (widgets selectInput). Les utilisateurs devraient être en mesure de sélectionner le filtre qu'ils veulent.

Et pour chaque filtre sélectionné, il y a un bouton '(désélectionner tout)' qui lui est associé. Mon problème est que, puisque le nombre de filtres n'est pas fixé, l'instruction de boucle pour générer les instructions observeEvent doit être dans une autre fonction observe.

Veuillez exécuter le code reproductible suivant.

Des suggestions pour faire fonctionner le bouton '(désélectionner tout')? Merci.

library(ggplot2) 
library(shiny) 
server <- function(input, output, session) { 
    R = mtcars[,c("cyl","am","carb","gear")] 

    output$FILTERS = renderUI({ 
    selectInput("filters","Filters",choices = names(R),multiple = TRUE) 
    }) 

    #this observe generates filters(selectInput widgets) dynamically, not important 
    observe({ 
    req(input$filters) 
    filter_names = input$filters 

    # count how many filters I selected 
    n = length(filter_names)  

    # to render n selectInput  
    lapply(1:n,function(x){ 
     output[[paste0("FILTER_",x)]] = renderUI({ 
     req(input$filters) 
     div(
      selectInput(paste0("filter_",x), 
         paste0(filter_names[x]), 
         choices = unique(R[,filter_names[x]]), 
         multiple = TRUE, 
         selected = unique(R[,filter_names[x]]) 
        ), 
      actionButton(paste0("filter_all_",x),"(Un)Select All") 
     ) 
     }) 
    }) 

    # this renders all the selectInput widgets 
    output$FILTER_GROUP = renderUI({ 
     lapply(1:n, function(i){ 
     uiOutput(paste0("FILTER_",i)) 
     }) 
    }) 
    }) 
#################### issue begins ##################### 
    observe(

    n = length(input$filters) 

    lapply(
    1:n, 
    FUN = function(i){ 
     Filter = paste0("filter_",i) 
     botton = paste0("filter_all_",i) 

     observeEvent(botton,{ 
     NAME = input$filters[i] 
     choices = unique(mtcars[,NAME]) 

     if (is.null(input[[Filter]])) { 

      updateCheckboxGroupInput(
      session = session, inputId = Filter, selected = as.character(choices) 
     ) 
     } else { 
      updateCheckboxGroupInput(
      session = session, inputId = Filter, selected = "" 
     ) 
     } 
     }) 
    } 
) 
) 
#################### issue ends ##################### 
}) 

ui <- fluidPage(
    uiOutput("FILTERS"), 
    hr(), 
    uiOutput("FILTER_GROUP") 
) 

shinyApp(ui = ui, server = server) 

Answer 1

Votre code a beaucoup de problèmes, 1) Vous évaluez le nombre d'éléments dans un selectInput à l'aide is.null au lieu de length. 2) Vous utilisez updateCheckboxGroupInput au lieu de updateSelectInput. 3) Si vous mettez un observateur dans un autre observateur, vous créerez plusieurs observateurs pour le même événement. Et 4) vous avez {} manquant dans votre dernier observateur et un ) supplémentaire dans la fonction serveur.

L'idée sur le answer recommandé est de garder une trace du dernier bouton cliqué pour éviter plusieurs observateurs. Dans votre problème, en plus d'avoir un seul observateur (et éviter les observateurs imbriqués), l'idée est de connaître le id du selectInput correspondant à côté du bouton (Un)Select All. Le but est de mettre à jour uniquement cette entrée select spécifique. Dans votre code, la mise à jour sera appliquée à tous les selectInput.

Nous devons ajouter à chaque actionButton l'id du selectInput et le nom de la colonne de l'ensemble de données mtcars associée à cette selectInput. Pour cela, nous pouvons ajouter les attributs: data pour l'ID et name pour le nom de la colonne. Avec JavaScript, nous pouvons récupérer ces attributs et les renvoyer au serveur en tant que input, respectivement lastSelectId et lastSelectName. Voici votre code modifié pour avoir une fonction JavaScript pour gérer l'événement click pour le sélecteur button. S'il vous plaît noter que nous avons également besoin d'envelopper chaque selectInput et actionButton dans un div avec class = "dynamicSI" pour distinguer des autres boutons.

library(ggplot2) 
library(shiny) 

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

    R = mtcars[,c("cyl","am","carb","gear")] 

    output$FILTERS = renderUI({ 
    selectInput("filters","Filters",choices = names(R),multiple = TRUE) 
    }) 

    observe({ 

    req(input$filters) 
    filter_names = input$filters 

    # count how many filters I selected 
    n = length(filter_names)  

    # to render n selectInput  
    lapply(1:n,function(x){ 
     output[[paste0("FILTER_",x)]] = renderUI({ 
     req(input$filters) 
     div(class = "dynamicSI", 
      selectInput(paste0("filter_",x), 
         paste0(filter_names[x]), 
         choices = unique(R[,filter_names[x]]), 
         multiple = TRUE, 
         selected = unique(R[,filter_names[x]]) 
        ), 
      actionButton(paste0("filter_all_",x),"(Un)Select All", 
         data = paste0("filter_",x), # selectInput id 
         name = paste0(filter_names[x])) # name of column 
     ) 
     }) 
    }) 

    output$FILTER_GROUP = renderUI({ 
     div(class="dynamicSI", 
     lapply(1:n, function(i){ 
      uiOutput(paste0("FILTER_",i)) 
     }) 
    ) 

    }) 

    }) 


    observeEvent(input$lastSelect, { 

    if (!is.null(input$lastSelectId)) { 
     cat("lastSelectId:", input$lastSelectId, "\n") 
     cat("lastSelectName:", input$lastSelectName, "\n") 
    } 
    # selectInput id 
    Filter = input$lastSelectId 
    # column name of dataset, (label on select input) 
    NAME = input$lastSelectName 
    choices = unique(mtcars[,NAME]) 

    if (length(input[[Filter]]) == 0) { 
     # in corresponding selectInput has no elements selected 
     updateSelectInput(
     session = session, inputId = Filter, selected = as.character(choices) 
    ) 
    } else { 
     # has at least one element selected 
     updateSelectInput(
     session = session, inputId = Filter, selected = "" 
    ) 
    } 

    }) 

    output$L = renderPrint({ 
    input$lastSelectId 
    }) 
} 


ui <- fluidPage(
    tags$script("$(document).on('click', '.dynamicSI button', function() { 
       var id = document.getElementById(this.id).getAttribute('data'); 
       var name = document.getElementById(this.id).getAttribute('name'); 
       Shiny.onInputChange('lastSelectId',id); 
       Shiny.onInputChange('lastSelectName',name); 
       // to report changes on the same selectInput 
       Shiny.onInputChange('lastSelect', Math.random()); 
       });"), 

    uiOutput("FILTERS"), 
    hr(), 
    uiOutput("FILTER_GROUP"), 
    hr(), 
    verbatimTextOutput("L") 

) 

shinyApp(ui = ui, server = server) 

Answer 2

@Geovany

Mise à jour

library(ggplot2) 
library(shiny) 


dropdownButton <- function(label = "", status = c("default", "primary", "success", "info", "warning", "danger"), ..., width = NULL) { 

    status <- match.arg(status) 
    # dropdown button content 
    html_ul <- list(
    class = "dropdown-menu", 
    style = if (!is.null(width)) 
     paste0("width: ", validateCssUnit(width), ";"), 
    lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;font-size:x-small") 
) 
    # dropdown button apparence 
    html_button <- list(
    class = paste0("btn btn-", status," dropdown-toggle"), 
    type = "button", 
    `data-toggle` = "dropdown", 
    style="font-size:x-small;width:135px" 
    # style="font-size:small;width:135px" 

) 
    html_button <- c(html_button, list(label)) 
    html_button <- c(html_button, list(tags$span(class = "caret"))) 
    # final result 
    tags$div(
    class = "dropdown", 
    br(), 
    do.call(tags$button, html_button), 
    do.call(tags$ul, html_ul), 
    tags$script(
     "$('.dropdown-menu').click(function(e) { 
     e.stopPropagation(); 
});") 
) 
    } 


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

    R = mtcars[,c("cyl","am","carb","gear")] 

    output$FILTERS = renderUI({ 
    selectInput("filters","Filters",choices = names(R),multiple = TRUE) 
    }) 

    observe({ 

    req(input$filters) 
    filter_names = input$filters 

    # count how many filters I selected 
    n = length(filter_names)  

    # to render n selectInput  
    lapply(1:n,function(x){ 
     output[[paste0("FILTER_",x)]] = renderUI({ 
     req(input$filters) 
     div(class = "dynamicSI", 

      dropdownButton(
       label = paste0(filter_names[x]), status ="default",width =50, 

        actionButton(inputId = paste0("filter_all_",x), label = "(Un)select all", 
           class="btn btn-primary btn-sm", 
           data = paste0("filter_",x), 
           name = paste(filter_names[x]) 
        ) 

       , 
       checkboxGroupInput(paste0("filter_",x),"", 
            choices = sort(unique(R[,filter_names[x]])), 
            selected = unique(R[,filter_names[x]]) 
           ) 
      ) 


     ) 
     }) 
    }) 

    output$FILTER_GROUP = renderUI({ 
     div(class="dynamicSI", 
      lapply(1:n, function(i){ 
      uiOutput(paste0("FILTER_",i)) 
      }) 
    ) 

    }) 

    }) 


    observeEvent(input$lastSelect, { 

    if (!is.null(input$lastSelectId)) { 
     cat("lastSelectId:", input$lastSelectId, "\n") 
     cat("lastSelectName:", input$lastSelectName, "\n") 
    } 
    # selectInput id 
    Filter = input$lastSelectId 
    # column name of dataset, (label on select input) 
    NAME = input$lastSelectName 
    choices = unique(mtcars[,NAME]) 

    if (length(input[[Filter]]) == 0) { 
     # in corresponding selectInput has no elements selected 
     updateSelectInput(
     session = session, inputId = Filter, selected = as.character(choices) 
    ) 
    } else { 
     # has at least one element selected 
     updateSelectInput(
     session = session, inputId = Filter, selected = "" 
    ) 
    } 

    }) 

    output$L = renderPrint({ 
    input$lastSelectId 
    }) 
} 


ui <- fluidPage(
    tags$script("$(document).on('click', '.dynamicSI button', function() { 
       var id = document.getElementById(this.id).getAttribute('data'); 
       var name = document.getElementById(this.id).getAttribute('name'); 
       Shiny.onInputChange('lastSelectId',id); 
       Shiny.onInputChange('lastSelectName',name); 
       // to report changes on the same selectInput 
       Shiny.onInputChange('lastSelect', Math.random()); 
       });"), 

    uiOutput("FILTERS"), 
    hr(), 
    uiOutput("FILTER_GROUP"), 
    hr(), 
    verbatimTextOutput("L") 

) 

shinyApp(ui = ui, server = server)