R netWorkD3 Sankey - 通过 js 添加百分比不起作用

Question

我正在使用 networkD3::sankeyNetwork() 使用以下示例数据和脚本在 R 中创建桑基图。我想显示节点标签之外的百分比。

我创建的具有完整数据集的 sankey 有 8 层。我只是在下面的代码中发布了一段数据。

library("networkD3")
library("htmlwidgets")
library("dplyr")

a <- read.csv(header = TRUE, text = "
date,dataCenter,customer,companyID,source,target,value

")

node_names <- unique(c(as.character(a$source), as.character(a$target)))
nodes <- data.frame(name = node_names)
links <- data.frame(source = match(a$source, node_names) - 1,
                    target = match(a$target, node_names) - 1,
                    value = a$value)

# group by source and calculate the percentage of each node
g <- a %>%
  group_by(source) %>%
  summarize(cnt = n()) %>%
  mutate(freq = round(cnt / sum(cnt) * 100, 2)) %>%
  arrange(desc(freq))


nodes$name <- sub('(.*)_\\d+', '\\1', nodes$name)
links$linkgroup <- "linkgrp"
colourScale <- 
  'd3.scaleOrdinal()
     .domain(["linkgrp"])
     .range(["gainsboro"].concat(d3.schemeCategory20))'

p <- sankeyNetwork(Links = links, Nodes = nodes, Source = "source",
              Target = "target", Value = "value", NodeID = "name",
              fontSize = 9,
              fontFamily = "sans-serif", nodePadding=10,
              margin = list(t=100),
              sinksRight = FALSE, iterations = 0,
              LinkGroup = "linkgroup", 
              colourScale = colourScale)

showLabel_string <- 
  'function(el, x){
    d3.select(el).selectAll(".node text")
      .text(d => d.name + " (" + d.value + ")");}'

addTitle_string <-
  'function(el) { 
    var cols_x = this.sankey.nodes().map(d => d.x+15).filter((v, i, a) => a.indexOf(v) === i).sort(function(a, b){return a - b});
    cols_x.forEach((d, i) => {
    d3.select(el)
    .select("svg")
    .append("text")
    .attr("x", d)
    .attr("y", 0).text("step" + (i + 1))
    .style("font-size", "12px")
    .style("font-family", "sans-serif")
    .style("text-orientation", "upright");})
  }'

p <- htmlwidgets::onRender(x = p, jsCode = showLabel_string)
p <- htmlwidgets::onRender(x = p, jsCode = addTitle_string)
p <- htmlwidgets::prependContent(p, htmltools::tags$h3("Opportunity Marketing User Behavior Monitor"))
p

现在我想显示每个节点标签和计数之外的百分比。我已经通过下面的脚本计算了百分比值，但是如何将其放在节点标签和计数之后？

我意识到下面计算每个节点百分比的方法是不正确的，因为当按“源”列分组时，最后一层中的节点会被遗漏，因为它们仅用作“目标”节点。我在帖子中用新图片更新了预期结果，该图片更清楚地显示了百分比的显示方式。一般来说，该百分比应遵循能量守恒定律。有可能实现吗？

g <- a %>%
  group_by(source) %>%
  summarize(cnt = n()) %>%
  mutate(freq = round(cnt / sum(cnt) * 100, 2)) %>%
  arrange(desc(freq))

预期结果是

Answer 1

您可以在创建 htmlwidget 之后将变量添加到 nodes data.frame（否则，sankeyNetwork() 将仅保留所需的列）。然后，您可以编辑节点标签文本的自定义代码以包含百分比...

p$x$nodes <- g %>% 
  mutate(name = sub("_[0-9]", "", source)) %>% 
  select(name, freq) %>% 
  right_join(p$x$nodes, by = "name") %>% 
  mutate(freq = ifelse(is.na(freq), "", paste0(freq, "%")))

showLabel_string <- 
  'function(el, x){
    d3.select(el).selectAll(".node text")
      .text(d => d.name + " (" + d.value + ") " + d.freq);}'