我有一个完美工作的闪亮应用程序,它呈现一个带有一个或多个 DT 列的 DT 表,其中行包含 selectInput 小部件。
给定一个带有一个列表列的数据框 df,我创建数据表如下:
output$table <- renderDataTable({
DT::datatable(df,
escape = FALSE, rownames = FALSE, selection = 'none',
options = list(
sort = FALSE, paging = FALSE, searching = FALSE, dom = 't',
fixedheader = TRUE,
pageLength = 5,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node());}')
))
})
在 df 列中创建 selectInput 小部件的函数将为每个小部件构造一个唯一的 inputId:例如,
pasteo("select_", rowID)
,其中 rowID 将是数据框 df 中的行号。
在我的应用程序中,列表列的内容被转换为小部件,如下所示:
CreateWidget <- function(data){
widget <- apply(data, 1, function(x){
ifelse(length(x$listcol) == 1 , x$listcol, as.character(selectizeInput(paste0("select_", x$row), choices = x$listcol,
label = NULL,
selected = 1,
width = '100%',
multiple = TRUE, # Make a direct selection
size = length(x$listcol))))
})
}
渲染 DT 表后,我可以在 selectInput 小部件中进行适当的选择。选择后,所选值即可在服务器上使用:
input$select_1
这种方法效果很好,我有一个正在生产中的闪亮应用程序。
现在我正在尝试更改我的闪亮应用程序,使其使用模块(我根本没有使用模块的经验)。我本以为只需在生成 selectInput 小部件的函数中命名 inputId 就足够了。
CreateWidget <- function(data, ns){
widget <- apply(data, 1, function(x){
ifelse(length(x$listcol) == 1 , x$listcol, as.character(selectizeInput(ns(paste0("select_", x$row)), choices = x$listcol,
label = NULL,
selected = 1,
width = '100%',
multiple = TRUE, # Make a direct selection
size = length(x$listcol))))
})
}
我在服务器模块中使用
ns = session$ns
的地方,即调用该函数的地方。
例如,如果模块 ID 为“main”,我的输入值现在可用为:
input$main-select_1
或者在我的代码中:
input[[ns(paste0("select_", row))]]
但是可惜,这根本不起作用! 在我基于模块的应用程序中,我什至看不到与我的 selectInput 小部件关联的输入值。我可以使用浏览器检查器检查它们的 ID,因此我知道它们存在,但我无法访问它们。我可以看到与其他小部件和 DT 表关联的所有其他输入对象。
在 ismirsehregal 的请求后添加了工作代表示例:
全球.R
# module_server.R
library(shiny)
library(dplyr)
library(DT)
source("./R/modules/app_ui.R", local = TRUE)
source("./R/modules/app_server.R", local = TRUE)
ui.R
ui <- fluidPage(
carTableUI("main")
)
服务器.R
# Module Server
server <- function(input, output, session) {
carTableServer("main")
}
app_ui.R
# Module UI
carTableUI <- function(id) {
ns <- NS(id)
tagList(
DTOutput(ns("car_table")),
textOutput(ns("selected_cars"))
)
}
应用服务器.R
# module_server.R
carTableServer <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
# function to create a selectizeInput widget for the DT table
CreateWidget <- function(cars, ns) {
sel_widget <- apply(cars, 1, function(x){
if (length(x$Type) == 1) {
x$Type
} else {
as.character(
selectizeInput(
inputId = session$ns(paste0("car_sel_", x$Brand)),
#inputId = paste0("car_sel_", x$Brand),
choices = x$Type,
label = NULL,
selected = 1,
width = '100%',
multiple = TRUE,
size = length(x$Type)
)
)
}
})
return(sel_widget)
}
Cars <- tibble(
Brand = c("Tesla", "Kia", "Toyota"),
Model = c("Model X", "Seltos", "Corolla"),
Type = list(
list("normal car", "sports car", "luxury car"),
list("normal car", "sports car", "luxury car"),
list("normal car", "sports car", "luxury car")
)
)
Cars$selectize <- CreateWidget(Cars, ns)
glimpse(Cars) # check how the df looks like
output$car_table <- renderDT({
datatable(Cars[, c("Brand", "Model", "selectize")],
escape = FALSE, rownames = FALSE, selection = 'none',
options = list(
paging = FALSE,
searching = FALSE,
dom = 't',
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); }')
))
}, server = FALSE)
# Reactive expression to collect selected values
selected_cars <- reactive({
browser()
selected <- sapply(Cars$Brand, function(x) {
input[[ns(paste0("car_sel_", x))]]
})
selected <- selected[!sapply(selected, is.null)]
})
# Output the selected values
output$selected_cars <- renderText({
selected_values <- selected_cars()
if (length(selected_values) == 0) {
"No cars selected"
} else {
paste("Selected cars:", paste(selected_values, collapse = ", "))
}
})
observeEvent(input[["main-car_sel_Tesla"]],
print(input[["main-car_sel_Tesla"]])
)
# print all input objects to the console
# observe({
# print(reactiveValuesToList(input))
# })
})
}
为了让这项工作正常进行,我需要解决两个问题。
第一个描述于here。从闪亮的 1.8.0 开始。在 DataTable 中使用 selectize 的依赖项时,您需要“手动”将它们附加到 UI。请参阅下面的
findDependencies
电话。
第二个问题是,在
app_server.R
中,您不需要使用 ns()
来访问输入(selected_cars 反应式):
全球.R
# module_server.R
library(shiny)
library(dplyr)
library(DT)
select_input <- selectizeInput("dummy", label = NULL, choices = NULL)
deps <- htmltools::findDependencies(select_input)
source("./R/modules/app_ui.R", local = TRUE)
source("./R/modules/app_server.R", local = TRUE)
ui.R
ui <- fluidPage(
tagList(deps),
carTableUI("main")
)
服务器.R
# Module Server
server <- function(input, output, session) {
carTableServer("main")
}
app_ui.R
# Module UI
carTableUI <- function(id) {
ns <- NS(id)
tagList(
DTOutput(ns("car_table")),
textOutput(ns("selected_cars"))
)
}
应用服务器.R
# module_server.R
carTableServer <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
# function to create a selectizeInput widget for the DT table
CreateWidget <- function(cars, ns) {
sel_widget <- apply(cars, 1, function(x){
if (length(x$Type) == 1) {
x$Type
} else {
as.character(
selectizeInput(
inputId = session$ns(paste0("car_sel_", x$Brand)),
#inputId = paste0("car_sel_", x$Brand),
choices = x$Type,
label = NULL,
selected = 1,
width = '100%',
multiple = TRUE,
size = length(x$Type)
)
)
}
})
return(sel_widget)
}
Cars <- tibble(
Brand = c("Tesla", "Kia", "Toyota"),
Model = c("Model X", "Seltos", "Corolla"),
Type = list(
list("normal car", "sports car", "luxury car"),
list("normal car", "sports car", "luxury car"),
list("normal car", "sports car", "luxury car")
)
)
Cars$selectize <- CreateWidget(Cars, ns)
glimpse(Cars) # check how the df looks like
output$car_table <- renderDT({
datatable(Cars[, c("Brand", "Model", "selectize")],
escape = FALSE, rownames = FALSE, selection = 'none',
options = list(
paging = FALSE,
searching = FALSE,
dom = 't',
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); }')
))
}, server = FALSE)
# Reactive expression to collect selected values
selected_cars <- reactive({
selected <- sapply(Cars$Brand, function(x) {
input[[paste0("car_sel_", x)]]
})
selected <- selected[!sapply(selected, is.null)]
selected
})
observe({
print(names(input))
})
# Output the selected values
output$selected_cars <- renderText({
selected_values <- selected_cars()
if (length(selected_values) == 0) {
"No cars selected"
} else {
paste("Selected cars:", paste(selected_values, collapse = ", "))
}
})
observeEvent(input[["main-car_sel_Tesla"]],
print(input[["main-car_sel_Tesla"]])
)
# print all input objects to the console
# observe({
# print(reactiveValuesToList(input))
# })
})
}