將選中的圖標添加到DT閃亮的選定行中

Question

我在閃亮的應用程序中有一個DT表，其背景色設置為匹配某些值。 我還使用表中選定的行來控制應用程序的其他部分。 現在，我的問題是使選定的行變得顯而易見。

通常，表中選定的行會更改背景顏色，但是我沒有此選項，因為我已經設置了背景顏色並且不想更改它。 更改選定行的前景色（字體顏色）不是最佳方法，因為這並不明顯且直觀。

現在，我使選定的行與未選定的行具有不同的不透明度，這在某種程度上可以工作，但仍然不是最佳的。

一種方法是在選中的行中添加一些選中的圖標。 注意，我不希望輸入真正的復選框，因為這會使用戶單擊復選框，而我認為單擊行進行選擇會更容易。

有一些示例顯示DT表中的html內容，但這意味着通過行選擇動態更改表內容，這對我的應用程序是不可接受的，因為每次表內容更改都會觸發表刷新，這會重置行選擇並進入一個循環。

我認為應該可以使用js更改選定的行css類，從而向其添加選中的圖標。 我看到了這個問題，這是一種類似，但是例子是很難理解我。

更新：@StéphaneLaurent的答案完全解決了我的問題。 我之前進行了廣泛的搜索，但沒有找到。

更新2：我的用例更加復雜，並且在適應這種方法時遇到了問題。 我需要2個控制表，並基於單選按鈕控件對其進行切換。 通過動態呈現表，排除狀態將在每個開關中重置。 以前我使用的是DT行選擇，但沒有這個問題。

參見下面的示例，排除表1中的某些行，切換到表2，然后再切換回去，恢復排除狀態。

library(shiny)
library(DT)
# DT checked js ----
rowNames <- FALSE # whether to show row names in the table
colIndex <- as.integer(rowNames)
# making variants since we have two table. not worth a function since only two instances. main changes are function name and shiny input id excludedRows
callback1 <- c(
  sprintf("table.on('click', 'td:nth-child(%d)', function(){", colIndex+1),
  "  var td = this;",
  "  var cell = table.cell(td);",
  "  if(cell.data() === 'ok'){",
  "    cell.data('remove');",
  "  } else {",
  "    cell.data('ok');",
  "  }",
  "  var $row = $(td).closest('tr');",
  "  $row.toggleClass('excluded');",
  "  var excludedRows = [];",
  "  table.$('tr').each(function(i, row){",
  "    if($(this).hasClass('excluded')){",
  "      excludedRows.push(parseInt($(row).attr('id').split('_')[1]));",
  "    }",
  "  });",
  "  Shiny.setInputValue('excludedRows1', excludedRows);",
  "})"
)
callback2 <- c(
  sprintf("table.on('click', 'td:nth-child(%d)', function(){", colIndex+1),
  "  var td = this;",
  "  var cell = table.cell(td);",
  "  if(cell.data() === 'ok'){",
  "    cell.data('remove');",
  "  } else {",
  "    cell.data('ok');",
  "  }",
  "  var $row = $(td).closest('tr');",
  "  $row.toggleClass('excluded');",
  "  var excludedRows = [];",
  "  table.$('tr').each(function(i, row){",
  "    if($(this).hasClass('excluded')){",
  "      excludedRows.push(parseInt($(row).attr('id').split('_')[1]));",
  "    }",
  "  });",
  "  Shiny.setInputValue('excludedRows2', excludedRows);",
  "})"
)
# for select all, not using it now
# restore <- c(
#   "function(e, table, node, config) {",
#   "  table.$('tr').removeClass('excluded').each(function(){",
#   sprintf("    var td = $(this).find('td').eq(%d)[0];", colIndex), 
#   "    var cell = table.cell(td);", 
#   "    cell.data('ok');",
#   "  });",
#   "  Shiny.setInputValue('excludedRows', null);",
#   "}"
# )

render <- c(
  'function(data, type, row, meta){',
  '  if(type === "display"){',
  '    var color = data === "ok" ? "#027eac" : "gray";',
  '    return "<span style=\\\"color:" + color +',
  '           "; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" +', 
  '           data + "\\\"></i></span>";',
  '  } else {',
  '    return data;',
  '  }',
  '}'
)
# test app ----
ui <- fluidPage(
  tags$head(
    tags$style(HTML(
      ".excluded { color: gray; font-style: italic; }"
    ))
  ),
  fluidRow(
    column(
      6, 
      tags$label("Excluded rows Table 1"),
      verbatimTextOutput("excludedRows1"),
      tags$label("Excluded rows Table 2"),
      verbatimTextOutput("excludedRows2")
    ),
    column(
      6, 
      tags$label("Included rows"),
      verbatimTextOutput("includedRows1"),
      verbatimTextOutput("includedRows2")
    )
  ),
  br(),
  radioButtons("select_table", label = "Select table", choices = c("1", "2"), inline = TRUE),
  uiOutput("control_table_ui")
  # tabBox(tabPanel("1", DTOutput("mytable1")),
  #        tabPanel("2", DTOutput("mytable2")))


)
server <- function(input, output,session) {
    output$control_table_ui <- renderUI({
    if (input$select_table == "1") {
      column(12, offset = 0, DTOutput("mytable1"))
    } else {
      column(12, offset = 0, DTOutput("mytable2"))
    }
  })

  dt <- cbind(On = "ok", mtcars[1:6,], id = paste0("row_",1:6))
    row_colors <- rep(c("red", "blue", "green"), 2)
    names(row_colors) <- dt$id
  output[["mytable1"]] <- renderDT({
    datatable(dt, caption = "table 1",
              rownames = rowNames, extensions = c("Select"), 
              selection = "none", callback = JS(callback1),
              options = list(
                # pageLength = 3,
                sort = FALSE,
                rowId = JS(sprintf("function(data){return data[%d];}", 
                                   ncol(dt)-1+colIndex)), 
                columnDefs = list(
                  list(visible = FALSE, targets = ncol(dt)-1+colIndex),
                  list(className = "dt-center", targets = "_all"),
                  list(className = "notselectable", targets = colIndex),
                  list(targets = colIndex, render = JS(render)) 
                ),
                dom = "t",
                # buttons = list(list(
                #                  extend = "collection",
                #                  text = 'Select All', 
                #                  action = JS(restore)
                #                )
                # ),
                select = list(style = "single", selector = "td:not(.notselectable)")
                # select = list(style = 'os', # set 'os' select style so that ctrl/shift + click in enabled
                #               items = 'row') # items can be cell, row or column
              )
    ) %>% 
      formatStyle("id", target = "row",
                 backgroundColor = styleEqual(dt$id, row_colors))
  }, server = FALSE)
      output[["mytable2"]] <- renderDT({
    datatable(dt, caption = "table 2",
              rownames = rowNames, extensions = c("Select"), 
              selection = "none", callback = JS(callback2),
              options = list(
                # pageLength = 3,
                rowId = JS(sprintf("function(data){return data[%d];}", 
                                   ncol(dt)-1+colIndex)), 
                columnDefs = list(
                  list(visible = FALSE, targets = ncol(dt)-1+colIndex),
                  list(className = "dt-center", targets = "_all"),
                  list(className = "notselectable", targets = colIndex),
                  list(targets = colIndex, render = JS(render)) 
                ),
                dom = "t",
                # buttons = list(list(
                #                  extend = "collection",
                #                  text = 'Select All', 
                #                  action = JS(restore)
                #                )
                # ),
                select = list(style = "single", selector = "td:not(.notselectable)")
              )
    ) %>% 
      formatStyle("id", target = "row",
                 backgroundColor = styleEqual(dt$id, row_colors))
  }, server = FALSE)
    output$excludedRows1 <- renderPrint({
      input[["excludedRows1"]]
    })
    output$excludedRows2 <- renderPrint({
      input[["excludedRows2"]]
    })
    output$includedRows1 <- renderPrint({
      setdiff(1:nrow(dt), input[["excludedRows1"]])
    })

}
shinyApp(ui, server)

更新3：根據@StéphaneLaurent的建議，使用conditionalPanel解決了該問題。 盡管它比renderUI慢一些，但是可以正常工作。

Answer 1

感謝@StéphaneLaurent的回答，它是一個很棒的基於js的解決方案，解決了我95％的需求。 但是，由於我的js技能有限，我需要一個按鈕來清除所有選擇，並且無法編寫該選擇。 我也忘記了重要的server=FALSE參數，因此遇到了丟失選擇排序的問題。 因此，我切換回了原來的行選擇機制。

我曾經嘗試通過行選擇來修改表，但這會觸發反應式事件循環。 后來我意識到我只需要更改視圖，而無需更改基礎數據，並且僅通過CSS規則即可更改視圖。

在此處查看示例 ， more icons示例可以顯示不同的圖標，具體取決於復選框的選擇。 通過檢查css規則，我發現兩個圖標一直都存在，只是css規則因選擇狀態而異。

因此，我想出了此解決方案，該解決方案使用了DT中的內置行選擇和一些CSS規則，這樣，您仍然具有DT中行選擇控制的所有功能，而無需使用JS代碼，並且一切都由CSS實現。

library(shiny)
library(DT)
library(data.table)
ui <- fluidPage(
    tags$head(
    tags$style(HTML("
.selected .table-icon-yes {
    opacity: 1;
    display: inline-block;
    color: #3c763d;
}
.table-icon-yes {
    opacity: 0;
    display: none;
}
.selected .table-icon-no {
    opacity: 0;
    display: none;
}
.table-icon-no {
    opacity: 1;
    display: inline-block;
    color: #999;
}
    "))
  ),
  DTOutput("table")
)

icon_col <- tagList(span(class = "table-icon-yes", icon("ok", lib = "glyphicon")),
                    span(class = "table-icon-no", icon("remove", lib = "glyphicon")))

server <- function(input, output, session) {
 output$table <- renderDT({
   dt <- data.table(iris)
   dt[, Selected := as.character(icon_col)]
   setcolorder(dt, c(ncol(dt), 1:(ncol(dt) - 1)))
   datatable(dt, escape = FALSE)
 }) 
}

shinyApp(ui = ui, server = server)