如何让R中Plotly树状图hover时显示节点自定义信息？

问题背景 #

已用R完成历史工作流树状图的基础渲染，需要实现鼠标悬停在节点或分支位置时，显示actions列表中对应的自定义label和state信息。

解决方案 #

核心思路是将自定义的label和state数据关联到ggdendro生成的树状图数据中，通过ggplot的text美学映射定义悬停内容，最后用ggplotly启用悬停提示。

修改后的完整代码 #

library(plotly)
library(ggplot2)
library(ggdendro)
library(shiny)

find_lca <- function(parents, depth, node1, node2) {
  # Find the depths of the nodes
  depth1 <- depth[node1]
  depth2 <- depth[node2]
  
  # Make sure node1 is at a higher depth
  if (depth1 < depth2) {
    temp <- node1
    node1 <- node2
    node2 <- temp
  }
  
  # Adjust the depth of node1
  depth_diff <- depth1 - depth2
  while (depth_diff > 0) {
    node1 <- parents[node1]
    depth_diff <- depth_diff - 1
  }
  
  # Check if node1 and node2 are already the same
  if (node1 == node2) {
    return(node1)
  }
  
  # Move up both nodes until they have a common parent
  while (parents[node1] != parents[node2]) {
    node1 <- parents[node1]
    node2 <- parents[node2]
  }
  
  # Return the lowest common ancestor
  return(parents[node1])
}

calculate_distance <- function(parent.of.index, distance.from.root, child_a_index, child_b_index) {
  
  # Calculate the distance between root and n1
  dist_n1_root <- distance.from.root[[child_a_index]]
  # Calculate the distance between root and n2
  dist_n2_root <- distance.from.root[[child_b_index]]
  
  # Calculate the distance between n1 and n2
  dist_n1_n2 <- distance.from.root[[find_lca(parent.of.index, distance.from.root, child_a_index, child_b_index)]]
  # Calculate the final distance using the formula
  final_distance <- dist_n1_root + dist_n2_root - 2 * dist_n1_n2
  
  return(final_distance)
}


state <- list(1, 2, 3, 4, 5)
actions = list( list(label = "Action 1", variables = state[1]), 
                list(label = "Action 2", variables = state[2]), 
                list(label = "Action 3", variables = state[3]), 
                list(label = "Action 4", variables = state[4]), 
                list(label = "Action 5", variables = state[5]) 
)
parent.of.index = c(-1, 1, 1, 3, 3)
depth = c(0, 1, 1, 2, 2)

dendro_data <- data.frame(
  child_b = c()
)


for (i in 2:length(actions)) {
  for (j in 1:(i-1)) {
    child_a <- i
    child_b <- j
    #child_b is ALWAYS smaller/higher/earlier than child_a
    distance <- calculate_distance(parent.of.index, depth, child_a, child_b)
    dendro_data[i, j] = distance
  }
}

dendro_data <- dendro_data[-1, ]
colnames(dendro_data) <- state[-length(state)]

temp = as.vector(na.omit(unlist(dendro_data)))
NM = unique(c(colnames(dendro_data), row.names(dendro_data)))
mydist = structure(temp, Size = length(NM), Labels = NM,
                   Diag = FALSE, Upper = FALSE, method = "euclidean", #Optional
                   class = "dist")
model <- hclust(mydist)
dhc <- as.dendrogram(model)

# 提取树状图完整数据（含线段和节点）
data <- dendro_data(dhc, type = "triangle")

# 处理节点数据，关联自定义label和state
node_data <- data$label
node_data$state <- as.integer(node_data$label)
# 匹配actions中的自定义信息
node_data <- merge(node_data, 
                   do.call(rbind, lapply(actions, function(x) data.frame(label = x$label, state = unlist(x$variables)))),
                   by = "state", all.x = TRUE)

# 处理线段数据，关联对应子节点的自定义信息
segment_data <- data$segment
segment_data <- merge(segment_data, node_data[, c("x", "label", "state")], by.x = "x", by.y = "x", all.x = TRUE)

# 绘制树状图并添加悬停文本
p <- ggplot() + 
  # 分支线段添加悬停信息
  geom_segment(data = segment_data, 
               aes(x = x, y = y, xend = xend, yend = yend,
                   text = paste("Label:", label, "\nState:", state))) + 
  # 节点标签添加悬停信息
  geom_text(data = node_data, 
            aes(x = x, y = y, label = label,
                text = paste("Label:", label, "\nState:", state))) +
  scale_y_reverse(expand = c(0.2, 0)) +
  theme_dendro()

# 启用悬停提示，指定显示自定义文本内容
ggplotly(p, tooltip = "text")

关键修改说明 #

• 数据关联：将node_data与actions中的label、state匹配，确保每个节点对应到自定义信息
• 悬停文本定义：在geom_segment和geom_text的美学映射中加入text参数，用paste组合多行提示内容
• 悬停启用：调用ggplotly时指定tooltip = "text"，让Plotly渲染自定义的悬停提示

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