如何在不重载线框的情况下平滑更新3D网络图？

核心问题根源 #

你当前的实现每次调用Network_plot3d时都会用rgl.clear()清除所有图形后重新绘制，这是频闪的直接原因——并非更新现有对象，而是完全重建整个画面。

优化RGL实现：直接更新现有对象 #

RGL支持直接修改已绘制对象的属性，无需每次清除重绘。核心思路是首次绘制时保存对象ID，后续迭代仅更新这些ID对应的坐标/属性。

修改后的Network_plot3d函数 #

# 全局变量存储已创建的RGL对象ID，避免重复创建
rgl_obj_ids <- list(nodes = NULL, edges = NULL)

Network_plot3d <- function(attr, edgelist, layout.par = "layout.par") {
  lines <- layout.par["lines"]
  
  # 首次初始化窗口与坐标轴范围
  if (rgl.cur() == 0) {
    open3d()
    par3d(
      xlim = c(-layout.par["xlim"], layout.par["xlim"]),
      ylim = c(-layout.par["ylim"], layout.par["ylim"]),
      zlim = c(-layout.par["zlim"], layout.par["zlim"])
    )
  }
  
  # 更新节点：存在则修改属性，不存在则创建
  if (!is.null(rgl_obj_ids$nodes)) {
    rgl.attrib(rgl_obj_ids$nodes, "x", attr[, 1])
    rgl.attrib(rgl_obj_ids$nodes, "y", attr[, 2])
    rgl.attrib(rgl_obj_ids$nodes, "z", attr[, 3])
    # 若颜色/大小需要动态变化，可同步更新
    rgl.attrib(rgl_obj_ids$nodes, "color", attr[, 7])
    rgl.attrib(rgl_obj_ids$nodes, "size", attr[, 8])
  } else {
    rgl_obj_ids$nodes <- plot3d(
      attr[, 1:3],
      col = attr[, 7],
      type = "s",
      size = attr[, 8],
      add = TRUE
    )$id
  }
  
  # 更新边：存在则修改坐标，不存在则创建；不需要时移除
  if (lines == TRUE) {
    edges <- edge_locations(attr, edgelist)
    if (!is.null(rgl_obj_ids$edges)) {
      rgl.attrib(rgl_obj_ids$edges, "x", edges[, 1])
      rgl.attrib(rgl_obj_ids$edges, "y", edges[, 2])
      rgl.attrib(rgl_obj_ids$edges, "z", edges[, 3])
    } else {
      rgl_obj_ids$edges <- lines3d(edges, add = TRUE)$id
    }
  } else {
    if (!is.null(rgl_obj_ids$edges)) {
      rgl.pop3d(id = rgl_obj_ids$edges)
      rgl_obj_ids$edges <- NULL
    }
  }
  
  # 强制刷新画面
  rgl.update()
}

修改sort.surface.sort的调用逻辑 #

移除原有清除对象的代码，改为直接更新现有元素：

sort.surface.sort <- function(attr, edges, layout.par, mod = 0) {   
  if (mod == 0) {mod <- layout.par["iterations"] + 1}              
  iterations <- layout.par["iterations"]                      
  lines <- layout.par["lines"]                                
  layout.par["lines"] <- FALSE                                
  nw <- network(edges, directed = layout.par["directed"])     
  hood_list <- get_neighborhoods(nw)                          
  loud <- layout.par["verbose"]                              
  
  attr <- degree_scaler(attr, layout.par)                      
  if (loud == 1) (print("first it recenters and normalizes everyone to their proper radius"))
  attr <- recenter(attr)
  attr <- normalize_subjective(attr, target_list = 1:nrow(attr), layout.par)
  if (loud == 1) (print("Then it moves everyone to their geometric mean - do in order by hubs?"))
  
  # 首次绘制初始化
  Network_plot3d(attr, edges, layout.par)
  
  for (i in 1:iterations) {
    if (loud == 1) (print(i))
    attr <- geo_mean(hood_list, attr, batch = TRUE, target_list = 1:nrow(attr))
    attr <- recenter(attr)
    attr <- normalize_subjective(attr, target_list = 1:nrow(attr), layout.par) 
    if (i %% mod == 0) {
      Network_plot3d(attr, edges, layout.par)
      # 可选：添加延迟控制动画速度
      Sys.sleep(0.05)
    }
  }
  
  layout.par["lines"] <- lines
  Network_plot3d(attr, edges, layout.par)
  
  return(attr)
}

替代方案：使用plotly实现平滑WebGL动画 #

如果RGL的优化仍达不到预期，可尝试plotly的3D动画功能——它基于WebGL，原生支持平滑属性过渡，适合需要导出或网页展示的场景：

示例实现思路 #

library(plotly)

# 收集所有迭代的节点坐标数据
collect_frames <- function(attr, edges, layout.par, iterations) {
  frames <- list()
  nw <- network(edges, directed = layout.par["directed"])     
  hood_list <- get_neighborhoods(nw)                          
  attr <- degree_scaler(attr, layout.par)
  attr <- recenter(attr)
  attr <- normalize_subjective(attr, target_list = 1:nrow(attr), layout.par)
  
  frames[[1]] <- attr
  for (i in 1:iterations) {
    attr <- geo_mean(hood_list, attr, batch = TRUE, target_list = 1:nrow(attr))
    attr <- recenter(attr)
    attr <- normalize_subjective(attr, target_list = 1:nrow(attr), layout.par)
    frames[[i+1]] <- attr
  }
  return(frames)
}

# 创建plotly动画
plotly_network_animation <- function(frames, edges, layout.par) {
  # 初始化基础图
  p <- plot_ly() %>%
    add_markers(
      x = ~frames[[1]][,1], y = ~frames[[1]][,2], z = ~frames[[1]][,3],
      color = ~frames[[1]][,7], size = ~frames[[1]][,8],
      type = "scatter3d", mode = "markers", marker = list(sizemode = "diameter")
    ) %>%
    add_trace(
      x = ~edge_locations(frames[[length(frames)]], edges)[,1],
      y = ~edge_locations(frames[[length(frames)]], edges)[,2],
      z = ~edge_locations(frames[[length(frames)]], edges)[,3],
      type = "scatter3d", mode = "lines", line = list(color = "#888")
    ) %>%
    layout(
      scene = list(
        xaxis = list(range = c(-layout.par["xlim"], layout.par["xlim"])),
        yaxis = list(range = c(-layout.par["ylim"], layout.par["ylim"])),
        zaxis = list(range = c(-layout.par["zlim"], layout.par["zlim"]))
      )
    )
  
  # 添加动画帧
  for (i in 2:length(frames)) {
    p <- p %>%
      add_frames(
        data = frames[[i]],
        name = paste0("frame", i),
        add_markers(
          x = ~frames[[i]][,1], y = ~frames[[i]][,2], z = ~frames[[i]][,3],
          color = ~frames[[i]][,7], size = ~frames[[i]][,8]
        ),
        add_trace(
          x = ~edge_locations(frames[[i]], edges)[,1],
          y = ~edge_locations(frames[[i]], edges)[,2],
          z = ~edge_locations(frames[[i]], edges)[,3]
        )
      )
  }
  
  # 设置动画过渡参数
  p <- p %>%
    animation_opts(frame = 50, transition = 0, redraw = FALSE) %>%
    animation_slider(currentvalue = list(prefix = "Iteration: "))
  
  return(p)
}

关键注意事项 #

• RGL的rgl.attrib()仅支持修改动态属性，球体的位置、颜色、大小及线条坐标均属于可修改范围。
• 使用全局变量rgl_obj_ids时，多次运行前需重置该变量，避免对象ID冲突。
• plotly动画适合导出或网页展示，RGL则更适合本地交互式操作。

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