1

背景

该应用程序具有以下结构：

.
├── R
│   ├── mod_observationSelector.R
│   ├── mod_previewTable.R
│   └── mod_summaryTable.R
└── app.R

随着文件完成各自的功能：

  • mod_observationSelector.R- 提供一种updateSelectInput机制，便于选择数据中的整数或实数mtcars列
  • mod_previewTable.R-head为选定的列生成
  • mod_summaryTable.R-summary为选定的列生成

设计假设

  • mod_observationSelector.R此模块中可用的链接界面元素应可用于提供选择机制的其余模块

问题

嵌套后，下拉选择不再更新。

工作版本

筑巢前。

mod_observationSelector.R

observationSelectorUI <- function(id) {
    ns <- NS(id)
    fluidPage(
        selectInput(
            inputId = ns("varTypes"),
            label = h3("Variable types"),
            choices = list("Integer" = TRUE,
                           "Real" = FALSE),
            selectize = FALSE,
            multiple = FALSE
        ),

        selectInput(
            inputId = ns("selectColumn"),
            label = h4("Selected Column"),
            choices = character(0)
        )
    )
}

observationSelectorServer <- function(id, data) {
    moduleServer(id,
                 function(input, output, session) {
                     observeEvent(eventExpr = input$varTypes,
                                  handlerExpr = {
                                      all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))
                                      selected_cols <-
                                          names(all_cols[all_cols == input$varTypes])
                                      updateSelectInput(
                                          session = session,
                                          inputId = "selectColumn",
                                          label = paste(
                                              "Selected",
                                              ifelse(input$varTypes, "integer", "real"),
                                              "columns"
                                          ),
                                          choices = selected_cols
                                      )
                                  })
                 })
}

app.R

library("shiny")
library("tidyverse")


 ui <- fluidPage(


     titlePanel("Nested Modules"),
     observationSelectorUI("colChooser")
 )

 # Define server logic required to draw a histogram
 server <- function(input, output) {
     observationSelectorServer("colChooser")
 }

 # Run the application
 shinyApp(ui = ui, server = server)

破解版

问题

  1. 以前的工作updateSelect现在坏了

app.R

library("shiny")
library("tidyverse")


ui <- fluidPage(titlePanel("Nested Modules"),
                tabsetPanel(summaryUI("modSummary"),
                            previewUI("modPreview")
                            ))

# Define server logic required to draw a histogram
server <- function(input, output) {
    summaryServer("modSummary")
    previewServer("modPreview")
}

# Run the application
shinyApp(ui = ui, server = server)

mod_observationSelector.R

实际上，没有变化。

observationSelectorUI <- function(id) {
    ns <- NS(id)
    fluidPage(
        selectInput(
            inputId = ns("varTypes"),
            label = h3("Variable types"),
            choices = list("Integer" = TRUE,
                           "Real" = FALSE),
            selectize = FALSE,
            multiple = FALSE
        ),

        selectInput(
            inputId = ns("selectColumn"),
            label = h4("Selected Column"),
            choices = character(0)
        )
    )
}

observationSelectorServer <- function(id, data) {
    moduleServer(id,
                 function(input, output, session) {
                     observeEvent(eventExpr = input$varTypes,
                                  handlerExpr = {
                                      all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))
                                      selected_cols <-
                                          names(all_cols[all_cols == input$varTypes])
                                      updateSelectInput(
                                          session = session,
                                          inputId = "selectColumn",
                                          label = paste(
                                              "Selected",
                                              ifelse(input$varTypes, "integer", "real"),
                                              "columns"
                                          ),
                                          choices = selected_cols
                                      )
                                  })
                 })
}

mod_summaryTable.R

summaryUI <- function(id) {
    ns <- NS(id)
    tabPanel("Summary table",
             column(4, observationSelectorUI(ns("colChooser"))),
             column(8, tableOutput(ns('summaryTable'))))
}

summaryServer <- function(id) {
    moduleServer(id,
                 function(input, output, session) {
                     output$summaryTable <-
                         renderTable(summary(mtcars[, input$selectColumn]))
                 })
}

mod_previewTable

previewUI <-     function(id) {
    ns <- NS(id)
    tabPanel("Summary table",
             column(4, observationSelectorUI(ns("colChooser"))),
             column(8, tableOutput(ns('headTable'))))
}

previewServer <- function(id) {
    moduleServer(id,
                 function(input, output, session) {
                     output$headTable <-
                         renderTable(head(mtcars[, input$selectColumn]))
                 })
}

预期的结果

  • 跨模块的下拉选择更新
  • 模块内下拉选择的结果可用于“外部”模块以生成摘要等。

为方便起见，该代码也可在 GitHub 上找到：konradzdeb/nestedModule。

4

1 回答 1

1

为了后代，解决方案如下

mod_observationSelector.R

返回反应元素。

observationSelectorUI <- function(id) {
    ns <- NS(id)

    tagList(
        selectInput(
            inputId = ns("varTypes"),
            label = h3("Variable types"),
            choices = list("Integer" = TRUE,
                           "Real" = FALSE),
            selectize = FALSE,
            multiple = FALSE
        ),

        selectInput(
            inputId = ns("selectColumn"),
            label = h4("Selected Column"),
            choices = c("cyl", "hp", "vs", "am", "gear", "carb")
        )
    )
}

observationSelectorServer <- function(id, data) {
    moduleServer(id,
                 function(input, output, session) {
                     observeEvent(eventExpr = input$varTypes,
                                  handlerExpr = {
                                      all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))
                                      selected_cols <-
                                          names(all_cols[all_cols == input$varTypes])
                                      updateSelectInput(
                                          session = session,
                                          inputId = "selectColumn",
                                          label = paste(
                                              "Selected",
                                              ifelse(input$varTypes, "integer", "real"),
                                              "columns"
                                          ),
                                          choices = selected_cols
                                      )
                                  })

                     # Return the selection result
                     return(reactive({
                         validate(need(input$selectColumn, FALSE))
                         input$selectColumn
                     }))
                 })
}

使用模块输入

与任何其他反应式一样，我从嵌套模块中获取结果，然后调用它们innerResult()。

previewUI <-     function(id) {

    ns <- NS(id)

    tabPanel("Summary table",
             column(4, observationSelectorUI(ns("colChooser"))),
             column(8, tableOutput(ns('headTable'))))
}

previewServer <- function(id) {
    moduleServer(id,
                 function(input, output, session) {

                     innerResult <- observationSelectorServer("colChooser")

                     output$headTable <- renderTable(head(mtcars[, innerResult()]))
                 })
}

完整的应用程序

可在 GitHub 上获得：b25758b.

于 2020-07-06T21:47:01.077 回答