r语言 - 在闪亮模块中更新数据SelectInput

Question

我在更新使用SelectInput和闪亮模块选择的数据时面临一个问题。简而言之，当我选择要加载到selectInput面板中的数据时，它会在第一次选择时更新数据，但如果我想从数据集1转到数据集2，则数据不会更新。您可以在下面找到重现特定问题的代码。

# Libraries
pacman::p_load(shiny, shinydashboard,
tidyverse, data.table, DT, stringr,
ggplot2, plotly,
survival, survminer, GGally, scales,
shinycssloaders)
version <- 0.1
# GENERAL PARAMETERS
box.height <<- 700
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12
# Data
men1_1.norm <<- as.numeric(rnorm(50))
men1_1.pois <<- as.numeric(rpois(50, lambda = 1))
men1_2.norm <<- as.numeric(rnorm(50, mean = 1))
men1_2.pois <<- as.numeric(rpois(50, lambda = 2))
# ui modules
LoadDataUI <- function(id, 
label = "Select the data:", 
sel = "Data 1", 
choic = c('Data 1','Data 2')){
ns <- NS(id)
selectInput(ns("data.sel"),
label = label,
choices = choic,
selected = sel)
}
PlotUI <- function(id){
ns <- NS(id)
plotOutput(ns("plot"))
}
# ui
ui <- dashboardPage(
dashboardHeader(title = paste('My Dashboard',version,sep='')),
dashboardSidebar(
sidebarMenu(
id = "sbMenu",
#Tabs for different data displays
menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
)
),
dashboardBody(
tabItems(
tabItem(tabName = 'men1',
h2(strong('tab 1')),
fluidRow(
### !!!! TO REMOVE ERROR MESSAGES !!!!
# tags$style(type="text/css",
#            ".shiny-output-error { visibility: hidden; }",
#            ".shiny-output-error:before { visibility: hidden; }"
#,
box(title='Select data to load:', height= select.box.height, width = select.box.width,
LoadDataUI("data1")
),
box(title='Normal', height=box.height,
PlotUI("hist_norm1")
),
box(title='Poisson', height=box.height,
PlotUI("hist_pois1")
)
)

)
)
)
)

# server modules
Panel <- function(id){
moduleServer(
id,
function(input, output, session) {
return(
list(
data = reactive({input$data.sel})
)
)
}
)
}
LoadDataServer <- function(id, menu, data_selected
){
moduleServer(
id,
function(input, output, session){
dt <- reactive(data_selected)
data <- reactiveValues(norm = NULL,
pois = NULL)
data$norm <- reactive({get(paste0(menu(),"_", dt(), ".norm"), envir = .GlobalEnv)})
data$pois <- reactive({get(paste0(menu(),"_", dt(), ".pois"), envir = .GlobalEnv)})
return(
data
)
}
)
}

PlotServer <- function(id,data = NULL){
moduleServer(
id,
function(input, output, session) {
x <- reactive(as.numeric(data))
output$plot <- renderPlot({
hist(x(), col = 'darkgray', border = 'white')
})
# output$plot <- renderPlot({
#   if(is.null(data)){return(NULL)}else{
#       hist(data, col = 'darkgray', border = 'white')}
# })
}
)
}

# server
server <- function(input, output, session){
data1 <- Panel("data1")
observeEvent(data1$data(), {
updateSelectInput(session, 'data.sel', selected = input$data.sel)
})
pnl1 <- reactive(
switch(data1$data(),
"Data 1" = "1",
"Data 2" = "2")
)
d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}), data_selected = pnl1())
# Plot
# menu1
output$plot <- PlotServer("hist_norm1", data = d1$norm())
output$plot <- PlotServer("hist_pois1", data = d1$pois())
}
shinyApp(ui, server)

谢谢!

Answer 1

试试这个

version <- 0.1
# GENERAL PARAMETERS
box.height <<- 500
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12
# Data
men1_1.norm <<- as.numeric(rnorm(50))
men1_1.pois <<- as.numeric(rpois(50, lambda = 1))
men1_2.norm <<- as.numeric(rnorm(150, mean = 1))
men1_2.pois <<- as.numeric(rpois(150, lambda = 2))
# ui modules
LoadDataUI <- function(id, 
label = "Select the data:", 
sel = "Data 1", 
choic = c('Data 1','Data 2')){
ns <- NS(id)
selectInput(ns("data.sel"),
label = label,
choices = choic,
selected = sel)
}
PlotUI <- function(id){
ns <- NS(id)
tagList(
plotOutput(ns("plot"))
)


}
# ui
ui <- dashboardPage(
dashboardHeader(title = paste('My Dashboard',version,sep='')),
dashboardSidebar(
sidebarMenu(
id = "sbMenu",
#Tabs for different data displays
menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
)
),
dashboardBody(
tabItems(
tabItem(tabName = 'men1',
h2(strong('tab 1')),
fluidRow(
### !!!! TO REMOVE ERROR MESSAGES !!!!
# tags$style(type="text/css",
#            ".shiny-output-error { visibility: hidden; }",
#            ".shiny-output-error:before { visibility: hidden; }"
#,
box(title='Select data to load:', height= select.box.height, width = select.box.width,
LoadDataUI("data1")
),
box(title='Normal', height=box.height,
PlotUI("hist_norm1")
),
box(title='Poisson', height=box.height,
PlotUI("hist_pois1")
)
)

)
)
)
)

# server modules
Panel <- function(id){
moduleServer(
id,
function(input, output, session) {
return(
list(
data = reactive({input$data.sel})
)
)
}
)
}
LoadDataServer <- function(id, menu, data_selected
){
moduleServer(
id,
function(input, output, session){
dt <- reactive(
switch(data_selected(),
"Data 1" = "1",
"Data 2" = "2")
)
observe({print(dt())})
data <- reactiveValues(norm = NULL,
pois = NULL)
data$norm <- reactive({get(paste0(menu(),"_", dt(), ".norm"), envir = .GlobalEnv)})
data$pois <- reactive({get(paste0(menu(),"_", dt(), ".pois"), envir = .GlobalEnv)})
return(
data
)
}
)
}

PlotServer <- function(id,data){
moduleServer(
id,
function(input, output, session) {
#x <- reactive(as.numeric(data))

output$plot <- renderPlot({
x <- as.numeric(data())
hist(x, col = 'darkgray', border = 'white')
})
# output$plot <- renderPlot({
#   if(is.null(data)){return(NULL)}else{
#       hist(data, col = 'darkgray', border = 'white')}
# })
}
)
}

# server
server <- function(input, output, session){
data1 <- Panel("data1")
# observeEvent(data1$data(), {
#   updateSelectInput(session, 'data.sel', selected = input$data.sel)
# })

# pnl1 <- reactive(
#   switch(data1$data(),
#          "Data 1" = "1",
#          "Data 2" = "2")
# )
d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}), data_selected = data1$data )

# Plot

# menu1
PlotServer("hist_norm1", data = reactive(d1$norm()) )
PlotServer("hist_pois1", data = reactive(d1$pois()) )
}
shinyApp(ui, server)

Answer 2

问题出现是因为您传递给PlotServer的数据不是响应性的。我做了额外的修改:

• 将开头的数据存储在列表中，避免使用get;直接使用数据对象
更容易、更安全。
• 从LoadDataServer中删除了data_selected参数，因为此信息由input$data.sel变量确定，但是这只能从模块内访问，而不是主应用程序server。对于初始化，您只需要在模块的UI部分(您已经实现了)中使用这些信息。这允许我在主应用程序server中删除observeEvent代码，因为这是由模块处理的。

# Libraries
# pacman::p_load(shiny, shinydashboard,
#                tidyverse, data.table, DT, stringr,
#                ggplot2, plotly,
#                survival, survminer, GGally, scales,
#                shinycssloaders)
library(shiny)
library(shinydashboard)
library(ggplot2)
version <- 0.1
# GENERAL PARAMETERS
box.height <<- 700
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12
# Data
data_object <- list(
men1_1 = list(
norm = as.numeric(rnorm(50)),
pois = as.numeric(rpois(50, lambda = 1))
),
men1_2 = list(
norm = as.numeric(rnorm(50, mean = 1)),
pois = as.numeric(rpois(50, lambda = 2))
)
)
# ui modules
LoadDataUI <- function(id, 
label = "Select the data:", 
sel = "Data 1", 
choic = c('Data 1' = "1",'Data 2'  = "2")){
ns <- NS(id)
selectInput(ns("data.sel"),
label = label,
choices = choic,
selected = sel)
}
PlotUI <- function(id){
ns <- NS(id)
plotOutput(ns("plot"))
}
# ui
ui <- dashboardPage(
dashboardHeader(title = paste('My Dashboard',version,sep='')),
dashboardSidebar(
sidebarMenu(
id = "sbMenu",
#Tabs for different data displays
menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
)
),
dashboardBody(
tabItems(
tabItem(tabName = 'men1',
h2(strong('tab 1')),
fluidRow(
### !!!! TO REMOVE ERROR MESSAGES !!!!
# tags$style(type="text/css",
#            ".shiny-output-error { visibility: hidden; }",
#            ".shiny-output-error:before { visibility: hidden; }"
#,
box(title='Select data to load:', height= select.box.height, width = select.box.width,
LoadDataUI("data1")
),
box(title='Normal', height=box.height,
PlotUI("hist_norm1")
),
box(title='Poisson', height=box.height,
PlotUI("hist_pois1")
)
)

)
)
)
)

# server modules
Panel <- function(id){
moduleServer(
id,
function(input, output, session) {
return(
list(
data = reactive({input$data.sel})
)
)
}
)
}
LoadDataServer <- function(id, menu
){
moduleServer(
id,
function(input, output, session){

data <- reactiveValues(norm = NULL,
pois = NULL)
observeEvent(input$data.sel, {
data$norm <- data_object[[paste0(menu(), "_", input$data.sel)]][["norm"]]
data$pois <- data_object[[paste0(menu(), "_", input$data.sel)]][["pois"]]
}) 

return(
data
)
}
)
}

PlotServer <- function(id,data = NULL){
moduleServer(
id,
function(input, output, session) {
output$plot <- renderPlot({
hist(data(), col = 'darkgray', border = 'white')
})
}
)
}

# server
server <- function(input, output, session){

d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}))

# Plot

# menu1
output$plot <- PlotServer("hist_norm1", data = reactive({d1$norm}))
output$plot <- PlotServer("hist_pois1", data = reactive({d1$pois}))
}
shinyApp(ui, server)

如果将完整的d1对象传递给PlotServer，则可以删除当前需要传递norm或pois数据的reactive({})。

我建议阅读如何在模块之间传递数据和模块封装，你可以从掌握shiny或我的模块介绍开始。