如何在R的sankeyNetwork桑基图列标题中添加换行？

问题背景 #

通过sankeyNetwork()生成桑基图后，使用htmlwidgets::onRender添加的列标题因过长溢出图表，需要在指定位置添加换行以完整显示。

数据与原代码 #

链接数据 #

sali1 <- structure(list(source = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L), levels = c("Yes", "I have heard something about it", "No", "I don't no/No answer"), class = "factor"), target = c("Strongly Disagree ", "Disagree ", "Neither agree, nor disagree ", "Agree ", "Strongly Agree ", "I don't know/No answer ", "Strongly Disagree ", "Disagree ", "Neither agree, nor disagree ", "Agree ", "Strongly Agree ", "I don't know/No answer ", "Strongly Disagree ", "Disagree ", "Neither agree, nor disagree ", "Agree ", "Strongly Agree ", "I don't know/No answer ", "Disagree ", "Neither agree, nor disagree ", "Agree ", "Strongly Agree ", "I don't know/No answer "), value = c(32L, 84L, 101L, 162L, 31L, 2L, 20L, 83L, 419L, 479L, 60L, 20L, 9L, 16L, 134L, 152L, 31L, 151L, 2L, 7L, 2L, 3L, 12L), group = c("Yes", "Yes", "Yes", "Yes", "Yes", "Yes", "I-have-heard-something-about-it", "I-have-heard-something-about-it", "I-have-heard-something-about-it", "I-have-heard-something-about-it", "I-have-heard-something-about-it", "I-have-heard-something-about-it", "No", "No", "No", "No", "No", "No", "I-dont-no/No-answer", "I-dont-no/No-answer", "I-dont-no/No-answer", "I-dont-no/No-answer", "I-dont-no/No-answer"), IDsource = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3), IDtarget = c(4, 5, 6, 7, 8, 9, 4, 5, 6, 7, 8, 9, 4, 5, 6, 7, 8, 9, 5, 6, 7, 8, 9)), row.names = c(NA, -23L), class = c("grouped_df", "tbl_df", "tbl", "data.frame"), groups = structure(list(source = structure(1:4, levels = c("Yes", "I have heard something about it", "No", "I don't no/No answer"), class = "factor"), .rows = structure(list(1:6, 7:12, 13:18, 19:23), ptype = integer(0), class = c("vctrs_list_of", "vctrs_vctr", "list"))), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -4L), .drop = TRUE))

节点数据 #

nodes <- structure(list(name = c("Yes", "I have heard something about it", "No", "I don't no/No answer", "Strongly Disagree ", "Disagree ", "Neither agree, nor disagree ", "Agree ", "Strongly Agree ", "I don't know/No answer "), group = c("Yes", "I-have-heard-something-about-it", "No", "I-dont-no/No-answer", "Strongly-Disagree-", "Disagree-", "Neither-agree,-nor-disagree-", "Agree-", "Strongly-Agree-", "I-dont-know/No-answer-")), row.names = c(NA, -10L), class = "data.frame")

原绘图代码 #

# Manually change color
color_scale <- "d3.scaleOrdinal() .domain(['Yes', 'I-have-heard-something-about-it', 'No','I-dont-no/No-answer', 'Strongly-Disagree-','Disagree-', 'Neither-agree,-nor-disagree-', 'Agree-', 'Strongly-Agree-', 'I-dont-know/No-answer-']) .range(['#28C4A9', '#A0C982', '#857A6E', '#bebebe', '#857A6E', '#D5B252', '#00487F', '#A0C982', '#28C4A9', '#bebebe']); "

# Plot sankey
sankey_sali1 <- sankeyNetwork(Links = sali1, Nodes = nodes,
                              Source = "IDsource", Target = "IDtarget",
                              Value = "value", NodeID = "name",
                              sinksRight = FALSE,
                              colourScale = color_scale,
                              NodeGroup = "group",
                              LinkGroup = "group",
                              nodeWidth = 40, fontSize = 20,
                              fontFamily = "Arial",
                              nodePadding = 20,
                              iterations = 0,
                              margin = list(left = 1, right = 1, top = 40, bottom = 10))

# Apply the manual var labels and change font of the labels
sankey_sali1 <- htmlwidgets::onRender(sankey_sali1, '
    function(el, x) { 
        var cols_x = this.sankey.nodes()
            .map(d => d.x)
            .filter((v, i, a) => a
            .indexOf(v) === i)
            .sort(function(a, b){return a - b});
        var labels = ["Do you know anything about radon?", "Radon may be a problem, but I have not paid much attention to it"];
        cols_x.forEach((d, i) => {
        d3.select(el)
            .select("svg")
            .append("text")
            .attr("x", d)
            .attr("y", 25)
            .text(labels[i])
            .style("font-family", "Arial")
            .style("font-size", "23");
        })
      }
    ')
  
sankey_sali1

解决方案 #

要实现标题换行，需在onRender的JavaScript代码中，将过长的标题拆分为多行，通过tspan元素实现换行布局。具体修改如下：

修改后的onRender代码 #

sankey_sali1 <- htmlwidgets::onRender(sankey_sali1, '
    function(el, x) { 
        var cols_x = this.sankey.nodes()
            .map(d => d.x)
            .filter((v, i, a) => a.indexOf(v) === i)
            .sort(function(a, b){return a - b});
        // 将长标题拆分为两行
        var labels = [
            ["Do you know anything about radon?"],
            ["Radon may be a problem,", "but I have not paid much attention to it"]
        ];
        cols_x.forEach((d, i) => {
            var text = d3.select(el)
                .select("svg")
                .append("text")
                .attr("x", d)
                .attr("y", 25)
                .style("font-family", "Arial")
                .style("font-size", "23");
            // 为每行添加tspan元素，实现换行
            text.selectAll("tspan")
                .data(labels[i])
                .enter()
                .append("tspan")
                .attr("x", d)
                .attr("dy", i === 0 ? 0 : "1.2em") // 第一行无需偏移，后续行设置行间距
                .text(function(line) { return line; });
        })
      }
    ')

改动说明 #

1. 将labels数组中的长标题拆分为字符串数组，指定换行位置。
2. 添加文本元素后，通过selectAll("tspan").data()绑定每行文本数据，生成对应的tspan子元素。
3. 设置tspan的x属性与父文本元素一致，保证每行对齐；通过dy属性设置行间距（这里用1.2em控制行高）。

这样修改后，右侧的长标题会在指定位置换行，完整显示在图表范围内。

内容的提问来源于stack exchange，提问作者Quan Truong Anh