通过下拉选择以闪亮方式编辑数据表（适用于 DT v0.19）

Question

我基于 Stephane Laurent 在 Stack Overflow 上对以下问题的解决方案编写了以下代码：

我在代码中添加了使用 editData 来更新表并能够保存/导出更新。

以下内容适用于 DT v0.18，但使用 DT v0.19 我发现 id_cell_edit 似乎没有触发。我不确定它是否与回调有关，或者可能与 DT v0.19 升级到 jquery 3.0 的 jquery.contextMenu 有关。如果人们对如何解决这个问题有任何见解，我将不胜感激。

以下是我在使用 v0.18 时观察到的行为的描述。当我选择使用列并将第一行的值从默认的“sel”更新为“id”时，DT 表中的值会发生变化。我还看到它更新了 tibble 的视图，因此下载 csv 文件中的数据也更新了。如果我进入下一页查看第 11 项，然后返回第一页，我可以看到我更新的记录仍然显示“id”。

以下是我在使用 v0.19 时观察到的行为的描述。当我选择使用列并将第一行的值从默认的“sel”更新为“id”时，DT 表中的值会发生变化。它不会更新 tibble 的视图，因此下载 csv 文件中的数据不会更新。如果我进入下一页查看第 11 项，然后返回第一页，我所做的更新将被清除。

请注意，我还使用reactlog 运行反应图。我按照相同的步骤将第一行的用法列更新为“id”。我注意到的第一个区别是，当我使用版本 v0.18 时，步骤 5 中的reactiveValues###$dt 给出了 7 的列表，而当我使用版本 v0.19 时，则给出了 8 的列表。在步骤 16，对于 v0.18，input$dt_cell_edit 无效，然后 Data 无效，output$table 无效。然而，在使用 v0.19 时的第 16 步，output$dt 无效，然后 output$table 无效。换句话说，使用 v0.19 时 input$dt_cell_edit 和 Data 不会失效。

library(shiny)
library(DT)
library(dplyr)

cars_df <- mtcars
cars_meta <- dplyr::tibble(variables = names(cars_df), data_class = sapply(cars_df, class), usage = "sel")
cars_meta$data_class <- factor(cars_meta$data_class,  c("numeric", "character", "factor", "logical"))
cars_meta$usage <- factor(cars_meta$usage,  c("id", "meta", "demo", "sel", "text"))


callback <- c(
    "var id = $(table.table().node()).closest('.datatables').attr('id');",
    "$.contextMenu({",
    "  selector: '#' + id + ' td.factor input[type=text]',",
    "  trigger: 'hover',",
    "  build: function($trigger, e){",
    "    var levels = $trigger.parent().data('levels');",
    "    if(levels === undefined){",
    "      var colindex = table.cell($trigger.parent()[0]).index().column;",
    "      levels = table.column(colindex).data().unique();",
    "    }",
    "    var options = levels.reduce(function(result, item, index, array){",
    "      result[index] = item;",
    "      return result;",
    "    }, {});",
    "    return {",
    "      autoHide: true,",
    "      items: {",
    "        dropdown: {",
    "          name: 'Edit',",
    "          type: 'select',",
    "          options: options,",
    "          selected: 0",
    "        }",
    "      },",
    "      events: {",
    "        show: function(opts){",
    "          opts.$trigger.off('blur');",
    "        },",
    "        hide: function(opts){",
    "          var $this = this;",
    "          var data = $.contextMenu.getInputValues(opts, $this.data());",
    "          var $input = opts.$trigger;",
    "          $input.val(options[data.dropdown]);",
    "          $input.trigger('change');",
    "        }",
    "      }",
    "    };",
    "  }",
    "});"
)

createdCell <- function(levels){
    if(missing(levels)){
        return("function(td, cellData, rowData, rowIndex, colIndex){}")
    }
    quotedLevels <- toString(sprintf("\"%s\"", levels))
    c(
        "function(td, cellData, rowData, rowIndex, colIndex){",
        sprintf("  $(td).attr('data-levels', '[%s]');", quotedLevels),
        "}"
    )
}

ui <- fluidPage(
    tags$head(
        tags$link(
            rel = "stylesheet",
            href = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.8.0/jquery.contextMenu.min.css"
        ),
        tags$script(
            src = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.8.0/jquery.contextMenu.min.js"
        )
    ),
    DTOutput("dt"),
    br(),
    verbatimTextOutput("table"),
    br(),
    downloadButton('download',"Download the data")
    
)

server <- function(input, output){
    
    dat <- cars_meta
    
    value <- reactiveValues()
    value$dt<-
        datatable(
            dat, editable = "cell", callback = JS(callback),
            options = list(
                columnDefs = list(
                    list(
                        targets = 2,
                        className = "factor",
                        createdCell = JS(createdCell(c(levels(cars_meta$data_class), "another level")))
                    ),
                    list(
                        targets = 3,
                        className = "factor",
                        createdCell = JS(createdCell(c(levels(cars_meta$usage), "another level")))
                    )
                )
            )
        )
    
    output[["dt"]] <- renderDT({
        value$dt
        
    }, 
    server = TRUE)
    
    Data <- reactive({
        info <- input[["dt_cell_edit"]]
        if(!is.null(info)){
            info <- unique(info)
            info$value[info$value==""] <- NA
            dat <-  editData(dat, info, proxy = "dt")
        }
        dat
    })
    
    
    #output table to be able to confirm the table updates
    output[["table"]] <- renderPrint({Data()})  
    
    output$download <- downloadHandler(
        filename = function(){"Data.csv"}, 
        content = function(fname){
            write.csv(Data(), fname)
        }
    )
}

shinyApp(ui, server)

下面我将 ismirsehregal 的解决方案运用到我的用例中。我还在 renderPrint/verbatimTextOutput 中添加了内容，以说明我试图对基础数据执行的操作。我希望能够捕获值而不是输入容器。本质上，我试图通过代码为用户提供一个数据集，允许他们更改一些值，但通过下拉列表限制选择，然后使用更新的数据集进行进一步处理。此时，在解决方案中，我不知道如何获取更新的数据集，以便我可以使用它，例如导出到 csv 文件。

library(DT)
library(shiny)
library(dplyr)


cars_df <- mtcars
selectInputIDa <- paste0("sela", 1:length(cars_df))
selectInputIDb <- paste0("selb", 1:length(cars_df))

initMeta <- dplyr::tibble(
    variables = names(cars_df), 
    data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor", "logical"), selected = sapply(cars_df, class)))}),
    usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = "sel"))})
)



ui <- fluidPage(
    DT::dataTableOutput(outputId = 'my_table'),
    br(),
    verbatimTextOutput("table")
)


server <- function(input, output, session) {
    
    
    displayTbl <- reactive({
        dplyr::tibble(
            variables = names(cars_df), 
            data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor", "logical"), selected = input[[x]]))}),
            usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = input[[x]]))})
        )
    })
    
    

    
    output$my_table = DT::renderDataTable({
        DT::datatable(
            initMeta, escape = FALSE, selection = 'none', rownames = FALSE,
            options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                           preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                           drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
            )
        )
    }, server = TRUE)
    
    my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
    
    observeEvent({sapply(selectInputIDa, function(x){input[[x]]})}, {
        replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
    }, ignoreInit = TRUE)
    
    observeEvent({sapply(selectInputIDb, function(x){input[[x]]})}, {
        replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
    }, ignoreInit = TRUE)
    
    
    
    output$table <- renderPrint({displayTbl()})  
    
    
}

shinyApp(ui = ui, server = server)

Answer 1

要获取

resultTbl

，您只需访问

input[x]

即可：

library(DT)
library(shiny)
library(dplyr)

cars_df <- mtcars
selectInputIDa <- paste0("sela", 1:length(cars_df))
selectInputIDb <- paste0("selb", 1:length(cars_df))

initMeta <- dplyr::tibble(
  variables = names(cars_df), 
  data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor", "logical"), selected = sapply(cars_df, class)))}),
  usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = "sel"))})
)

ui <- fluidPage(
  # please see: https://github.com/rstudio/shiny/issues/3979#issuecomment-1920046008
  # alternative: set selectize = FALSE in selectInput
  htmltools::findDependencies(selectizeInput("dummy", label = NULL, choices = NULL)),
  DT::dataTableOutput(outputId = 'my_table'),
  br(),
  verbatimTextOutput("table")
)

server <- function(input, output, session) {
  
  displayTbl <- reactive({
    dplyr::tibble(
      variables = names(cars_df), 
      data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor", "logical"), selected = input[[x]]))}),
      usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = input[[x]]))})
    )
  })
  
  resultTbl <- reactive({
    dplyr::tibble(
      variables = names(cars_df), 
      data_class = sapply(selectInputIDa, function(x){input[[x]]}),
      usage = sapply(selectInputIDb, function(x){input[[x]]})
    )
  })
  
  output$my_table = DT::renderDataTable({
    DT::datatable(
      initMeta, escape = FALSE, selection = 'none', rownames = FALSE,
      options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                     preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                     drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
      )
    )
  }, server = TRUE)
  
  my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
  
  observeEvent({sapply(selectInputIDa, function(x){input[[x]]})}, {
    replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
  }, ignoreInit = TRUE)
  
  observeEvent({sapply(selectInputIDb, function(x){input[[x]]})}, {
    replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
  }, ignoreInit = TRUE)
  
  output$table <- renderPrint({resultTbl()})  
  
}

shinyApp(ui = ui, server = server)

PS：这是基于我之前的回答这里。

PPS：这里可以找到后续帖子。

通过下拉选择以闪亮方式编辑数据表（适用于 DT v0.19）

问题描述投票：0回答：1

1个回答

最新问题

通过下拉选择以闪亮方式编辑数据表（适用于 DT v0.19）

问题描述 投票：0回答：1

1个回答

最新问题

问题描述投票：0回答：1