如何在R Shiny Highcharts数据更新后保留点击点的颜色

问题背景 #

使用R Shiny + Highcharts构建了按年份动态更新的散点图，启动动画后数据点随年份移动。已实现点击点变红的功能，但每次数据更新（滑块切换/动画播放）后，已点击点的自定义颜色会丢失，需要在数据更新后保留这些点的颜色。

解决方案思路 #

核心是在Shiny服务器端维护一个选中点名称的集合，每次更新图表数据时，为这些选中点添加自定义颜色属性，确保Highcharts渲染时应用该颜色。具体步骤：

• 用reactiveVal创建响应式变量，存储所有被用户点击选中的点名称
• 修改Highcharts的点点击事件，将点击点的name传递给Shiny，并切换该点的选中状态（加入/移除集合）
• 在准备图表数据时，为选中的点添加color: 'red'属性
• 调整图表的渲染和更新逻辑，确保自定义颜色被正确应用

完整代码实现 #

library(shiny)
library(highcharter)
library(dplyr)

dat <- 
  data.frame(
    year=seq(2000,2020),
    x=seq(0,20),
    y=seq(0,20),
    name=letters[seq(1,21)]
  ) %>% 
  add_row(
    data.frame(
      year=seq(2000,2020),
      x=seq(2,22),
      y=seq(2,22),
      name=letters[seq(1,21)]
    ) )

shinyApp(
  
  ui=fluidPage(
    
    # 年份滑块
    sliderInput(
      inputId = "g2_slider",
      label = NULL,
      min = 2000,
      max = 2020,
      value = 2000,
      step = 1,
      sep = "",
      animate = animationOptions(
        interval = 1000,
        loop = FALSE,
        playButton = actionButton("play", "Play", icon = icon("play"), width = "100px", style = "margin-top: 10px"),
        pauseButton = actionButton("pause", "Pause", icon = icon("pause"), width = "100px", style = "margin-top: 10px")
      )),
    
    actionButton("reset", "Reset", width = "100px", style = "margin-top: -87px"),
    
    # 散点图
    highchartOutput("g2_plot"),
    
  ), 
  
  server=function(input, output, session) {
    
    x_min <- dat %>% pull(x) %>% min()
    x_max <- dat %>% pull(x) %>% max()
    y_min <- dat %>% pull(y) %>% min()
    y_max <- dat %>% pull(y) %>% max()
    
    # 存储选中的点名称
    selected_points <- reactiveVal(c())
    
    # 重置按钮逻辑
    observeEvent(input$reset, {
      updateSliderInput(
        session = session,
        inputId = "g2_slider",
        value = 2000
      )
      # 重置选中点
      selected_points(c())
    })
    
    # 接收前端点击的点名称，切换选中状态
    observeEvent(input$point_clicked, {
      current <- selected_points()
      clicked_name <- input$point_clicked
      if(clicked_name %in% current){
        # 已选中则移除
        selected_points(current[current != clicked_name])
      } else {
        # 未选中则添加
        selected_points(c(current, clicked_name))
      }
    })
    
    # 准备带颜色的数据：选中的点设为红色
    prepare_data <- function(year){
      dat %>% 
        filter(year == year) %>% 
        mutate(
          color = ifelse(name %in% selected_points(), "red", NULL)
        ) %>% 
        # 转换为Highcharts需要的列表格式
        rowwise() %>% 
        mutate(data = list(list(x=x, y=y, name=name, color=color))) %>% 
        pull(data)
    }
    
    # 渲染初始图表
    output$g2_plot <- renderHighchart({ 
      
      highchart() %>% 
        hc_add_series(
          data = prepare_data(input$g2_slider),
          type = "scatter",
          animation=FALSE,
          id="scatter1"
        ) %>% 
        hc_plotOptions(
          series = list(
            point = list(
              events = list(
                # 点击时将点名称发送到Shiny服务器
                click = JS("function(event) { 
                            Shiny.setInputValue('point_clicked', this.name, {priority: 'event'});
                          }") 
              )))) %>% 
        hc_title(text = paste0("Year: ", input$g2_slider)) %>% 
        hc_xAxis(
          title = list(text = "x"),
          min=x_min, 
          max=x_max
        ) %>%
        hc_yAxis(
          title = list(text = "y"),
          min=y_min,
          max=y_max
        ) %>%
        hc_legend(enabled = FALSE) 
    })
    
    # 动态更新图表
    observeEvent(input$g2_slider, {
      
      highchartProxy("g2_plot") %>%
        hcpxy_update_series(
          id = "scatter1",
          data = prepare_data(input$g2_slider)
        ) %>% 
        hcpxy_update(title = list(text = paste0("Year: ", input$g2_slider)))
      
    })
    
  })

代码说明 #

• selected_points：响应式变量，存储所有被用户选中的点名称，实现跨数据更新的状态保存
• prepare_data函数：根据当前年份和选中点列表，为数据点添加颜色属性，选中点设为红色
• 点击事件修改：不再直接在前端修改颜色，而是将点名称发送到Shiny服务器，由服务器维护选中状态
• 图表更新时，使用prepare_data生成带颜色的数据，确保选中点的颜色被保留

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