使用一系列嵌套模块来运行闪亮的应用程序时遇到问题

Question

我根据我正在开发的真实闪亮应用程序遇到的问题创建了一个模拟闪亮应用程序。然而，当我想将一些东西从通用用户界面和服务器功能移到模块中时，我遇到了让它工作的麻烦。

这是正在运行的 Shiny 应用程序的基本版本：

library(shiny)
library(bs4Dash)
library(shinyWidgets)
library(dplyr)

module_gearcat_UI <- function(id){
  ns <- NS(id)
  box(
    title = textOutput(ns("box_title")),
    width = 12,
    solidHeader = TRUE,
    collapsible = TRUE,
    DT::DTOutput(ns("gear_DT"))
  )
}

module_gearcat_Server <- function(id, var_gear, selected_rows){
  moduleServer(id, function(input, output, session) {
    ns <- session$ns
    
    tbl <- eventReactive(var_gear, {
      mtcars %>% 
        filter(gear == var_gear)      
    })
    
    output$box_title <- renderText({
      var_gear %>% return()
    })
    
    output$gear_DT <- DT::renderDT({
      DT_output <- tbl() %>%
        DT::datatable(
          selection = "multiple",
          style = "bootstrap4",
          options = list(
            dom='t', 
            ordering = FALSE
          )
        ) 
      DT_output %>% return()
    })
    
    observeEvent(input$gear_DT_rows_selected, {
      input$gear_DT_rows_selected %>% print()
      selected_rows[[id]] <<- input$gear_DT_rows_selected
    })
  })
}

ui <- fluidPage(
  uiOutput("list")
)

server <- function(input, output) {
  lst <- c(3, 4, 5)
  
  # Initialize reactiveValues to store selected rows
  selected_rows <- reactiveValues()
  for (gear in lst) {
    selected_rows[[paste0("main_", gear)]] <- NULL
  }
  
  output$list <- renderUI({
    lapply(lst, function(gear) {
      fluidRow(
        column(12, module_gearcat_UI(paste0("main_", gear)))
      )
    })
  })
  
  lapply(lst, function(gear) {
    module_gearcat_Server(id = paste0("main_", gear), var_gear = gear, selected_rows)
  })
  
}

shinyApp(ui, server)

我想将

uiOutput("list")

中当前的所有内容移至单独的模块，但我所有的尝试都失败了。我确信有一个简单的技巧可以做到这一点，但是怎么做呢？有人可以告诉我解决方案的方向吗？

Answer 1

不确定问题出在哪里。首先，至少对于您的示例，我看不出有任何理由使用

renderUI

和

uiOutput

。相反，您可以将所有内容移至 UI。另外，我看不出有任何理由使用

reactiveValues

。相反，您可以返回选定的行作为模块服务器的返回值。

注意：我添加了一个文本输出来显示返回的值。

library(shiny)
library(shinydashboard)
library(dplyr)

module_gearcat_UI <- function(id) {
  ns <- NS(id)
  box(
    title = textOutput(ns("box_title")),
    width = 12,
    solidHeader = TRUE,
    collapsible = TRUE,
    DT::DTOutput(ns("gear_DT"))
  )
}

module_gearcat_Server <- function(id, var_gear) {
  moduleServer(id, function(input, output, session) {
    tbl <- reactive({
      mtcars %>%
        filter(gear == var_gear)
    })

    output$box_title <- renderText({
      var_gear
    })

    output$gear_DT <- DT::renderDT({
      tbl() %>%
        DT::datatable(
          selection = "multiple",
          style = "bootstrap4",
          options = list(
            dom = "t",
            ordering = FALSE
          )
        )
    })
    
    return(
      reactive(input$gear_DT_rows_selected)
    )
  })
}

lst <- c(3, 4, 5)

ui <- fluidPage(
  verbatimTextOutput("selected_rows"),
  lapply(lst, function(gear) {
    fluidRow(
      column(12, module_gearcat_UI(paste0("main_", gear)))
    )
  })
)

server <- function(input, output) {
  selected_rows <- lapply(lst, function(gear) {
    module_gearcat_Server(id = paste0("main_", gear), var_gear = gear)
  }) |> 
    setNames(paste0("main_", lst))
  
  output$selected_rows <- renderPrint({
    lapply(selected_rows, \(x) x())
  })
}

shinyApp(ui, server)

如果你想包装或嵌套在另一个模块中，那么你可以这样做：

module_main_ui <- function(id, lst) {
  ns <- NS(id)
  
  lapply(lst, function(gear) {
    fluidRow(
      column(12, module_gearcat_UI(ns(paste0("main_", gear))))
    )
  })
}

module_main_server <- function(id, lst) {
  moduleServer(id, function(input, output, session) {
    selected_rows <- lapply(lst, function(gear) {
      module_gearcat_Server(id = paste0("main_", gear), var_gear = gear)
    }) |>
      setNames(paste0("main_", lst))
    
    return(selected_rows)
  })
}

lst <- c(3, 4, 5)

ui <- fluidPage(
  verbatimTextOutput("selected_rows"),
  module_main_ui("main", lst)
)

server <- function(input, output) {
  selected_rows <- module_main_server("main", lst)
  
  output$selected_rows <- renderPrint({
    lapply(selected_rows, \(x) x())
  })
}

shinyApp(ui, server)