如何在R Shiny中实现Plotly钻取图表的响应式标题？

以下是修改后的完整代码，实现了初始标题显示「所选州的GDP水平」、钻取后显示「所选城市的GDP水平」的需求：

library(tidyverse)
library(plotly)
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinyjs)

full_data <- tibble(
  State = c("IL", "IL", "IL", "IL", "IL", "IL", "IN", "IN", "IN", "IN", "IN", "IN"),
  City = c("Chicago", "Rockford", "Naperville", "Chicago", "Rockford", "Naperville","Fort Wayne", 
           "Indianapolis", "Bloomington", "Fort Wayne", "Indianapolis", "Bloomington"),
  Year = c("2008", "2008", "2008", "2009", "2009", "2009", "2008", "2008", "2008", "2009", "2009", "2009"),
  GDP = c(200, 300, 350, 400, 450, 250, 600, 400, 300, 800, 520, 375)
)

ui <- fluidPage(useShinyjs(),
                selectInput(inputId = "year",
                            label = "Year",
                            multiple = TRUE,
                            choices = unique(full_data$Year),
                            selected = unique(full_data$Year)),
                selectInput(inputId = "state",
                            label = "State",
                            choices = unique(full_data$State)),
                plotlyOutput("gdp_level", height = 200),
                shinyjs::hidden(actionButton("clear", "Return to State"))
)

server <- function(input, output, session) {
  
  drills <- reactiveValues(
    category = NULL,
    sub_category = NULL
  )
  
  # 监听州选择变化，重置钻取状态
  observeEvent(input$state, {
    drills$category <- NULL
    shinyjs::hide("clear")
  })
  
  gdp_reactive <- reactive({
    full_data %>%
      filter(Year %in% input$year) %>%
      filter(State %in% input$state)  
  })
  
  gdp_reactive_2 <- reactive({
    full_data %>%
      filter(Year %in% input$year) %>%
      filter(State %in% input$state) %>%
      filter(City %in% drills$category) 
  })
  
  gdp_data <- reactive({
    if (!length(drills$category)) {
      return(gdp_reactive())
    } else {
      return(gdp_reactive_2())
    }
  })
  
  output$gdp_level <- renderPlotly({
    # 动态生成响应式标题
    if(!length(drills$category)){
      plot_title <- paste0(input$state, "州的GDP水平")
    } else {
      plot_title <- paste0(drills$category, "城市的GDP水平")
    }
    
    gdp_data() %>% 
      plot_ly(
        x = ~Year,
        y = ~GDP,
        color = ~City,
        key = ~City,
        source = "gdp_level",
        type = "bar"
      ) %>% 
      layout(barmode = "stack", 
             showlegend = T,
             xaxis = list(title = "Year"),
             yaxis = list(title = "GDP"),
             title = plot_title)
  })
  
  observeEvent(event_data("plotly_click", source = "gdp_level"), {
    x <- event_data("plotly_click", source = "gdp_level")$key
    if (!length(x)) return()
    
    if (!length(drills$category)) {
      drills$category <- x
    } else {
      drills$sub_category <- NULL
    }
  })
  
  observe({
    if(length(drills$category))  shinyjs::show("clear")  
  })
  
  observeEvent(input$clear, {
    drills$category <- NULL
    shinyjs::hide("clear")
  })
  
}

shinyApp(ui, server)

关键修改说明 #

1. 动态标题生成：在renderPlotly中，根据drills$category的存在与否，分别用当前选中的州（input$state）或钻取到的城市（drills$category）拼接标题文本，实现响应式变化。
2. 州切换重置：新增observeEvent(input$state)监听州选择的变化，自动重置钻取状态并隐藏返回按钮，确保切换州后标题和数据同步回到初始状态。
3. 保留原有钻取逻辑：其余钻取交互逻辑保持不变，仅调整标题生成部分，不影响原有功能。

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