使用 Shiny 模块复用代码

为什么使用 Shiny 模块

# Problem: without modules, ID conflicts arise
# ui <- fluidPage(
#   selectInput('dataset', ...),  # used by plot1 AND plot2!
#   selectInput('dataset', ...)   # duplicate ID — BROKEN
# )

# With modules: each instance has its own namespaced IDs
# plotModule('plot1', ...)  ->  input$plot1-dataset
# plotModule('plot2', ...)  ->  input$plot2-dataset

NS() — 命名空间函数

# Module UI function
filter_plot_ui <- function(id) {
  ns <- NS(id)  # create the namespace function

  tagList(
    selectInput(ns('dataset'), 'Choose Dataset:',
                choices = c('mtcars', 'iris', 'airquality')),
    sliderInput(ns('n_rows'), 'Rows to show:', 1, 50, 20),
    plotOutput(ns('scatter_plot'))
  )
}

moduleServer() — 服务器函数

# Module server function
filter_plot_server <- function(id) {
  moduleServer(id, function(input, output, session) {

    data <- reactive({
      # input$dataset is already namespaced to this instance
      head(get(input$dataset), input$n_rows)
    })

    output$scatter_plot <- renderPlot({
      df <- data()
      plot(df[[1]], df[[2]],
           xlab = names(df)[1], ylab = names(df)[2])
    })
  })
}

在应用中使用模块

# Main app using the module twice
ui <- fluidPage(
  h2('Plot 1'),
  filter_plot_ui('plot1'),   # instance 1
  hr(),
  h2('Plot 2'),
  filter_plot_ui('plot2')    # instance 2 — no ID conflicts!
)

server <- function(input, output, session) {
  filter_plot_server('plot1')  # wire up instance 1
  filter_plot_server('plot2')  # wire up instance 2
}

shinyApp(ui, server)

向模块用户界面传递参数

# Module UI with extra parameters
summary_table_ui <- function(id, title = 'Summary', height = '300px') {
  ns <- NS(id)
  tagList(
    h4(title),
    div(
      style = paste0('height:', height, '; overflow-y: auto;'),
      DTOutput(ns('tbl'))
    )
  )
}

# Use with custom titles
summary_table_ui('train_tbl', title = 'Training Data', height = '400px')
summary_table_ui('test_tbl',  title = 'Test Data',     height = '200px')

将响应式值传入模块

# Module that accepts a reactive as input
chart_module_server <- function(id, data_reactive) {
  moduleServer(id, function(input, output, session) {
    output$chart <- renderPlot({
      df <- data_reactive()   # call the reactive passed in
      ggplot2::ggplot(df, ggplot2::aes(x = x, y = y)) +
        ggplot2::geom_point(colour = input$colour)
    })
  })
}

# In main server:
server <- function(input, output, session) {
  shared_data <- reactive({ load_data(input$source) })
  chart_module_server('chart1', data_reactive = shared_data)
  chart_module_server('chart2', data_reactive = shared_data)
}

从模块返回响应式值

# Module that returns a reactive to the parent
filter_module_server <- function(id, all_data) {
  moduleServer(id, function(input, output, session) {

    # Return the filtered data reactive
    filtered <- reactive({
      all_data[all_data$group == input$group_filter, ]
    })

    return(filtered)  # parent can use this reactive
  })
}

# In main server:
server <- function(input, output, session) {
  raw_data <- reactive({ read.csv('data.csv') })

  # filtered_data is a reactive returned from the module
  filtered_data <- filter_module_server('filter1', raw_data)

  output$main_plot <- renderPlot({ plot(filtered_data()) })
}

模块文件组织

# Recommended project structure:
# myapp/
#   app.R                   # main app: source modules + wire up
#   R/
#     mod_filter_plot.R     # filter_plot_ui() + filter_plot_server()
#     mod_summary_table.R   # summary_table_ui() + summary_table_server()
#     mod_download.R        # download_ui() + download_server()
#   tests/
#     testthat/test-mod_filter_plot.R

# In app.R:
library(shiny)
# source('R/mod_filter_plot.R')  # not needed if in R/ folder
ui     <- fluidPage(filter_plot_ui('p1'))
server <- function(input, output, session) { filter_plot_server('p1') }
shinyApp(ui, server)

嵌套模块

# Outer module uses an inner module
outer_server <- function(id) {
  moduleServer(id, function(input, output, session) {

    # Call an inner module using this module's session
    inner_result <- inner_module_server(
      id      = 'inner',
      session = session  # passes the namespaced session
    )

    output$combined <- renderText({
      paste('Inner result:', inner_result())
    })
  })
}

# ID chain: outer -> inner
# Full ID: outer-inner-element

使用 shinytest2 测试模块

library(shinytest2)

# Wrap the module in a testable app
test_that('filter_plot module filters correctly', {
  test_app <- shinyApp(
    ui     = fluidPage(filter_plot_ui('test')),
    server = function(input, output, session) {
      filter_plot_server('test')
    }
  )

  app <- AppDriver$new(test_app)
  app$set_inputs('test-dataset' = 'iris')  # namespaced input
  app$wait_for_idle()

  # Assert plot was rendered
  expect_true(!is.null(app$get_value(output = 'test-scatter_plot')))
})

模块通信模式

# Sibling module communication via parent state
server <- function(input, output, session) {
  shared <- reactiveValues(selected_row = NULL)

  # Table module sets the selection
  table_module_server('tbl', shared_state = shared)

  # Detail module reads the selection
  detail_module_server('detail', shared_state = shared)

  # Both modules communicate through 'shared' reactiveValues
  # Table sets shared$selected_row; Detail reads it
}

快速检查

Shiny 模块回顾

# Complete module example
my_module_ui <- function(id) {
  ns <- NS(id)
  tagList(selectInput(ns('var'), 'Variable:', choices = names(mtcars)),
          plotOutput(ns('hist')))
}

my_module_server <- function(id, data) {
  moduleServer(id, function(input, output, session) {
    output$hist <- renderPlot(hist(data()[[input$var]]))
  })
}

# Use it:
ui <- fluidPage(my_module_ui('m1'), my_module_ui('m2'))
server <- function(input, output, session) {
  d <- reactive(mtcars)
  my_module_server('m1', d)
  my_module_server('m2', d)
}
shinyApp(ui, server)