我在闪亮的应用程序中有一个DT表，该表的背景色设置为匹配某些值。我还使用表中选定的行来控制应用程序的其他部分。现在，我的问题是要清楚选择了哪些行。
通常，表中选定的行会更改背景颜色，但是我没有此选项，因为我已经设置了背景颜色并且不想更改它。更改所选行的前景色（字体颜色）不是最佳选择，因为这不明显且不直观。
现在，我使选定的行与未选定的行具有不同的不透明度，这在某种程度上可以工作，但仍然不是最佳的。
一种方法是将某些选中的图标添加到所选行。注意，我不希望输入真正的复选框，因为这将导致用户单击复选框，而我认为单击行进行选择会更容易。
有一些示例在DT表中显示html内容，但这意味着通过行选择动态更改表内容，这对我的应用程序是不可接受的，因为每次表内容更改都会触发表刷新，从而重置行选择并进入一个循环。
我认为应该可以使用js更改选定的行css类，从而向其添加选中的图标。我看到this question有点相似，但是这个例子对我来说很难理解。
更新：@StéphaneLaurent的This answer完全解决了我的问题。我之前进行了广泛的搜索，但没有找到它。
更新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慢一点，但是可以正常工作。
答案 0 :(得分：0)
感谢@StéphaneLaurent的回答，它是一个很棒的基于js的解决方案，解决了我95％的需求。但是，由于我的js技能有限，我需要一个按钮来清除所有选择，并且无法编写该选择。我也忘记了重要的server=FALSE参数，因此遇到了对丢失的选择进行排序的问题。因此，我切换回了原来的行选择机制。
我曾经尝试通过行选择来修改表，但这会触发反应式事件循环。后来我意识到我只需要更改视图，而无需更改基础数据，并且仅通过CSS规则即可更改视图。
选中more icons的{{1}}示例可以显示不同的图标，具体取决于复选框的选择。通过检查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)