如何在DiagrammeR中把文本显示在箭头上方？

前端开发 2026-07-12

我正在用这段代码，根据结构方程模型的结果来绘制图表：

create_sem_diagram_ex <- function(node_edges) {

  sig_level      <- 0.05
  marginal_level <- 0.1

  var_names <- c(
    "CN_ratio"              = "C/N ratio",
    "tot_basal_area_m2perha"= "Forest basal area",
    "pimu_cover"            = "Mountain pine cover",
    "elevation"             = "Elevation",
    "bac_tax_shannon_bc"    = "Bacterial tax. div.",
    "fun_tax_shannon_bc"    = "Fungal tax. div."
  )

  rename_var <- function(var) {
    ifelse(var %in% names(var_names), var_names[var], var)
  }

  left_column_default <- c("pimu_cover", "tot_basal_area_m2perha", "elevation")

  all_nodes   <- unique(c(node_edges$Predictor, node_edges$Response))
  left_column <- left_column_default[left_column_default %in% all_nodes]

  node_edges <- node_edges %>%
    mutate(
      edge_colour = case_when(
        P.Value > marginal_level                              ~ "grey80",
        P.Value <= sig_level      & Std.Estimate > 0         ~ "forestgreen",
        P.Value <= sig_level      & Std.Estimate < 0         ~ "darkorange3",
        P.Value <= marginal_level & Std.Estimate > 0         ~ "#99c58f",
        P.Value <= marginal_level & Std.Estimate < 0         ~ "tan1"
      ),
      penwidth   = case_when(
        P.Value <= sig_level      ~ 2.5,
        P.Value <= marginal_level ~ 1.5,
        TRUE                     ~ 0.8
      ),
      path_label = ifelse(P.Value <= marginal_level, sprintf("%.3f", Std.Estimate), "")
    )

  node_defs <- sapply(all_nodes, function(node) {
    sprintf('  "%s" [label="%s", shape=box, style="rounded,filled", fillcolor="white", fontname=Helvetica];',
            node, rename_var(node))
  })

  edges <- apply(node_edges, 1, function(row) {
    label_attr <- if (nchar(row["path_label"]) > 0) 
      sprintf(', label="%s"', row["path_label"]) else ""
    sprintf(
      '  "%s" -> "%s" [color="%s", penwidth=%s%s];',
      row["Predictor"], row["Response"],
      row["edge_colour"], row["penwidth"],
      label_attr
    )
  })

  # invisible edges keep mid-ranked nodes tidier
  invisible_edges <- c()
  if (length(left_column) > 1) {
    for (i in 1:(length(left_column) - 1)) {
      invisible_edges <- c(invisible_edges,
                           sprintf('  "%s" -> "%s" [style=invis];', left_column[i], left_column[i + 1]))
    }
  }

  mid_column_default <- c("pH", "CN_ratio")
  mid_column <- mid_column_default[mid_column_default %in% all_nodes]

  mid_rank_block <- if (length(mid_column) > 0) {
    paste0("  { rank=same;\n",
           paste(sprintf('    "%s";', mid_column), collapse = "\n"),
           "\n  }\n\n")
  } else ""

  dot_spec <- paste0(
    "digraph SEM {\n",
    "  graph [rankdir=LR, nodesep=0.2, ranksep=0.5];\n",
    "  edge [fontname=Helvetica, fontsize=10];\n\n",
    paste(node_defs, collapse = "\n"),
    "\n\n  { rank=source;\n",
    paste(sprintf('    "%s";', left_column), collapse = "\n"),
    "\n  }\n\n",
    paste(invisible_edges, collapse = "\n"),
    "\n\n",
    paste(edges, collapse = "\n"),
    "\n}"
  )

  grViz(dot_spec)
}

但边上的文本会被绘制在各自箭头的下方，这有时会导致信号被遮挡。在下面的示例中，-0.535的负号被完全遮挡。

在此输入图片描述

我需要怎么修改，才能让文本出现在箭头之上？或者至少避开箭头？

解决方案

你可以通过将所有svg text 元素在视觉上放到最前面来实现，将它们追加到主图 graph0。

res

create_sem_diagram_ex(node_edges) |>
  htmlwidgets::onRender('function(el, x) {
    var svg = el.querySelector("svg");
    var graph = svg.querySelector("g#graph0");
    var texts = graph.querySelectorAll("g.edge text");
    texts.forEach(function(t) {
      graph.appendChild(t);
    });
  }')

数据、函数、库调用

library(DiagrammeR)
library(dplyr)

create_sem_diagram_ex <- function(node_edges) {

  sig_level      <- 0.05
  marginal_level <- 0.1

  var_names <- c(
    "CN_ratio"              = "C/N ratio",
    "tot_basal_area_m2perha"= "Forest basal area",
    "pimu_cover"            = "Mountain pine cover",
    "elevation"             = "Elevation",
    "bac_tax_shannon_bc"    = "Bacterial tax. div.",
    "fun_tax_shannon_bc"    = "Fungal tax. div."
  )

  rename_var <- function(var) {
    ifelse(var %in% names(var_names), var_names[var], var)
  }

  left_column_default <- c("pimu_cover", "tot_basal_area_m2perha", "elevation")

  all_nodes   <- unique(c(node_edges$Predictor, node_edges$Response))
  left_column <- left_column_default[left_column_default %in% all_nodes]

  node_edges <- node_edges %>%
    mutate(
      edge_colour = case_when(
        P.Value > marginal_level                              ~ "grey80",
        P.Value <= sig_level      & Std.Estimate > 0         ~ "forestgreen",
        P.Value <= sig_level      & Std.Estimate < 0         ~ "darkorange3",
        P.Value <= marginal_level & Std.Estimate > 0         ~ "#99c58f",
        P.Value <= marginal_level & Std.Estimate < 0         ~ "tan1"
      ),
      penwidth   = case_when(
        P.Value <= sig_level      ~ 2.5,
        P.Value <= marginal_level ~ 1.5,
        TRUE                     ~ 0.8
      ),
      path_label = ifelse(P.Value <= marginal_level, sprintf("%.3f", Std.Estimate), "")
    )

  node_defs <- sapply(all_nodes, function(node) {
    sprintf('  "%s" [label="%s", shape=box, style="rounded,filled", fillcolor="white", fontname=Helvetica];',
            node, rename_var(node))
  })

  edges <- apply(node_edges, 1, function(row) {
    label_attr <- if (nchar(row["path_label"]) > 0) 
      sprintf(', label="%s"', row["path_label"]) else ""
    sprintf(
      '  "%s" -> "%s" [color="%s", penwidth=%s%s];',
      row["Predictor"], row["Response"],
      row["edge_colour"], row["penwidth"],
      label_attr
    )
  })

  # invisible edges keep mid-ranked nodes tidier
  invisible_edges <- c()
  if (length(left_column) > 1) {
    for (i in 1:(length(left_column) - 1)) {
      invisible_edges <- c(invisible_edges,
                           sprintf('  "%s" -> "%s" [style=invis];', left_column[i], left_column[i + 1]))
    }
  }

  mid_column_default <- c("pH", "CN_ratio")
  mid_column <- mid_column_default[mid_column_default %in% all_nodes]

  mid_rank_block <- if (length(mid_column) > 0) {
    paste0("  { rank=same;\n",
           paste(sprintf('    "%s";', mid_column), collapse = "\n"),
           "\n  }\n\n")
  } else ""

  dot_spec <- paste0(
    "digraph SEM {\n",
    "  graph [rankdir=LR, nodesep=0.2, ranksep=0.5];\n",
    "  edge [fontname=Helvetica, fontsize=10];\n\n",
    paste(node_defs, collapse = "\n"),
    "\n\n  { rank=source;\n",
    paste(sprintf('    "%s";', left_column), collapse = "\n"),
    "\n  }\n\n",
    paste(invisible_edges, collapse = "\n"),
    "\n\n",
    paste(edges, collapse = "\n"),
    "\n}"
  )

  grViz(dot_spec)
}

set.seed(1)

node_edges <- data.frame(
  Predictor          = sample(c("elevation", "pimu_cover", "tot_basal_area_m2perha", "CN_ratio", "pH", "pimu_cover"), 10, replace = T),
  Response           = sample(c("elevation", "pimu_cover", "tot_basal_area_m2perha", "CN_ratio", "pH", "pimu_cover"), 10, replace = T),
  Std.Estimate       = rnorm(10),
  P.Value            = rnorm(10),
  stringsAsFactors   = FALSE
)

其他选项：

这些也是我尝试过的选项，但效果并不理想，因为它们会移动标签、改变颜色，却不能解决主要问题。它们也许对你有用。

你也可以尝试调整 taillabel labeldistance，但我发现这也相当手动。

edges <- apply(node_edges, 1, function(row) {
    label_attr <- if (nchar(row["path_label"]) > 0) 
      sprintf(', taillabel="%s" labeldistance=1', row["path_label"]) else ""
...
站内所有文章版权归属LeftHeroAI导航站，无授权禁止任何主体转载、抄袭、复制内容，亦不得私自架设镜像站点。一经侵权，本站将通过法律途径追责。

相关文章

怎么用Shapely检测共享边
5
如何去除着色区域之间的间隙？
0
在Xero的 Journal实体中，能否编辑Journal Lines的元数据或字段？
0
避免线条和箭头互相交叉
0
在一个栈上设置内边距，其子视图可能是空视图
1
在双向链表中，addLast方法只在链表为空时起作用一次，其他情况下根本不起作用
1
汇集全球数千款 AI 工具，每日持续更新，配套 AI 开发学习资源，轻松用 AI 提升工作效率。快捷键 Ctrl+D/⌘+D 一键收藏本站。

超人AI导航关于我们免责声明

Copyright © 超人AI导航  辽ICP备2024029316号-4