Shiny应用问题：如何根据下拉选择从Plotly对象列表生成对应图表

1. 完善UI：新增单股票选择下拉框 #

在UI的actionButton之后、plotlyOutput之前，添加用于选择单只股票的下拉框，初始选项为空，后续通过服务端动态更新：

shinyWidgets::pickerInput(
  inputId = "symbol2",
  label = h4("选择单只股票查看图表"),
  choices = NULL,
  selected = NULL
)

2. 动态更新单股票下拉框选项 #

在服务端中，当用户点击「Aplicar」按钮后，将symbol2的选项更新为用户之前选中的股票列表：

observeEvent(input$apply, {
  req(input$symbol)
  shinyWidgets::updatePickerInput(
    session = session,
    inputId = "symbol2",
    choices = input$symbol,
    selected = input$symbol[1]
  )
})

注意要在server函数中添加session参数：server <- function(input, output, session) {

3. 修正plotsList的定义与绘图逻辑 #

原代码存在几个核心问题，修正如下：

• eventReactive缺少触发条件，需绑定input$apply
• FANG数据集无Periodo和diff_from_base_year字段，替换为实际存在的date和close字段
• 替换未定义的theme_momura()为tidyquant自带的theme_tq()

修正后的plotsList代码：

plotsList = eventReactive(input$apply, {
  splits() %>%
    map(function(split_obj) {
      # 合并训练集与测试集，标记数据类型用于绘图区分
      bind_rows(
        training(split_obj) %>% mutate(data_type = "训练集"),
        testing(split_obj) %>% mutate(data_type = "测试集")
      ) %>%
        ggplot(aes(x = date, y = close, color = data_type)) +
        geom_line(size = 1) +
        scale_color_tq() +
        labs(
          x = "日期", y = "收盘价",
          title = "时间序列拆分：训练集 vs 测试集"
        ) +
        theme_tq() %>%
        ggplotly()
    })
})

4. 修正图表渲染逻辑 #

原代码用!!sym(input$symbol2)索引列表的方式错误，直接使用字符索引即可：

output$plot = renderPlotly({
  req(input$symbol2, plotsList())
  plotsList()[[input$symbol2]]
})

完整修正后的代码 #

library(shiny)
library(tidyverse)
library(tidyquant)
library(tidymodels)
library(timetk)
library(plotly)
library(shinyWidgets)

data(FANG) # 加载FANG数据集
uniqueSymbols = unique(FANG$symbol)

# 定义UI
ui <- fluidPage(
  titlePanel("股票时间序列分析"),
  
  shinyWidgets::pickerInput(
    inputId = "var_to_forecast_CF1",
    label = h4("待预测变量"),
    choices = c("open", "high"),
    selected = "open"
  ),
  
  verbatimTextOutput("formula_to_estimate_1"),
  
  airYearpickerInput(
    inputId = "yearly_range",
    label = "选择年份范围:",
    range = TRUE, value = c(Sys.Date()-365*10, Sys.Date())
  ),
  
  shinyWidgets::pickerInput(
    inputId = "symbol",
    label = h4("选择股票（可多选）"),
    choices = uniqueSymbols,
    selected = uniqueSymbols[1],
    multiple = TRUE,
    options = list(size = 3)
  ),
  
  actionButton(inputId = "apply", label = "应用", icon = icon("play")),
  
  shinyWidgets::pickerInput(
    inputId = "symbol2",
    label = h4("选择单只股票查看图表"),
    choices = NULL,
    selected = NULL
  ),
  
  plotlyOutput("plot")
)

# 定义服务端逻辑
server <- function(input, output, session) {
  
  formula_to_estimate = reactive({
    paste0(input$var_to_forecast_CF1, "~", "close") %>%
      as.formula()
  })
  
  output$formula_to_estimate_1 = renderText({
    deparse(as.formula(formula_to_estimate()))
  })
  
  # 计算测试集时长（月份）
  assessmentDuration = reactive({
    (year(input$yearly_range[2]) - year(input$yearly_range[1])) * 12
  })
  
  # 按股票拆分数据
  data_to_model = eventReactive(input$apply, {
    FANG %>%
      filter(symbol %in% input$symbol) %>%
      filter(date >= input$yearly_range[1], date <= input$yearly_range[2]) %>%
      split(., .$symbol)
  })
  
  # 生成时间序列拆分对象
  splits = eventReactive(input$apply, {
    data_to_model() %>%
      map(function(data) {
        time_series_split(
          data,
          assess = assessmentDuration(),
          cumulative = TRUE
        )
      })
  })
  
  # 更新单股票选择下拉框
  observeEvent(input$apply, {
    req(input$symbol)
    shinyWidgets::updatePickerInput(
      session = session,
      inputId = "symbol2",
      choices = input$symbol,
      selected = input$symbol[1]
    )
  })
  
  # 生成Plotly图表列表
  plotsList = eventReactive(input$apply, {
    splits() %>%
      map(function(split_obj) {
        bind_rows(
          training(split_obj) %>% mutate(data_type = "训练集"),
          testing(split_obj) %>% mutate(data_type = "测试集")
        ) %>%
          ggplot(aes(x = date, y = close, color = data_type)) +
          geom_line(size = 1) +
          scale_color_tq() +
          labs(
            x = "日期", y = "收盘价",
            title = "时间序列拆分：训练集 vs 测试集"
          ) +
          theme_tq() %>%
          ggplotly()
      })
  })
  
  # 渲染选中的图表
  output$plot = renderPlotly({
    req(input$symbol2, plotsList())
    plotsList()[[input$symbol2]]
  })
  
}

# 运行应用
shinyApp(ui = ui, server = server)

关键修正说明 #

• 添加session参数到server函数，用于动态更新下拉框选项
• 修复plotsList的触发条件，确保仅在点击「应用」后重新生成图表
• 替换数据集不存在的字段，使用FANG自带字段并区分训练集/测试集
• 修正图表索引方式，直接用字符类型的input$symbol2访问列表元素
• 添加req()函数确保依赖项存在后再执行，避免报错

内容的提问来源于stack exchange，提问作者user113156