带有过滤数据的R Shiny DataTable动态行选择

时间：2017-12-14 12:49:21

标签： r shiny dt

我想要实现的目标：

行选择和基于selectizeInput()的过滤器的组合，无论是否应用过滤器，都会保留所选行。

我尝试将行ID保存在无效值中，并为每个选择更新它，但我不能让它正常工作。在应用过滤器后，它会与行索引混淆。

在下面的示例代码中，我还添加了一种组选择：因此，如果选择了一个组的一个成员，则最后一列会显示为绿色。那是因为我想在组内建立一个过滤器，如果发生选择，应该在'背景'中选择整个组。

总的来说这是正确的方法吗？ 

library(shiny)
library(DT)
shinyApp(
  ui = fluidPage( 
    tags$span(icon('toggle-off'), style = "display: none;") ,
    tags$head(tags$style(".fa-toggle-off {color:#9b1f23}")),
    tags$head(tags$style(".fa-toggle-on {color:#a2ad00}")),
    selectizeInput("choose_grp","choose grp", choices = c("No Filter" = "", 1:20), multiple = T),
    DT::dataTableOutput('x1'), verbatimTextOutput('x2'), verbatimTextOutput('x3')),

  server = function(input, output, session) {

    # a sample data frame
    N <- 100
    res = data.frame(
      v1 = paste0('test', 1:N),
      v2 = ifelse(!duplicated(rep(1:20,each = 5)), rep(1:20,each = 5), NA),
      v2_grp = rep(1:20,each = 5),
      r_g = rep('r', N),
      r_g_grp = rep('r', N),
      v3 = ifelse(!duplicated(rep(1:20,each = 5)), 
                  as.character(icon('toggle-off')), NA),
      ID = 1: N,
      stringsAsFactors = FALSE
    )

    # reactive values to store selected rows
    sel_all <- reactiveValues(all = data.frame(ID = res$ID, sel = rep(F,N)))
    save_sel_vals <- reactiveValues(a = c(), d = c())

    # observer for reactive values to change preselected rows 
    observe({
      res_old <- res
      if (is.null(input$choose_grp)){
        res <- res
      }  else if (any(input$choose_grp != "")){
        res <- res[res$v2_grp %in% as.numeric(input$choose_grp),]
      }

      a_sel <- sel_all$all$sel[sel_all$all$ID %in% res$ID]

      a <- data.frame(IDs = res$ID,
                      sel = a_sel)
      if (is.null(input$x1_rows_selected)) {
        a[, 'sel'] <- F
      } else {
        a[input$x1_rows_selected, 'sel'] <- T
        a[- input$x1_rows_selected, 'sel'] <- F
      }

      sel_all$all$sel[sel_all$all$ID %in% a$IDs] <- a$sel


      isolate(a2 <- sel_all$all$sel[sel_all$all$ID %in% a$IDs])
      isolate(d <- input$x1_cell_clicked$row -1)

      save_sel_vals$a <- a2
      save_sel_vals$d <- d
    })


    # render the table containing shiny inputs
    output$x1 = DT::renderDataTable({

      sel_rows <- save_sel_vals$a
      res$r_g[sel_rows] <- 'g'
      res$r_g_grp <- ifelse(res$v2_grp %in% res$v2_grp[sel_rows], 'g', 'r')
      res$v3 <- ifelse(!is.na(res$v3), ifelse(  
        (res$v2_grp %in% res$v2_grp[sel_rows]), as.character(icon('toggle-on')), as.character(icon('toggle-off'))),
        NA)

      if (is.null(input$choose_grp)){
        res <- res
      }  else if (any(input$choose_grp != "")){
        res <- res[res$v2_grp %in% as.numeric(input$choose_grp),]
      }

      datatable(res, extensions = c('Scroller'), escape = F, 
                selection = list(mode = "multiple", target= 'row', selected = (1:nrow(res))[sel_rows]),
                options = list(scrollX = T,
                               autoWidth = F,
                               deferRender = TRUE,
                               scrollY = 500,
                               scroller = T,
                               paging = T
                ), callback = JS(paste0('table.row(',save_sel_vals$d,').scrollTo(false);'))
      ) %>%
        formatStyle(
          columns = c("v3"), valueColumns = 'r_g_grp',
          target = 'cell',
          backgroundColor = styleEqual(c('r','g'), c('#e1a593','#d8dea8'))
        )
    } , server = F
    )

    # print the values of inputs
    output$x2 = renderPrint({

      data.frame(selected_row = input$x1_rows_selected,
                 selected_grp = res$v2_grp[input$x1_rows_selected]
      )
    })

    output$x3 = renderPrint({
      sel_all$all[1:10,]
    })
  }
)

1 个答案:

答案 0 :(得分：1)

自己想出来： 为了摆脱选定的行依赖性，我将observer()拆分为两个observeEvent()函数，一个用于选定的ID，另一个用于在所选ID上设置过滤器。 

library(shiny)
library(DT)

options(shiny.reactlog=TRUE)

shinyApp(
  ui = fluidPage( 
    tags$span(icon('toggle-off'), style = "display: none;") ,
    tags$head(tags$style(".fa-toggle-off {color:#9b1f23}")),
    tags$head(tags$style(".fa-toggle-on {color:#a2ad00}")),
    selectizeInput("choose_grp","choose grp", choices = c("No Filter" = "", 1:20), multiple = T),
    DT::dataTableOutput('x1'), verbatimTextOutput('x2'), verbatimTextOutput('x3')),

  server = function(input, output, session) {

    # a sample data frame
    N <- 100
    res = data.frame(
      v1 = paste0('test', 1:N),
      v2 = ifelse(!duplicated(rep(1:20,each = 5)), rep(1:20,each = 5), NA),
      v2_grp = rep(1:20,each = 5),
      r_g = rep('r', N),
      r_g_grp = rep('r', N),
      v3 = ifelse(!duplicated(rep(1:20,each = 5)), 
                  as.character(icon('toggle-off')), NA),
      ID = 1: N,
      stringsAsFactors = FALSE
    )

    # reactive values to store selected rows
    sel_all <- reactiveValues(all = data.frame(ID = res$ID, sel = rep(F,N)))
    save_sel_vals <- reactiveValues(a = c(), d = c())


    # observer selected rows/groups
    observeEvent(input$x1_cell_clicked$row,{
      res_old <- res
      if (is.null(input$choose_grp)){
        res <- res
      }  else if (any(input$choose_grp != "")){
        res <- res[res$v2_grp %in% as.numeric(input$choose_grp),]
      }

      a_sel <- sel_all$all$sel[sel_all$all$ID %in% res$ID]

      a <- data.frame(IDs = res$ID,
                      sel = a_sel)
      if (is.null(input$x1_cell_clicked$row)) {
        a[, 'sel'] <- F
      } else if (isTRUE(a[input$x1_cell_clicked$row, 'sel'])){
        a[input$x1_cell_clicked$row, 'sel'] <- F
      } else  if (!isTRUE(a[input$x1_cell_clicked$row, 'sel'])){
        a[input$x1_cell_clicked$row, 'sel'] <- T
      }

      sel_all$all$sel[sel_all$all$ID %in% a$IDs] <- a$sel


      isolate(a2 <- sel_all$all$sel[sel_all$all$ID %in% a$IDs])
      isolate(d <- input$x1_cell_clicked$row -1)

      save_sel_vals$a <- a2
      save_sel_vals$d <- d
    }, ignoreNULL = TRUE)


    # observer IDs of filtered data
    observeEvent(input$choose_grp, {
      res_old <- res
      if (is.null(input$choose_grp)){
        res <- res
      }  else if (any(input$choose_grp != "")){
        res <- res[res$v2_grp %in% as.numeric(input$choose_grp),]
      }

      a_sel <- sel_all$all$sel[sel_all$all$ID %in% res$ID]

      a <- data.frame(IDs = res$ID,
                      sel = a_sel)

      isolate(a2 <- sel_all$all$sel[sel_all$all$ID %in% a$IDs])
      save_sel_vals$a <- a2

    }, ignoreNULL = FALSE)


    # render the table containing shiny inputs
    output$x1 = DT::renderDataTable({

      if (is.null(input$choose_grp)){
        res <- res
      }  else if (any(input$choose_grp != "")){
        res <- res[res$v2_grp %in% as.numeric(input$choose_grp),]
      }

      sel_rows <- save_sel_vals$a
      res$r_g[sel_rows] <- 'g'
      res$r_g_grp <- ifelse(res$v2_grp %in% res$v2_grp[sel_rows], 'g', 'r')
      res$v3 <- ifelse(!is.na(res$v3), ifelse(  
        (res$v2_grp %in% res$v2_grp[sel_rows]), as.character(icon('toggle-on')), as.character(icon('toggle-off'))),
        NA)

      datatable(res, extensions = c('Scroller'), escape = F, 
                selection = list(mode = "multiple", target= 'row', selected = (1:nrow(res))[sel_rows]),
                options = list(scrollX = T,
                               autoWidth = F,
                               deferRender = TRUE,
                               scrollY = 500,
                               scroller = T,
                               paging = T
                ), callback = JS(paste0('table.row(',save_sel_vals$d,').scrollTo(false);'))
      ) %>%
        formatStyle(
          columns = c("v3"), valueColumns = 'r_g_grp',
          target = 'cell',
          backgroundColor = styleEqual(c('r','g'), c('#e1a593','#d8dea8'))
        )
    } , server = F
    )

    # print the values of inputs
    output$x2 = renderPrint({

      data.frame(selected_row = input$x1_rows_selected,
                 selected_grp = res$v2_grp[input$x1_rows_selected]
      )
    })

    output$x3 = renderPrint({
      sel_all$all[1:10,]
    })
  }
)
相关问题
最新问题