时间戳

首页 > 解决方案 > 有没有办法将选择器/selectInput 与闪亮的可编辑、反应式 DT 结合使用？

r - 有没有办法将选择器/selectInput 与闪亮的可编辑、反应式 DT 结合使用？

问题描述

我一直在努力解决以下问题，并且在 SO 上找不到合适的解决方案。

这是我对 DataTable 的要求

  1. 我想编辑我的数据表（已实现）
  2. 在我的编辑完好无损的情况下过滤 DataTable 中的数据。目前，我的编辑在我更改过滤器后消失
  3. 将整个 DataTable 保存为 RDS，而不仅仅是基于过滤器的当前显示数据。目前，我只是根据过滤器保存当前显示的 DataTable

提前谢谢你的帮助！

df <- iris

species <- unique(as.character(df$Species))
width <- unique(df$Petal.Width)
#==========================================UI=======================================================#
ui = navbarPage("CSAT & SA", theme = shinytheme("flatly"),
                tabPanel("Sentiment Analysis",
                         sidebarLayout(
                           sidebarPanel(
                             pickerInput(inputId = "species",
                                         label = "Species", selected = species,
                                         choices = species, multiple = T, 
                                         options = list(`actions-box` = TRUE, `deselect-all-text` = "None...",
                                                        `select-all-text` = "Select All", `none-selected-text` = "None Selected")),
                             pickerInput(inputId = "width",
                                         label = "Petal Width", selected = width,
                                         choices = width, multiple = T, 
                                         options = list(`actions-box` = TRUE, `deselect-all-text` = "None...",
                                                        `select-all-text` = "Select All", `none-selected-text` = "None Selected")),
                             width = 2, 
                             actionButton(inputId = "save", label = "Save"), 
                             actionButton(inputId = "update", label = "Update")
                           ),
                           mainPanel(
                             h2("Iris"), fluidRow(
                               tabPanel("Iris", DT::dataTableOutput("x1"),
                                        width = 12)
                             )))))
#==========================================SERVER=======================================================#

server <- function(input, output, session) {
  
  SA <- reactive({
    df<-df %>%
      filter(Species %in% input$species) %>%
      filter(Petal.Width %in% input$width)
  }) 
  
  
  rec_val = reactiveValues(df = NULL)
  
  
  observe({
    rec_val$SA <- SA()
  })
  
  output$x1 = renderDT(SA(),  selection = 'none', editable = list(target = 'cell', disable = list(columns=c(0,1,2))))
  
  proxy = dataTableProxy('x1')
  
  observeEvent(input$x1_cell_edit, {
    info = input$x1_cell_edit
    str(info)
    i = info$row
    j = info$col   
    v = info$value
    rec_val$SA[i, j] <<- DT::coerceValue(v, rec_val$SA[i, j])
    replaceData(proxy, rec_val$SA, resetPaging = FALSE)
  })
  
  observeEvent(input$save, {
    saveRDS(rec_val$SA, "somewhere.rds") # write new data out
    
  })

  
  
}

shinyApp(ui = ui, server = server)

编辑：

看这里

标签： rshinydatatabledt

解决方案

您需要用于updatePickerInput()根据编辑更新可用的选项。此外，定义行 id 以保留修改后的数据。使用重置您可以返回到原始数据表。尝试这个

library(shinythemes)
dat <- iris

species <- unique(as.character(dat$Species))
width <- unique(dat$Petal.Width)
#==========================================UI=======================================================#
ui = navbarPage("CSAT & SA", theme = shinytheme("flatly"),
                tabPanel("Sentiment Analysis",
                         sidebarLayout(
                           sidebarPanel(
                             pickerInput(inputId = "species",
                                         label = "Species", selected = species,
                                         choices = as.list(species), multiple = T, 
                                         options = list(`actions-box` = TRUE, `deselect-all-text` = "None...",
                                                        `select-all-text` = "Select All", `none-selected-text` = "None Selected")),
                             pickerInput(inputId = "width",
                                         label = "Petal Width", selected = width,
                                         choices = as.list(width), multiple = T, 
                                         options = list(`actions-box` = TRUE, `deselect-all-text` = "None...",
                                                        `select-all-text` = "Select All", `none-selected-text` = "None Selected")),
                             width = 2, 
                             actionButton(inputId = "save", label = "Save"), 
                             actionButton(inputId = "reset", label = "Reset")
                           ),
                           mainPanel(
                             h2("Iris"), fluidRow(
                               tabPanel("Iris", DT::dataTableOutput("x1"), DTOutput("x2"),
                                        width = 12)
                             )))))
#==========================================SERVER=======================================================#

server <- function(input, output, session) {
  
  SA <- reactive({
    row_id <- c(1:nrow(dat))
    data <- data.frame(dat,row_id)
    data
  })
  
  rv = reactiveValues(df = NULL)
  
  observe({
    rv$df <- SA() %>%
      filter(Species %in% isolate(input$species)) %>%
      filter(Petal.Width %in% isolate(input$width))
  })
  
  observeEvent(input$species, {
                  df1 <- SA()         ### orig data
                  df2 <- rv$df        ### modified data
                  if (is.null(df2)){
                    rvdf <- SA()
                  }else{
                    vn <- colnames(df1)
                    vnx <- paste0(vn,".x")
                    vny <- paste0(vn,".y")

                    rvdf <- left_join(df1, df2, by="row_id") %>% transmute(var1 = get(!!vnx[1]), var2 = get(!!vnx[2]), var3 = get(!!vnx[3]),
                                                                            var4 = ifelse(is.na(get(!!vny[4])), get(!!vnx[4]), get(!!vny[4])),
                                                                            var5 = get(!!vnx[5]),  # ifelse(is.na(get(!!vny[5])), get(!!vnx[5]), get(!!vny[5])),
                                                                            row_id)

                    colnames(rvdf) <- vn
                  }
                  rv$df <- rvdf  %>%
                    filter(Species %in% input$species) %>% 
                    filter(Petal.Width %in% input$width)

  })
  
  observeEvent(input$width, {
    df1 <- SA()         ### orig data
    df2 <- rv$df        ### modified data
    if (is.null(df2)){
      rvdf <- SA()
    }else{
      
      vn <- colnames(df1)
      vnx <- paste0(vn,".x")
      vny <- paste0(vn,".y")
      ###    keep modified data, if present; if not, keep original data
      rvdf <- left_join(df1, df2, by="row_id") %>% transmute(var1 = get(!!vnx[1]), var2 = get(!!vnx[2]), var3 = get(!!vnx[3]),
                                                              var4 = ifelse(is.na(get(!!vny[4])), get(!!vnx[4]), get(!!vny[4])),  ##  keep modified data
                                                              var5 = get(!!vnx[5]),  # ifelse(is.na(get(!!vny[5])), get(!!vnx[5]), get(!!vny[5])),
                                                              row_id)
      
      colnames(rvdf) <- vn
      
    }
    rv$df <- rvdf  %>%
      filter(Species %in% input$species) %>% 
      filter(Petal.Width %in% input$width)
    
  })
  
  output$x1 <- renderDT(rv$df,  selection = 'none',
                       editable = list(target = 'cell', disable = list(columns=c(0,1,2))),
                       options = list(
                         columnDefs = list(
                           list(
                             visible = FALSE,
                             targets = 6
                           )
                         )
                       )
                       )
  
  proxy <- dataTableProxy('x1')
  
  observeEvent(input$x1_cell_edit, {
    info = input$x1_cell_edit
    str(info)
    i = info$row
    j = info$col   
    v = info$value
    
    rv$df[i, j] <<- DT::coerceValue(v, rv$df[i, j])
    
    #replaceData(proxy, rv$df, resetPaging = FALSE)
    
  })
  
  observeEvent(input$save, {
    #choicess <- as.list(unique(c(as.character(rv$df[,5]), as.character(SA()[,5]))))
    choicesp <- as.list(unique(c(rv$df[,4], SA()[,4])))
    # updatePickerInput(session, inputId = "species", choices = choicess, selected=choicess)
    updatePickerInput(session, inputId = "width", choices = choicesp, selected=choicesp)
    saveRDS(rv$df, "somewhere.rds") # write new data out
    
    df3 <- readRDS("C:/My Disk Space/_My Work/RStuff/GWS/somewhere.rds")
    output$x2 <- renderDT({
      df3
    })
    
  })
  observeEvent(input$reset, {
    rv$df <- SA()
    # choicess <- unique(as.character(rv$df[,5]))
    choicesp <- unique(SA()[,4])
    # updatePickerInput(session, inputId = "species", choices = choicess, selected=choicess)
    updatePickerInput(session, inputId = "width", choices = choicesp, selected=choicesp)
  })
  
}

shinyApp(ui = ui, server = server)

推荐阅读