排序后单元格颜色重置

Question

我试图让数据表中的单元格在编辑后更改其背景颜色。虽然Stéphane 的解决方案 在一定程度上有效，但一旦表格被排序或过滤，颜色就会消失。有没有办法跟踪编辑的单元格并在浏览器端操作数据表时将其着色？

下面是 Stéphane 开发的解决方案，也是一个很好的可重复示例。

library(shiny)
library(shinyjs)
library(DT)

js <- HTML(
  "function colorizeCell(i, j){
    var selector = '#dtable tr:nth-child(' + i + ') td:nth-child(' + j + ')';
    $(selector).css({'background-color': 'yellow'});
  }"
)

colorizeCell <- function(i, j){
  sprintf("colorizeCell(%d, %d)", i, j)
}

ui <- fluidPage(
  useShinyjs(),
  tags$head(
    tags$script(js)
  ),
  br(),
  DTOutput("dtable")
)

dat <- iris[1:5, ]

server <- function(input, output, session){
  
  output[["dtable"]] <- renderDT({
    datatable(dat, editable = TRUE, selection = "none")
  }, server = FALSE)
  
  observeEvent(input[["dtable_cell_edit"]], {
    info <- input[["dtable_cell_edit"]]
    i <- info[["row"]]
    j <- info[["col"]]
    runjs(colorizeCell(i, j+1))
  })
  
}

shinyApp(ui, server)

Answer 1

问题是您正在为可见行着色，该行不需要与物理行相对应。

一种可能的解决方案是在服务器端进行着色，如下所示：

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

dat <- iris[1:5, ]

ui <- fluidPage(
  DTOutput("dtable")
)

server <- function(input, output, session){
  
  my_table <- reactiveVal({
    new_dat <- dat %>% 
      mutate(across(everything(), list(changed = ~ FALSE)))
    ord <- c(rbind(names(dat), paste0(names(dat), "_changed")))
    new_dat %>% 
      select(all_of(ord))
  })
  
  output[["dtable"]] <- renderDT({
    targets <- which(grepl("_changed$", names(my_table()))) - 1L
    fns <- lapply(targets, function(ind) 
      function(table) {
        formatStyle(table, ind, ind + 1L,
                    backgroundColor = styleEqual(TRUE, "yellow"))
      }) %>% 
      do.call(Compose, .)
    datatable(my_table(), editable = TRUE, selection = "none", rownames = FALSE,
              options = list(columnDefs = list(list(visible = FALSE,
                                                    targets = targets)))) %>% 
      fns()
  })
  
  observeEvent(input[["dtable_cell_edit"]], {
    info <- input[["dtable_cell_edit"]]
    row <- info$row
    col <- info$col + 1L
    dat <- my_table()
    dat[row, col + 1L] <- TRUE
    dat[row, col] <- info$value
    my_table(dat)
  })
  
}

shinyApp(ui, server)

这个想法是：

1. 为每个原始列添加后缀为

   _changed

   的辅助列（在

   mutate

   调用中完成）
2. 创建一个

   reactive

   ，其中保存当前数据，包括用户所做的更改。
3. 在

   renderDT

   函数中，您引用

   reactiveVal

   （而不是静态

   data.frame

   ），隐藏辅助列并使用

   formatStyle

   根据关联的

   *_changed

   列中的相应值为单元格着色。
4. 最后一部分是通过调整您的

   observeEvent

   来保持客户端和服务器同步，我们通过相应的

   *_changed

   列将单元格标记为已更改，并更改值以反映客户端的更改。

N.B. 请注意，R 是基于 1 的，而 JS 是基于 0 的，因此您需要将目标索引偏移

-1

（因为我删除了行名称，否则这些行名称在 JS 中将位于 0 处）。无论出于何种奇怪的原因，这不适用于

formatStyle

函数。

---

更新

要保持过滤器持久，您需要存储它们并重新应用它们：

server <- function(input, output, session){
  
  filter_state <- reactiveValues(search = NULL, search_columns = NULL)
  
  format_table <- function(dat) {
    targets <- which(grepl("_changed$", names(dat))) - 1L
    fns <- lapply(targets, function(ind) 
      function(table) {
        formatStyle(table, ind, ind + 1L,
                    backgroundColor = styleEqual(TRUE, "yellow"))
      }) %>% 
      do.call(Compose, .)
    datatable(dat, editable = TRUE, selection = "none", rownames = FALSE,
              options = list(columnDefs = list(list(visible = FALSE,
                                                    targets = targets)))) %>% 
      fns()  
  }
  
  proxy <- dataTableProxy("dtable")
  
  my_table <- reactiveVal({
    new_dat <- dat %>% 
      mutate(across(everything(), list(changed = ~ FALSE)))
    ord <- c(rbind(names(dat), paste0(names(dat), "_changed")))
    new_dat %>% 
      select(all_of(ord))
  })
  
  output[["dtable"]] <- renderDT({
    isolate({
      filter_state$search <- input[["dtable_search"]]
      filter_state$search_columns <- input[["dtable_search_columns"]]
    })
    dat <- my_table()
    format_table(dat)
  })
  
  observeEvent(input[["dtable_cell_edit"]], {
    info <- input[["dtable_cell_edit"]]
    row <- info$row
    col <- info$col + 1L
    dat <- my_table()
    dat[row, col + 1L] <- TRUE
    dat[row, col] <- info$value
    my_table(dat)
  })
  
  observeEvent(c(filter_state$search, filter_state$search_columns), {
    proxy %>% 
      updateSearch(list(global = filter_state$search, 
                        columns = filter_state$search_columns))
  })
  
}

主要思想是，在渲染时，我们存储搜索字符串 - 既用于整体搜索 (

dtable_search

) 又用于潜在的特定列搜索 (

dtable_search_columns

)。然后我们所要做的就是对

dataTableProxy

对象应用相同的搜索。