閃亮 - 使用insertUI的動態數據過濾器

Question

我是新來的閃亮，並試圖編寫一個應用程序，用戶可以動態添加數據過濾器（請參閱下面的代碼）。 我認爲insertUI和刪除用戶界面非常酷。 但是，我有幾個問題：

1) I cannot address dynamically generates input$ids (see filterId in the code, l. 36 and l. 58) 
    2) in updateCheckboxGroupInput (l. 62) checkboxes are not preselected. 
    3) I cannot select data rows using which() (l. 74) 
    4) The checkboxes are not displayed inside the column, but spread over the whole page. 

我非常感謝任何提示。

感謝，霍爾迪

這裏的代碼：

library(shiny) 

rowvalues <- function(col,data) { 
    as.list(unique(data[col])) 
} 

ui <- fluidPage(
    sidebarLayout(
    sidebarPanel(
     fluidRow(
     column(6, actionButton('addFilter', 'Add filter')), 
     column(6, actionButton('removeFilter', 'Remove filter')), 
     offset = 6 
    ), 
     tags$hr(), 
     tags$div(id = 'placeholderAddRemFilt'), 
     tags$div(id = 'placeholderFilter'), 
     width = 4 # sidebar 
    ), 
    mainPanel(
     tableOutput("data") 
    ) 
) 
) 

server <- function(input, output,session) { 
    filter <- character(0) 

    observeEvent(input$addFilter, { 
    add <- input$addFilter 
    filterId <- paste0('Filter', add) 
    headers <- names(mtcars) 
    insertUI(
     selector = '#placeholderFilter', 
     ui = tags$div(
     # selectInput(filterId, label = paste0("Filter ",add), # does not work 
     selectInput("ColFilter", label = paste0("Filter ",add), 
        choices = as.list(headers), 
        selected = 1), 
     checkboxGroupInput("RowFilter", label = "Select variable values", 
          choices = NULL, selected = NULL, 
          inline = TRUE, width = 4000), 
     id = filterId 
    ) 
    ) 

    filter <<- c(filter,filterId) 
    }) 

    observeEvent(input$removeFilter, { 
    removeUI(
     ## pass in appropriate div id 
     selector = paste0('#', filter[length(filter)]) 
    ) 
    filter <<- filter[-length(filter)] 
    }) 

    # observeEvent(input$filterId, { # does ntót work 
    observeEvent(input$ColFilter, { 
    col <- input$ColFilter 
    values <- as.list(unique(mtcars[col]))[[1]] 
    updateCheckboxGroupInput(session,"RowFilter", label = "Select variable values", 
           choices = values, selected = values, 
           inline = TRUE) 
    }) 

    output$data <- renderTable({ 
    col <- input$ColFilter 
    rows <- input$RowFilter 
    print(c("selected col: ",col)) 
    print(c("selected rows: ",as.vector(rows))) 
    if(is.null(col)) mtcars 
    else { 
     mtcars[which(mtcars$col != rows),] 
    } 
    }) 
} 

shinyApp(ui = ui, server = server) 

Answer 1

請參閱下面的代碼爲我的建議。我基本上做了你希望/試圖做的事情，即動態添加觀察者，以便每個新的過濾器元素都有自己的觀察者。事實證明：你可以做到這一點。就這樣。所以我在觀察者內部添加了ui元素的精確觀察事件，以提供他們所需的反應性。我甚至添加了「個人」刪除按鈕，這將比刪除最下面的按鈕更方便。此外，處理所有這些過濾器的邏輯將是一個彙總列表，用於存儲當前在各種過濾器中選擇的所有信息。這使得renderTable部分變得更容易。

請熟悉代碼並詢問是否存在不確定性。

問候

library(shiny) 

ui <- fluidPage(
    sidebarLayout(
    sidebarPanel(
     fluidRow(
     column(6, actionButton('addFilter', 'Add filter')), 
     offset = 6 
    ), 
     tags$hr(), 
     tags$div(id = 'placeholderAddRemFilt'), 
     tags$div(id = 'placeholderFilter'), 
     width = 4 # sidebar 
    ), 
    mainPanel(
     tableOutput("data") 
    ) 
) 
) 

server <- function(input, output,session) { 
    filter <- character(0) 

    makeReactiveBinding("aggregFilterObserver") 
    aggregFilterObserver <- list() 

    observeEvent(input$addFilter, { 
    add <- input$addFilter 
    filterId <- paste0('Filter_', add) 
    colfilterId <- paste0('Col_Filter_', add) 
    rowfilterId <- paste0('Row_Filter_', add) 
    removeFilterId <- paste0('Remove_Filter_', add) 
    headers <- names(mtcars) 
    insertUI(
     selector = '#placeholderFilter', 
     ui = tags$div(id = filterId, 
     actionButton(removeFilterId, label = "Remove filter", style = "float: right;"), 
     selectInput(colfilterId, label = "Some Filter", choices = as.list(headers), selected = 1), 
     checkboxGroupInput(rowfilterId, label = "Select variable values", 
          choices = NULL, selected = NULL, width = 4000) 
    ) 
    ) 

    observeEvent(input[[colfilterId]], { 

     col <- input[[colfilterId]] 
     values <- as.list(unique(mtcars[col]))[[1]] 

     updateCheckboxGroupInput(session, rowfilterId , label = "Select variable values", 
           choices = values, selected = values, inline = TRUE) 

     aggregFilterObserver[[filterId]]$col <<- col 
     aggregFilterObserver[[filterId]]$rows <<- NULL 
    }) 

    observeEvent(input[[rowfilterId]], { 

     rows <- input[[rowfilterId]] 

     aggregFilterObserver[[filterId]]$rows <<- rows 

    }) 

    observeEvent(input[[removeFilterId]], { 
     removeUI(selector = paste0('#', filterId)) 

     aggregFilterObserver[[filterId]] <<- NULL 

    }) 
    }) 

    output$data <- renderTable({ 

    dataSet <- mtcars 

    invisible(lapply(aggregFilterObserver, function(filter){ 

     dataSet <<- dataSet[which(!(dataSet[[filter$col]] %in% filter$rows)), ] 

    })) 

    dataSet 
    }) 
} 

shinyApp(ui = ui, server = server)