基于R、Plotly、Shiny实现柱状图点击条带高亮的技术问询

我帮你修复了代码里的警告问题，同时实现了点击柱状图高亮选中条带、子类别图表同步使用相同颜色的功能。下面是完整的可运行代码，之后会拆解关键修改点：

library(shiny)
library(plotly)
library(dplyr)

sales <- diamonds
sales$category = sales$cut
sales$sub_category = sales$color
sales$sales = sales$price
sales$order_date = sample(seq(as.Date('2020-01-01'), as.Date('2020-02-01'), by="day"),nrow(sales), replace = T)

ui <- fluidPage(
  plotlyOutput("category", height = 200),
  plotlyOutput("sub_category", height = 200),
  plotlyOutput("sales", height = 300),
  DT::dataTableOutput("datatable")
)

# 复用的轴标题函数
axis_titles <- . %>%
  layout(
    xaxis = list(title = ""),
    yaxis = list(title = "Sales")
  )

server <- function(input, output, session) {
  # 维护选中状态：类别、子类别、日期，以及选中条的颜色
  category <- reactiveVal()
  sub_category <- reactiveVal()
  order_date <- reactiveVal()
  selected_color <- reactiveVal("#1F77B4") # 默认蓝色

  # 点击类别图表时更新状态
  observeEvent(event_data("plotly_click", source = "category"), {
    click_data <- event_data("plotly_click", source = "category")
    category(click_data$x)
    selected_color(click_data$marker.color) # 保存点击条的原始颜色
    sub_category(NULL)
    order_date(NULL)
  })

  observeEvent(event_data("plotly_click", source = "sub_category"), {
    click_data <- event_data("plotly_click", source = "sub_category")
    sub_category(click_data$x)
    order_date(NULL)
  })

  observeEvent(event_data("plotly_click", source = "order_date"), {
    order_date(event_data("plotly_click", source = "order_date")$x)
  })

  output$category <- renderPlotly({
    sales %>%
      count(category, wt = sales) %>%
      plot_ly(x = ~category, y = ~n, source = "category", marker = list(color = "#1F77B4")) %>%
      axis_titles() %>%
      layout(title = "Sales by category") %>%
      event_register("plotly_click") %>% # 注册点击事件，消除警告
      highlight(
        on = "plotly_click",
        selected = list(marker = list(color = "#FF6B6B")), # 选中条高亮颜色
        unselected = list(marker = list(color = "rgba(128,128,128,0.5)")), # 未选中条置灰
        persistent = TRUE # 保持选中状态直到下一次点击
      )
  })

  output$sub_category <- renderPlotly({
    if (is.null(category())) return(NULL)
    sales %>%
      filter(category %in% category()) %>%
      count(sub_category, wt = sales) %>%
      plot_ly(
        x = ~sub_category, 
        y = ~n, 
        source = "sub_category", 
        marker = list(color = selected_color()) # 同步使用类别选中条的颜色
      ) %>%
      axis_titles() %>%
      layout(title = category()) %>%
      event_register("plotly_click") %>%
      highlight(
        on = "plotly_click",
        selected = list(marker = list(color = "#FF6B6B")),
        unselected = list(marker = list(color = "rgba(128,128,128,0.5)")),
        persistent = TRUE
      )
  })

  output$sales <- renderPlotly({
    if (is.null(sub_category())) return(NULL)
    sales %>%
      filter(sub_category %in% sub_category()) %>%
      count(order_date, wt = sales) %>%
      plot_ly(x = ~order_date, y = ~n, source = "order_date") %>%
      add_lines(line = list(color = selected_color())) %>% # 同步线条颜色
      axis_titles() %>%
      layout(title = paste(sub_category(), "sales over time")) %>%
      event_register("plotly_click")
  })

  output$datatable <- DT::renderDataTable({
    if (is.null(order_date())) return(NULL)
    sales %>%
      filter(
        sub_category %in% sub_category(),
        as.Date(order_date) %in% as.Date(order_date())
      )
  })
}

shinyApp(ui, server)

关键修改点说明 #

1. 消除plotly_click未注册警告 #

每个需要响应点击事件的Plotly图表，都需要用event_register("plotly_click")显式注册事件。这是Plotly和Shiny联动的必要步骤，没注册的话就会出现你遇到的警告，事件也无法正常响应。

2. 实现点击高亮效果 #

使用highlight()函数控制选中/未选中元素的样式：

• on = "plotly_click"：指定触发高亮的事件是点击
• selected：定义选中元素的样式（这里用红色高亮选中的柱状条）
• unselected：定义未选中元素的样式（这里用半透明灰色置灰未选中条）
• persistent = TRUE：保持选中状态，直到用户点击其他元素

3. 同步子类别图表的颜色 #

• 新增selected_color reactiveVal保存点击类别条时的原始颜色
• 在子类别图表中，将所有柱状条的颜色设置为selected_color()，实现和选中类别条颜色同步
• 时间趋势图的线条颜色也同步使用这个颜色，保持视觉一致性

4. 优化点击事件数据获取 #

在observeEvent中先把event_data存到变量里，避免重复调用，同时可以获取点击点的marker.color属性，用来同步颜色。

这样修改后，你就能实现点击类别柱状条时该条高亮显示，子类别图表的所有条同步使用选中条的颜色，同时也解决了未注册事件的警告问题。

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