Shiny应用中Plotly 3D散点图按日期固定着色问题

问题原因 #

1. pickerInput的选项结构错误，混入了无关的PointColor分组，可能导致数据过滤逻辑异常
2. Plotly对Date类型变量的颜色映射默认是动态分配的，且当前代码未指定固定颜色规则，导致所有点显示统一蓝色

解决方案步骤 #

• 为每个唯一日期预分配固定颜色，建立日期-颜色映射表
• 修正pickerInput的选项，仅保留日期选择项
• 在Plotly绘图时，通过colors参数绑定预定义的颜色映射，确保颜色不随选中状态变化
• 服务器端过滤数据时使用局部变量，避免覆盖全局数据集

修改后的完整代码 #

library(shiny)
library(tidyverse)
library(plotly)
library(dplyr)
library(shinyWidgets) # 加载shinyWidgets以使用pickerInput

df2 <- structure(list(publicationDate = structure(c(18610, 18410, 18597, 
                                                    18375, 18284), class = "Date"), x = c(8.593744, 10.341268, 11.454429, 
                                                                                          10.595986, 11.012522), y = c(4.2456923, 6.767409, 5.2631335, 
                                                                                                                       6.5070715, 7.6513457), z = c(5.6303487, 8.002673, 6.332502, 8.773426, 
                                                                                                                                                    8.604475), influentialCitationCount = c(98.2037608756666, 100, 
                                                                                                                                                                                            37.8052203199551, 99.6632051641875, 99.1018804378333)), row.names = c(NA, 
                                                                                                                                                                                                  5L), class = "data.frame")
df2 <- df2[order(df2[, 1]), ]

# 预定义日期与固定颜色的映射表
date_colors <- setNames(
  c("#FF6B6B", "#4ECDC4", "#45B7D1", "#96CEB4", "#FFEAA7"), # 自定义固定颜色
  unique(df2$publicationDate)
)

ui <- fluidPage(
  titlePanel("3D Scatter Plot Visualization"),
  sidebarLayout(
    sidebarPanel(
      pickerInput(inputId = "selectedDates",
                  label = "Choose Dates:",
                  choices = as.list(unique(df2$publicationDate)),
                  selected = unique(df2$publicationDate)[1],
                  multiple = TRUE,
                  options = list(
                    `actions-box` = TRUE,
                    `deselect-all-text` = "None...",
                    `select-all-text` = "Yeah, all !",
                    `none-selected-text` = "zero"
                  ))
    ),
    mainPanel(
      plotlyOutput(outputId = "scatterPlot3D")
    )
  )
)

server <- function(input, output) {
  output$scatterPlot3D <- renderPlotly({
    # 过滤数据，使用局部变量避免覆盖全局df2
    filtered_df <- df2[df2$publicationDate %in% input$selectedDates, ]
    
    # 创建3D散点图，绑定固定颜色映射
    scatter3Dplot <- plot_ly(data = filtered_df, 
                             x = ~x, y = ~y, z = ~z, 
                             color = ~publicationDate,
                             colors = date_colors, # 指定预定义的颜色映射
                             type = "scatter3d", mode = "markers",
                             marker = list(size = 3)) %>%
      layout(title = "3D Scatter Plot with Wrapped Title and Custom Popup by Date",
             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)

关键修改说明 #

1. 预定义颜色映射：通过date_colors为每个日期绑定固定颜色，确保每次渲染都使用相同颜色
2. 修正pickerInput选项：移除了多余的PointColor分组，仅保留日期选项，避免数据过滤错误
3. 指定colors参数：在plot_ly中添加colors = date_colors，强制Plotly使用预定义的颜色映射
4. 局部变量过滤数据：使用filtered_df替代直接修改全局df2，防止数据被意外覆盖

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