Shiny中DT v0.19带下拉选择的可编辑表格cell_edit事件不触发问题

我下方的代码基于公开的技术社区解决方案修改，新增了使用editData更新表格、支持保存/导出更新内容的代码。

该代码在DT v0.18版本可正常运行，但升级到DT v0.19版本后发现id_cell_edit事件似乎无法触发，不确定是否与callback或jquery.contextMenu有关，因DT v0.19已升级到jquery 3.0。

版本行为差异 #

DT v0.18版本运行表现 #

选中usage列将第一行的值从默认的「sel」修改为「id」时：

• DT表格中的值会变更
• tibble视图同步更新
• 下载的CSV文件中的数据也同步更新
• 跳转到下一页查看第11条数据后返回第一页，之前修改的记录仍显示为「id」

DT v0.19版本运行表现 #

选中usage列将第一行的值从默认的「sel」修改为「id」时：

• DT表格中的值会变更
• tibble视图不会更新，下载的CSV文件中的数据也未更新
• 跳转到下一页查看第11条数据后返回第一页，之前做的修改会被清空

reactlog观测差异 #

使用reactlog运行响应式图谱，按照相同步骤将第一行的usage列修改为「id」：

• 第一处差异：v0.18版本中Step 5的reactiveValues###$dt是长度为7的列表，v0.19版本中是长度为8的列表
• 第二处差异：Step 16时v0.18版本中input$dt_cell_edit失效，随后Data、output$table依次失效；而v0.19版本中仅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)

我还将公开的技术社区解决方案适配到我的使用场景中，新增了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)

内容的提问来源于stack exchange，提问作者stomper