排序后的单元颜色重置

Question

我正在尝试将一个单元格在数据表中更改其背景颜色后。 stéphane's>stéphane's解决方案在一定程度上起作用，一旦表格或过滤表，颜色就会消失。有没有办法跟踪编辑的单元格，并且由于浏览器端在浏览器端被操纵而进行了颜色？

以下是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

问题在于您正在为可见的行着色，这不必与物理行对应。

一种可能的解决方案是在 server 方面进行着色，这样的

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的辅助列（在突变调用）
2. 创建反应性，该保存当前数据，包括用户完成的更改。
3. 在renderdt函数中，您可以参考reactiveVal（而不是静态data.frame.frame），隐藏助手列并使用格式>格式>格式根据关联*_更改列中的相应值对彩色单元格进行彩色。
4. 最后一部分是通过调整您的ObserveEvent来保持客户端和服务器保持同步，在其中我们通过相应的*_更改列来标记一个单元格，并更改值客户端的更改。

nb 请注意，当JS基于0时，您的r是1，因此您需要通过-1 -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对象。