我正在开发一个闪亮的应用程序,其中包含各种面板,每个面板都分为自己的模块。其中之一在各个单元格上使用带有
selectInput
的 DataTable,我需要在同一模块内访问其值。在下面的示例中,我只是尝试用 output$mySelectOutput
显示所选值。
我确信我遗漏了一些关于
ns
的内容。我尝试将其添加到 inputId
内的 selectInput
之前,但这还不够。
编辑:我仍然没有解决问题,但我发现有两件事会导致应用程序无法按预期工作。
preDrawCallback
和 drawCallback
选项as.character(selectInput(...))
并不像我想象的那样工作,并且从我所看到的情况来看,不可能检索以这种方式生成的 selectInput
的 id。所以我决定回滚到我的自制生成器(称为 mySelectInput
),我尝试将 ns()
这是可重现的示例:
### Libraries
library(shiny) # used to create the Shiny App
library(bslib) # used to create the framework of the Shiny App
library(DT) # used for creating interactive DataTable
# Create levels to choose from in the Select Input
factorOptions <- function(factor_levels) {
optionList <- ""
for (i in factor_levels) {optionList <- paste0(optionList, '<option value="', i, '">', i, '</option>\n')}
return(optionList)
}
# Create the Select Input with ID and corresponding entry from the datatable
mySelectInput <- function(id_list, selected_factors, factor_levels) {
select_input <- paste0('<select id="ns(single_select_', id_list, ')"style="width: 100%;">\n',
sprintf('<option value="%s" selected>%s</option>\n', selected_factors, selected_factors),
factorOptions(factor_levels), '</select>')
return(select_input)
}
### Server
dummy_serverModule <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
dummy_data <- datatable(
data = tibble(select_test = mySelectInput(1, 1, 1:4)),
selection = 'none', escape = FALSE, rownames = FALSE,
options = list(
keys = TRUE,
preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
)
)
output$dummyDT <- renderDT({dummy_data})
output$mySelectOutput <- renderText({input$single_select_1})
})
}
server <- function(input, output, session) {
dummy_serverModule(id = "dummyId")
session$onSessionEnded(function() {
stopApp()
})
}
### UI
dummy_uiModule <- function(id) {
ns <- NS(id)
page_fluid(
card_body(DTOutput(ns("dummyDT"))),
card(verbatimTextOutput(ns("mySelectOutput")))
)
}
ui <- page_navbar(
nav_panel(
title = "Dashboard",
dummy_uiModule(id = "dummyId")
)
)
### App
shinyApp(ui, server)
好吧,我实际上有正确的想法,但执行错误。由于
ns()
充当函数,在输入/输出ID之前添加模块ID,因此将其放入生成selectInput
的字符串中,因为字符串没有执行任何操作。
但是,由于
ns
基本上是模块 ID 和输入/输出 ID 的 paste0
,我可以通过在 mySelectInput
中添加 id_module 参数并进行编辑来复制它,如下所示:
mySelectInput <- function(id_module, id_list, selected_factors, factor_levels) {
select_input <- paste0('<select id="', id_module, '-single_select_', id_list, '"style="width: 100%;">\n',
sprintf('<option value="%s" selected>%s</option>\n', selected_factors, selected_factors),
factorOptions(factor_levels), '</select>')
return(select_input)
}
这样,DataTable 中生成的每个
selectInput
都会链接到模块,并且可以正确提取它们的值。
这是完整的更正代码:
### Libraries
library(shiny) # used to create the Shiny App
library(bslib) # used to create the framework of the Shiny App
library(DT) # used for creating interactive DataTable
# Create levels to choose from in the Select Input
factorOptions <- function(factor_levels) {
optionList <- ""
for (i in factor_levels) {optionList <- paste0(optionList, '<option value="', i, '">', i, '</option>\n')}
return(optionList)
}
# Create the Select Input with ID and corresponding entry from the datatable
mySelectInput <- function(id_module, id_list, selected_factors, factor_levels) {
select_input <- paste0('<select id="', id_module, '-single_select_', id_list, '"style="width: 100%;">\n',
sprintf('<option value="%s" selected>%s</option>\n', selected_factors, selected_factors),
factorOptions(factor_levels), '</select>')
return(select_input)
}
### Server
dummy_serverModule <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
dummy_data <- datatable(
data = tibble(select_test = mySelectInput(id, 1, 1, 1:4)),
selection = 'none', escape = FALSE, rownames = FALSE,
options = list(
keys = TRUE,
preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
)
)
output$dummyDT <- renderDT({dummy_data})
output$mySelectOutput <- renderText({input$single_select_1})
})
}
server <- function(input, output, session) {
dummy_serverModule(id = "dummyId")
session$onSessionEnded(function() {
stopApp()
})
}
### UI
dummy_uiModule <- function(id) {
ns <- NS(id)
page_fluid(
card_body(DTOutput(ns("dummyDT"))),
card(verbatimTextOutput(ns("mySelectOutput")))
)
}
ui <- page_navbar(
nav_panel(
title = "Dashboard",
dummy_uiModule(id = "dummyId")
)
)
### App
shinyApp(ui, server)