R Shiny：嵌套觀察函數

對於示例數據集mtcars，我們希望使用"cyl","am","carb","gear"作爲候選過濾器（selectInput小部件）。用戶應該能夠選擇他們想要的過濾器。R Shiny：嵌套觀察函數

對於每個篩選出的篩選器，都有一個與其關聯的「（全部）全選」按鈕。

我的問題是，由於過濾器的數量不固定，因此生成observeEvent語句的循環語句必須位於另一個observe函數中。

請運行以下可重複的代碼。

任何建議，使'（un）全選'botton工作？謝謝。

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)

來源

2016-11-22 John

如果我們使用'dropdownButton'部件看看這個答案http://stackoverflow.com/questions/40631788/shiny-observe-triggered-by-dynamicaly-generated-inputs/40643541#40643541 – Geovany

你的代碼有很多問題，1）您使用的is.null代替length評估要素在selectInput數量。 2）您正在使用updateCheckboxGroupInput而不是updateSelectInput。 3）如果你把觀察者放在另一個觀察者的內部，你將爲同一個事件創建多個觀察者。 4）你在最後一個觀察者中缺少一些{}，並且在服務器功能中有一個額外的)。

推薦answer的想法是跟蹤最後一個點擊的按鈕，以避免多個觀察者。在你的問題中，除了只有一個觀察者（並且避免嵌套的觀察者）之外，想法是知道(Un)Select All按鈕旁邊對應的selectInput的id。目標是僅更新特定的選擇輸入。在您的代碼中，更新將應用於所有selectInput's。

我們需要爲每個actionButton添加selectInput的ID和與該selectInput相關聯的mtcars數據集的列名。爲此，我們可以添加屬性：data爲id，name爲列名稱。使用JavaScript，我們可以檢索這些屬性並將它們分別發送回服務器，分別爲input的lastSelectId和lastSelectName。

下面是您的代碼修改爲具有JavaScript函數來處理選擇器button的click事件。請注意，我們還需要將每個selectInput和actionButton換成div與class = "dynamicSI"以區別於其他按鈕。

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)

來源

2016-11-23 01:28:46 Geovany

定義在這個鏈接http://stackoverflow.com/questions/34530142/drop-down-checkbox-input-in-shiny，任何想法，我們應該把'div（class =「dynamicSI」，...）'語句in。 – John

儘可能靠近動作按鈕來選擇所有元素。 – Geovany

我更新了我的代碼。我嘗試了幾個地方分類但沒有工作。定製小部件「dropdownButton」是否阻止定義類... – John

@Geovany

更新

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)

來源

2016-11-22 06:49:01 John

R Shiny：嵌套觀察函數

回答

相關問題