R Plotly动画中连接点线段异常及箭头替换问题求助

问题根源分析 #

1. 线段浮动：原始add_segments按day分组渲染时，未绑定连接的生命周期，且重复数据导致Plotly渲染逻辑不稳定，引发线段位置偏移。
2. 线段消失：add_segments结合color参数时，分组机制过滤了部分重复/不匹配记录；部分连接因infector.x/y关联缺失为NA，无法渲染。
3. 连接不全：原始仅提取day=1的感染者坐标，后续出现的传染源（如ID2）未被纳入，导致部分连接坐标缺失。
4. 箭头动画失效：Plotly的add_annotations不支持直接通过frame参数绑定动画，需手动构建每个帧的注释列表。

修复后的线段版本代码 #

library(dplyr)
library(plotly)

set.seed(12)
df <- tibble(
  day = rep(1:8, each = 10),
  id = rep(paste0("ID", 1:10), 8),
  infector = NA
) %>%
  group_by(id) %>%
  mutate(x = rnorm(1),
         y = rnorm(1),
         group =  sample(c("A", "B", "C"), 1)) %>%
  ungroup() %>%
  mutate(
    infector = case_when(
      id == "ID2" & day >= 1 ~ "ID4",
      id == "ID3" & day >= 2 ~ "ID4",
      id == "ID1" & day >= 3 ~ "ID2",
      id == "ID5" & day >= 3 ~ "ID3",
      id == "ID6" & day >= 3 ~ "ID4",
      id == "ID10" & day >= 4 ~ "ID2",
      id == "ID9" & day >= 7 ~ "ID5"
    )
  )

# 提取所有传染源的固定坐标（每个ID的x/y不变）
infectors <- df %>% 
  distinct(id, x, y, group) %>% 
  rename(infector = id, infector.x = x, infector.y = y, infector_group = group)

df <- left_join(df, infectors, by = "infector")

# 过滤出有效连接行，避免无效渲染
segments_df <- df %>% filter(!is.na(infector))

pal <- c("A" = "blue", "B" = "green", "C" = "red")

plot_ly() %>%
  # 先绘制线段，确保层级在标记下方
  add_segments(
    data = segments_df,
    x = ~infector.x,
    xend = ~x,
    y = ~infector.y,
    yend = ~y,
    color = ~infector_group,
    colors = pal,
    frame = ~day,
    showlegend = FALSE
  ) %>%
  add_markers(
    data = df,
    x = ~x,
    y = ~y,
    frame = ~day,
    hoverinfo = "text",
    text = ~paste("ID:", id),
    symbol = ~group,
    color = ~group,
    colors = pal
  ) %>%
  layout(
    xaxis = list(title = "X"),
    yaxis = list(title = "Y")
  ) %>%
  animation_opts(
    frame = 1000, # 帧间隔（毫秒）
    transition = 500, # 过渡时长
    redraw = TRUE
  )

修复点说明 #

• 改用distinct提取所有ID的固定坐标，确保连接起始点稳定，解决线段浮动问题。
• 过滤无连接的行，减少无效渲染，避免线段消失。
• 纳入所有传染源坐标，确保所有连接都能正确绘制。
• 分离线段与标记的数据逻辑，保留color/symbol参数的同时避免分组冲突。

箭头版本代码（替换线段为箭头） #

由于add_annotations不直接支持动画，需手动构建每个帧的注释列表：

# 按day分组构建箭头注释
frame_annotations <- segments_df %>%
  group_by(day) %>%
  group_map(function(data, day_val) {
    lapply(1:nrow(data), function(i) {
      list(
        x = data$x[i],
        y = data$y[i],
        ax = data$infector.x[i],
        ay = data$infector.y[i],
        xref = "x",
        yref = "y",
        axref = "x",
        ayref = "y",
        showarrow = TRUE,
        arrowhead = 2,
        arrowsize = 1,
        arrowcolor = pal[data$infector_group[i]],
        arrowwidth = 2
      )
    })
  }) %>%
  set_names(paste0("frame_", 1:8))

# 构建动画帧对象
frames <- lapply(1:8, function(d) {
  list(
    name = as.character(d),
    data = list(
      list(
        type = "scatter",
        mode = "markers",
        x = df$x[df$day == d],
        y = df$y[df$day == d],
        text = paste("ID:", df$id[df$day == d]),
        symbol = df$group[df$day == d],
        color = pal[df$group[df$day == d]],
        hoverinfo = "text"
      )
    ),
    layout = list(annotations = frame_annotations[[d]])
  )
})

# 初始图（显示day1内容）
initial_markers <- df %>% filter(day == 1)

plot_ly(initial_markers, x = ~x, y = ~y, type = "scatter", mode = "markers",
        hoverinfo = "text", text = ~paste("ID:", id),
        symbol = ~group, color = ~group, colors = pal) %>%
  layout(
    xaxis = list(title = "X"),
    yaxis = list(title = "Y"),
    annotations = frame_annotations[["frame_1"]]
  ) %>%
  animation_opts(frame = 1000, transition = 500, redraw = TRUE) %>%
  animation_slider(currentvalue = list(prefix = "Day: ")) %>%
  animation_button(label = "Play") %>%
  add_frames(frames)

箭头版本说明 #

• 手动为每个day绑定对应的箭头注释，通过add_frames实现动画效果。
• 箭头颜色与传染源分组保持一致，视觉统一。
• 可自定义动画控制参数（滑块、播放按钮等）。

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