Shiny应用中为动态子集化数据集的唯一列值分配稳定颜色

我在Shiny应用中每次都会上传包含动态数量topicLabel的数据集，并且需要选择在图表中显示任意数量的topicLabel。核心需求是为每个topicLabel分配稳定的颜色——无论隐藏/恢复某个标签，或是添加新主题，对应标签的颜色都保持不变。

我尝试过在上传数据集后给数据框添加颜色列（示例中已预先准备该列），以为这样不会受后续子集化操作影响；也接受通过传入适配动态数量topicLabel的颜色列表来实现需求。以下是我的初始尝试代码：

# install.packages("shiny")
library(shiny)
library(tidyverse)
library(plotly)
library(shinyWidgets)
library(dplyr)

df2<-structure(list(topicLabel = c("Advancements in Speech Recognition and Audio Processing", 
                                   "Medical Applications of ChatGPT and AI in Healthcare", "Innovative Software and Information Systems in Engineering", 
                                   "Medical Applications of ChatGPT and AI in Healthcare", "Unassigned Papers"
), x3D = c(3.1479151, -0.8278939, -0.725248, -1.076007, -0.50435966
), y3D = c(9.737644, 3.1556723, 7.265499, 3.0800967, 3.873302
), z3D = c(9.376617, 8.729877, 5.7492423, 8.762159, 8.518042), 
AssignedColor = c("red", "green", "yellow", "black", 
                  "blue")), row.names = c(144L, 318L, 582L, 588L, 662L), class = "data.frame")

# Get unique names from the 'Name' column
unique_names <- unique(df2$topicLabel)

# Assign colors to unique names
assigned_colors <- colors[1:length(unique_names)]

# Create a new column 'AssignedColor' based on the matching of names with colors
df2$AssignedColor <- assigned_colors[match(df2$topicLabel, unique_names)]

ui <- fluidPage(
  titlePanel("3D Scatter Plot Visualization"),
  sidebarLayout(
    sidebarPanel(
        uiOutput("p1")
    ),
    mainPanel(
                 plotlyOutput(outputId = "scatterPlot3D")
      )
    )
  )

server <- function(input, output) {
  output$p1<-renderUI({
    pickerInput(inputId = "selectedTopics",
                label = "Choose Topic Labels:",
                choices = list(Topics = as.list(unique(df2$topicLabel))),
                selected = unique(df2$topicLabel)[1],
                multiple = TRUE,
                options = list(
                  `actions-box` = TRUE,
                  `deselect-all-text` = "None...",
                  `select-all-text` = "Yeah, all !",
                  `none-selected-text` = "zero"
                ))
  })
  
  output$scatterPlot3D <- renderPlotly({
    # Filter data based on selected topicLabels
    filteredData <- df2[df2$topicLabel %in% input$selectedTopics, ]
    
      # Create the 3D scatter plot with bolded hover text
      scatter3Dplot <- plot_ly(data = filteredData, x = ~x3D, y = ~y3D, z = ~z3D, color = ~as.character(topicLabel),
                               type = "scatter3d", mode = "markers",
                               marker = list(size = 3),
                               colors = ~AssignedColor
                               ) %>%
        layout(title = "3D Scatter Plot with Wrapped Title and Custom Popup by topicLabel",
               scene = list(
                 xaxis = list(title = "X Axis"),
                 yaxis = list(title = "Y Axis"),
                 zaxis = list(title = "Z Axis")
               )) %>%
        layout(legend = list(orientation = "h"),
               showlegend = FALSE)
      
      return(scatter3Dplot)
  })
}

# Component 3: A call to the `shinyApp` function
shinyApp(ui = ui, server = server)

问题分析与修改方案 #

初始代码的核心问题在于plot_ly中colors = ~AssignedColor的用法错误——该参数需要的是颜色映射规则，而非直接引用数据列。要实现颜色稳定，需基于所有可能的topicLabel构建全局颜色映射表，确保每次渲染图表时，颜色与标签的对应关系固定。

修改要点：

• 构建命名向量形式的颜色映射表：将每个唯一topicLabel映射到固定颜色，确保全局唯一对应
• 在plot_ly中直接使用该映射表作为colors参数，而非依赖过滤后的数据列
• 若为动态上传数据场景，需在数据上传后重新生成该映射表（示例为静态数据，可直接全局定义）

修改后的完整代码 #

# install.packages("shiny")
library(shiny)
library(tidyverse)
library(plotly)
library(shinyWidgets)
library(dplyr)

df2<-structure(list(topicLabel = c("Advancements in Speech Recognition and Audio Processing", 
                                   "Medical Applications of ChatGPT and AI in Healthcare", "Innovative Software and Information Systems in Engineering", 
                                   "Medical Applications of ChatGPT and AI in Healthcare", "Unassigned Papers"
), x3D = c(3.1479151, -0.8278939, -0.725248, -1.076007, -0.50435966
), y3D = c(9.737644, 3.1556723, 7.265499, 3.0800967, 3.873302
), z3D = c(9.376617, 8.729877, 5.7492423, 8.762159, 8.518042), 
AssignedColor = c("red", "green", "yellow", "black", 
                  "blue")), row.names = c(144L, 318L, 582L, 588L, 662L), class = "data.frame")

# 构建全局颜色映射表：命名向量，key为topicLabel，value为对应颜色
unique_topics <- unique(df2$topicLabel)
color_mapping <- setNames(df2$AssignedColor[match(unique_topics, df2$topicLabel)], unique_topics)

ui <- fluidPage(
  titlePanel("3D Scatter Plot Visualization"),
  sidebarLayout(
    sidebarPanel(
        uiOutput("p1")
    ),
    mainPanel(
                 plotlyOutput(outputId = "scatterPlot3D")
      )
    )
  )

server <- function(input, output) {
  output$p1<-renderUI({
    pickerInput(inputId = "selectedTopics",
                label = "Choose Topic Labels:",
                choices = list(Topics = as.list(unique_topics)),
                selected = unique_topics[1],
                multiple = TRUE,
                options = list(
                  `actions-box` = TRUE,
                  `deselect-all-text` = "None...",
                  `select-all-text` = "Yeah, all !",
                  `none-selected-text` = "zero"
                ))
  })
  
  output$scatterPlot3D <- renderPlotly({
    # 过滤数据
    filteredData <- df2[df2$topicLabel %in% input$selectedTopics, ]
    
    # 使用全局颜色映射表，确保颜色与topicLabel固定对应
    scatter3Dplot <- plot_ly(data = filteredData, 
                             x = ~x3D, y = ~y3D, z = ~z3D, 
                             color = ~topicLabel,
                             type = "scatter3d", mode = "markers",
                             marker = list(size = 3),
                             colors = color_mapping) %>%
      layout(title = "3D Scatter Plot with Wrapped Title and Custom Popup by topicLabel",
             scene = list(
               xaxis = list(title = "X Axis"),
               yaxis = list(title = "Y Axis"),
               zaxis = list(title = "Z Axis")
             )) %>%
      layout(legend = list(orientation = "h"),
             showlegend = FALSE)
    
    return(scatter3Dplot)
  })
}

shinyApp(ui = ui, server = server)

效果说明 #

修改后，无论选择哪些topicLabel，每个标签的颜色始终与初始分配的颜色保持一致。即使隐藏部分标签后再恢复，或后续上传包含新topicLabel的数据集（只需重新生成color_mapping），颜色与标签的对应关系都不会混乱。

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