R闪亮集复选框将值控制为数据帧特定列中的值

Question

我想在加载数据表时将复选框值设置为列"YN"中的相应值。我试图修改一个使用复选框控件更新"YN"值的示例。这正是我所需要的，然而，最初复选框的值默认为"TRUE"，而不是数据文件中的"YN"值。我创建了一个函数"valueFromData"，我认为它最初会填充控件，但它似乎不起作用。请建议如何正确实施。非常感谢。这是代码：

library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
DT::dataTableOutput('x1'),
),

server = function(input, output, session) {
# create a character vector of shiny inputs
shinyInput = function(FUN, len, id, value, ...) {
if (length(value) == 1) value <- rep(value, len)
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, value = value[i]))
}
inputs
}
# obtain the values of check-boxes from 'data'YN'
valueFromData = function(id, len) {
print(id)
print(len)
unlist(lapply(seq_len(len), function(i) {
print(i)
print(df1$YN[i])
value = print(df1$YN[i])
#print(value)
#if (is.null(value)) TRUE else value
}))
}

# obtain the values of inputs
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
#print(value)
if (is.null(value)) TRUE else value
}))
}


n = 10
df1 = data.frame(
month = month.abb[1:n],
YN = rep(c(FALSE, TRUE), times = c(5,5)),
ID = seq_len(n),
stringsAsFactors = FALSE
)
df2 = data.frame(
cb = shinyInput(checkboxInput, n, 'cb_', value = valueFromData('cb_', n), width='1px'),
df1,
stringsAsFactors = FALSE
)

loopData = reactive({
df2$cb <<- shinyInput(checkboxInput, n, 'cb_', value = shinyValue('cb_', n), width='1px')
df2$YN <<- shinyValue('cb_', n)
df2
})

output$x1 = DT::renderDataTable(
isolate(loopData()),
escape = FALSE, selection = 'none',
options = list(
dom = 't', paging = FALSE, ordering = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
))

proxy = dataTableProxy('x1')

observe({
replaceData(proxy, loopData(), resetPaging = FALSE)
})

}
)

Answer 1

这里有一种方法：

library(shiny)
library(DT)
shinyApp(

ui = fluidPage(
DTOutput('x1'),
),

server = function(input, output, session) {

# create a character vector of shiny inputs
shinyInput = function(FUN, len, id, value, width) {
if (length(value) == 1) value <- rep(value, len)
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = 
as.character(FUN(paste0(id, i), label = NULL, value = value[i], width = width))
}
inputs
}
# obtain the values of inputs
shinyValue = function(id, len, initial) {
vapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) initial[i] else value
}, FUN.VALUE = logical(1))
}

n = 10
YN = rep(c(FALSE, TRUE), times = c(5,5))
df1 = data.frame(
cb = shinyInput(checkboxInput, n, 'cb_', 
value = YN, width='30px'),
month = month.abb[1:n],
YN = YN,
ID = seq_len(n),
stringsAsFactors = FALSE
)
loopData = reactive({
values = shinyValue('cb_', n, initial = YN)
dat = df1
dat$cb = shinyInput(checkboxInput, n, 'cb_',
value = values,
width = '30px')
dat$YN = values
dat
})

output$x1 = renderDT(
df1, class = "display compact",
escape = FALSE, selection = 'none',
options = list(
dom = 't', paging = FALSE, ordering = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
))

proxy = dataTableProxy('x1')

observe({
replaceData(proxy, loopData(), resetPaging = FALSE)
})

}
)

---

编辑

另一种应该更具性能的方式：

library(shiny)
library(DT)
df <- data.frame(item = c("a", "b", "c"), YN = c(TRUE, FALSE, FALSE))
shinyCheckbox <- function(id, values) {
inputs <- character(length(values))
for(i in seq_along(inputs)) {
inputs[i] <- 
as.character(
checkboxInput(paste0(id, i), label = NULL, value = values[i], width = "20px")
)
}
inputs
}
callback <- c(
"$('[id^=check]').on('click', function(){",
"  var id = this.getAttribute('id');",
"  var i = parseInt(/check(\d+)/.exec(id)[1]);",
"  var value = $(this).prop('checked');",
"  var cell = table.cell(i-1, 2).data(value).draw();",
"})"
)
server <- function(input, output, session) {
output$tbl <- renderDT(
server = FALSE, escape = FALSE, callback = JS(callback),
options = list(
dom = 't', paging = FALSE, ordering = FALSE,
columnDefs = list(
list(targets = "_all", className = "dt-center"),
list(targets = 3, width = "20px")
),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
), {
df$check <- shinyCheckbox("check", df$YN)
df
}
)
}
ui <- fluidPage(
DTOutput("tbl")
)
shinyApp(ui, server)