DT中响应式颜色选择器问题：颜色选择无法更新Reactive值

现有Shiny+DT+ggplot2代码中，直接修改十六进制颜色字符串可实现DT表格与绘图的颜色同步更新，且会话中能保留修改。但改用颜色选择器（原生HTML color输入或shinyWidgets组件）后，仅视觉上颜色变化，无法触发input$table_cell_edit事件，导致reactiveValues对象meta中的数据无法更新，进而绘图颜色也无法同步。

可用代码（十六进制手动输入版） #

library(shiny)
library(DT)
library(ggplot2)

ui <- fluidPage(
    DTOutput("table"),
    plotOutput("plot") 
)

server <- function(input, output, session) {

    mdf <- data.frame(
        station = c("Station 1", "Station 2", "Station 3"),
        color = c("#1f77b4", "#ff7f0e", "#d62728"),
        value = c(1, 2, 3)
    )

    meta <- reactiveValues(data = mdf)
    proxy <- dataTableProxy("table")

    observeEvent(input$table_cell_edit, {
        info <- input$table_cell_edit
        i <- info$row
        j <- info$col + 1
        k <- info$value

        isolate({
            meta$data[i, j] <- k
        })

        replaceData(proxy, meta$data, resetPaging = FALSE)
    })

    observe({
        print(meta$data$color)
    })

    output$table <- renderDT({
        datatable(
            meta$data,
            editable = TRUE,
            rownames = FALSE
        )
    })

    output$plot <- renderPlot({
        ggplot(meta$data, aes(x = station, y = value)) +
        geom_point(aes(color = station), size = 5) +
        scale_color_manual(values = meta$data$color)
    })

}

shinyApp(ui, server)

失效代码（颜色选择器版） #

library(shiny)
library(DT)
library(ggplot2)
library(shinyWidgets)

ui <- fluidPage(
    DTOutput("table"),
    plotOutput("plot") 
)

server <- function(input, output, session) {

    mdf <- data.frame(
        station = c("Station 1", "Station 2", "Station 3"),
        color = c("#1f77b4", "#ff7f0e", "#d62728"),
        value = c(1, 2, 3)
    )

    meta <- reactiveValues(data = mdf)
    proxy <- dataTableProxy("table")

    observeEvent(input$table_cell_edit, {
        info <- input$table_cell_edit
        i <- info$row
        j <- info$col + 1
        k <- info$value

        isolate({
            meta$data[i, j] <- k
        })

        replaceData(proxy, meta$data, resetPaging = FALSE)
    })

    observe({
        print(meta$data$color)
    })

    output$table <- renderDT({
        datatable(
            meta$data,
            editable = TRUE,
            rownames = FALSE,
            escape = FALSE,
            options = list(
                columnDefs = list(
                    list(targets = 1, render = JS(
                        "function(data, type, row, meta) {",
                        "return '<input type=\"color\" value=\"' + data + '\">';",
                        "}")
                    )
                )
            )
        )
    })

    output$plot <- renderPlot({
        ggplot(meta$data, aes(x = station, y = value)) +
            geom_point(aes(color = station), size = 5) +
            scale_color_manual(values = meta$data$color)
    })

}

shinyApp(ui, server)

解决方案 #

问题核心：DT的input$table_cell_edit仅响应DT自带的单元格编辑行为，自定义插入的input[type="color"]组件需要手动绑定事件来同步数据到Shiny。

修改后的代码如下：

library(shiny)
library(DT)
library(ggplot2)

ui <- fluidPage(
    DTOutput("table"),
    plotOutput("plot") 
)

server <- function(input, output, session) {

    mdf <- data.frame(
        station = c("Station 1", "Station 2", "Station 3"),
        color = c("#1f77b4", "#ff7f0e", "#d62728"),
        value = c(1, 2, 3)
    )

    meta <- reactiveValues(data = mdf)
    proxy <- dataTableProxy("table")

    # 处理value列的原生单元格编辑
    observeEvent(input$table_cell_edit, {
        info <- input$table_cell_edit
        i <- info$row
        j <- info$col + 1
        k <- info$value

        isolate({
            meta$data[i, j] <- k
        })

        replaceData(proxy, meta$data, resetPaging = FALSE)
    })

    # 监听颜色选择器的变化事件
    observeEvent(input$color_change, {
        info <- input$color_change
        i <- info$row
        new_color <- info$color

        isolate({
            meta$data[i, "color"] <- new_color
        })

        replaceData(proxy, meta$data, resetPaging = FALSE)
    })

    observe({
        print(meta$data$color)
    })

    output$table <- renderDT({
        datatable(
            meta$data,
            editable = list(targets = 2), # 仅允许value列使用原生编辑
            rownames = FALSE,
            escape = FALSE,
            options = list(
                columnDefs = list(
                    list(targets = 1, render = JS(
                        "function(data, type, row, meta) {",
                        // 创建带行号标记的颜色选择器
                        "var input = '<input type=\"color\" value=\"' + data + '\" data-row=\"' + meta.row + '\">';",
                        // 绑定change事件，将数据发送到Shiny
                        "$(document).on('change', 'input[type=\"color\"]', function() {",
                        "var row = $(this).data('row');",
                        "Shiny.setInputValue('color_change', {row: row + 1, color: $(this).val()}, {priority: 'event'});",
                        "});",
                        "return input;",
                        "}")
                    )
                )
            )
        )
    })

    output$plot <- renderPlot({
        ggplot(meta$data, aes(x = station, y = value)) +
            geom_point(aes(color = station), size = 5) +
            scale_color_manual(values = meta$data$color)
    })

}

shinyApp(ui, server)

修改说明 #

1. 限制原生编辑范围：将editable设置为list(targets = 2)，仅允许value列使用DT原生编辑，避免和颜色选择器冲突。
2. 添加JS事件监听：在颜色选择器渲染时绑定change事件，通过Shiny.setInputValue将选中的颜色值和对应行号发送到Shiny的input$color_change。
3. 新增颜色更新观察者：在server端监听input$color_change，更新meta$data中对应行的颜色值，并同步到DT表格。
4. 行号适配：DT的JS索引从0开始，发送给Shiny时需+1，对应R数据框的行号。

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