在选项卡式部分调整sankey图

时间:2023-02-01 13:59:41

In the r-markdown document given below, I use tabbed sections to display sankey plots.

在下面给出的r-markdown文档中,我使用选项卡式部分来显示sankey图。

However, when a sankey plot is in a tab other than the first, adjusting (using htmlwidgets::onRender function) does not work. Does anybody know a way to overcome that problem?

但是,当sankey绘图位于第一个以外的选项卡中时,调整(使用htmlwidgets :: onRender函数)不起作用。有人知道克服这个问题的方法吗?

Related question: How to control node labels in Sankey diagram

相关问题:如何在Sankey图中控制节点标签

---
title: "Untitled"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)

library(networkD3)
library(htmlwidgets)

nodes <- data.frame('name' = 
c('Node0','Node1','Node2','Node3','Node4','Node5','Node6',                   
'Node7','Node8','Node9','Node10','Node11','Node12','Node13',
'Node14','Node15','Node16','Node17','Node18','Node19',
'Node20','Node21','Node22','Node23','Node24','Node25',
'Node26','Node27','Node28','Node29','Node30','Node31',
'Node32','Node33'))

links = as.data.frame(matrix(c(
  0, 3,140,
  0, 4,140,
  0, 5,140,
  0, 6,140,
  1, 3,140,
  1, 4,140,
  1, 5,140,
  1, 6,140,
  2, 3,140,
  2, 4,140,
  2, 5,140,
  2, 6,140,
  3, 7,130,
  3, 8,130,
  3, 9,50,
  3,10,50,
  3,11,50,
  4,12,140,
  4,13,100,
  4,14,100,
  4,15,80,
  5,16,150,
  5,17,150,
  5,18,60,
  5,19,60,
  6,20,180,
  6,21,80,
  6,22,80,
  6,23,80,
  7,24,13,
  7,33,13,
  7,31,104,
  8,24,13,
  8,33,13,
  8,26,52,
  8,27,52,
  9,24,10,
  9,33,10,
  9,29,30,
  9,30,30,
  10,24,10,
  10,33,10,
  10,29,30,
  10,30,30,
  11,24,10,
  11,33,10,
  11,29,30,
  11,30,30,
  12,24,16,
  12,33,16,
  12,26,36,
  12,27,36,
  12,28,36,
  13,24,10,
  13,33,10,
  13,26,30,
  13,27,30,
  13,28,30,
  14,24,10,
  14,33,10,
  14,26,30,
  14,27,30,
  14,28,30,
  15,24,10,
  15,33,10,
  15,31,60,
  16,24,30,
  16,33,30,
  16,32,90,
  17,24,30,
  17,33,30,
  17,32,90,
  18,24,10,
  18,33,10,
  18,25,40,
  19,24,30,
  19,33,30,
  20,24,90,
  20,33,90,
  21,33,80,
  22,24,10,
  22,33,10,
  22,29,30,
  22,30,30,
  23,24,40,
  23,33,40),
byrow = TRUE, ncol = 3))

names(links) = c("source", "target", "value")
```

## Sankey diagrams {.tabset .tabset-fade}

### Outturn


```{r }


sn <- sankeyNetwork(Links = links, Nodes = nodes,
                    Source = "source", Target = "target",
                    Value = "value", NodeID = "name",
                    fontSize= 15, nodeWidth = 20, margin = list(left = 100),
                    colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20b);"))

onRender(
  sn,
  '
  function(el, x) {
    d3.selectAll(".node text").attr("text-anchor", "begin").attr("x", 20);
  }
  '
)
```

### Actual

```{r }


sn <- sankeyNetwork(Links = links, Nodes = nodes,
                    Source = "source", Target = "target",
                    Value = "value", NodeID = "name",
                    fontSize= 15, nodeWidth = 20, margin = list(left = 100),
                    colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20b);"))

onRender(
  sn,
  '
  function(el, x) {
    d3.selectAll(".node text").attr("text-anchor", "begin").attr("x", 20);
  }
  '
)
```

2 个解决方案

#1


8  

If you add the following code to the end of your example, the appropriate text-anchors will be set whenever a tab is clicked/activated, which should solve your specific problem...

如果将以下代码添加到示例的末尾,则只要单击/激活选项卡,就会设置相应的文本锚点,这将解决您的特定问题...

```{js}
setTimeout(function () {
    $('.nav-tabs a').on('shown.bs.tab', function() { 
        d3.selectAll(".node text").attr("text-anchor", "begin").attr("x", 20);
      })
  }, 1)
```

You could also then remove all of your calls to onRender further up since they're no longer needed.

然后,您还可以进一步删除对onRender的所有调用,因为它们不再需要。

Here's a full example with a bit of reformatting to make it more concise...

这是一个完整的例子,有一些重新格式化,使其更简洁......

---
title: "Untitled"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)

library(networkD3)
library(htmlwidgets)

name <- c('Node0', 'Node1', 'Node2', 'Node3', 'Node4', 'Node5', 'Node6', 
          'Node7', 'Node8', 'Node9', 'Node10', 'Node11', 'Node12', 'Node13',
          'Node14', 'Node15', 'Node16', 'Node17', 'Node18', 'Node19', 'Node20',
          'Node21', 'Node22', 'Node23', 'Node24', 'Node25', 'Node26', 'Node27',
          'Node28', 'Node29', 'Node30', 'Node31', 'Node32', 'Node33')
nodes <- data.frame(name)

source <- c(0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5,
            5, 5, 6, 6, 6, 6, 7, 7, 7, 8, 8, 8, 8, 9, 9, 9, 9, 10, 10, 10, 10, 
            11, 11, 11, 11, 12, 12, 12, 12, 12, 13, 13, 13, 13, 13, 14, 14, 14, 
            14, 14, 15, 15, 15, 16, 16, 16, 17, 17, 17, 18, 18, 18, 19, 19, 20, 
            20, 21, 22, 22, 22, 22, 23, 23)
target <- c(3, 4, 5, 6, 3, 4, 5, 6, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
            16, 17, 18, 19, 20, 21, 22, 23, 24, 33, 31, 24, 33, 26, 27, 24, 33, 
            29, 30, 24, 33, 29, 30, 24, 33, 29, 30, 24, 33, 26, 27, 28, 24, 33, 
            26, 27, 28, 24, 33, 26, 27, 28, 24, 33, 31, 24, 33, 32, 24, 33, 32, 
            24, 33, 25, 24, 33, 24, 33, 33, 24, 33, 29, 30, 24, 33)
value <- c(140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 130, 130,
           50, 50, 50, 140, 100, 100, 80, 150, 150, 60, 60, 180, 80, 80, 80, 13,
           13, 104, 13, 13, 52, 52, 10, 10, 30, 30, 10, 10, 30, 30, 10, 10, 30,
           30, 16, 16, 36, 36, 36, 10, 10, 30, 30, 30, 10, 10, 30, 30, 30, 10, 
           10, 60, 30, 30, 90, 30, 30, 90, 10, 10, 40, 30, 30, 90, 90, 80, 10, 
           10, 30, 30, 40, 40)
links <- data.frame(source, target, value)
```

## Sankey diagrams {.tabset .tabset-fade}

### Outturn

```{r }
sn <- sankeyNetwork(Links = links, Nodes = nodes, Source = "source", 
                    Target = "target", Value = "value", NodeID = "name", 
                    fontSize = 15, nodeWidth = 20, margin = list(left = 100),
                    colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20b);"))

onRender(sn, jsCode = 
  'function(el, x) { 
      d3.selectAll(".node text").attr("text-anchor", "begin").attr("x", 20);
  }')
```

### Actual

```{r }
sankeyNetwork(Links = links, Nodes = nodes, Source = "source", 
              Target = "target", Value = "value", NodeID = "name", 
              fontSize = 15, nodeWidth = 20, margin = list(left = 100),
              colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20b);"))
```

```{js}
setTimeout(function () {
    $('.nav-tabs a').on('shown.bs.tab', function() { 
        d3.selectAll(".node text").attr("text-anchor", "begin").attr("x", 20);
      })
  }, 10)
```

#2


2  

This might help (largely inspired from here). The idea is to rewrite the HTML code of tabsets from scratch (using htmltools) and define the same class for each tab item: 'tab-pane active'. The drawback of this approach is that it makes both plots visible before clicking on a tab. To solve this issue, we can add a JS script as a workaround that waits 1 millisecond before automatically switching to a tab.

这可能有所帮助(很大程度上受到启发)。我们的想法是从头开始重写标签集的HTML代码(使用htmltools),并为每个标签项定义相同的类:'tab-pane active'。这种方法的缺点是它在点击标签之前使两个图都可见。要解决此问题,我们可以添加一个JS脚本作为一种解决方法,在自动切换到选项卡之前等待1毫秒。

---
title: "Untitled"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)

library(networkD3)
library(htmlwidgets)

nodes <- data.frame('name' = 
c('Node0','Node1','Node2','Node3','Node4','Node5','Node6',                   
'Node7','Node8','Node9','Node10','Node11','Node12','Node13',
'Node14','Node15','Node16','Node17','Node18','Node19',
'Node20','Node21','Node22','Node23','Node24','Node25',
'Node26','Node27','Node28','Node29','Node30','Node31',
'Node32','Node33'))

links = as.data.frame(matrix(c(
  0, 3,140,
  0, 4,140,
  0, 5,140,
  0, 6,140,
  1, 3,140,
  1, 4,140,
  1, 5,140,
  1, 6,140,
  2, 3,140,
  2, 4,140,
  2, 5,140,
  2, 6,140,
  3, 7,130,
  3, 8,130,
  3, 9,50,
  3,10,50,
  3,11,50,
  4,12,140,
  4,13,100,
  4,14,100,
  4,15,80,
  5,16,150,
  5,17,150,
  5,18,60,
  5,19,60,
  6,20,180,
  6,21,80,
  6,22,80,
  6,23,80,
  7,24,13,
  7,33,13,
  7,31,104,
  8,24,13,
  8,33,13,
  8,26,52,
  8,27,52,
  9,24,10,
  9,33,10,
  9,29,30,
  9,30,30,
  10,24,10,
  10,33,10,
  10,29,30,
  10,30,30,
  11,24,10,
  11,33,10,
  11,29,30,
  11,30,30,
  12,24,16,
  12,33,16,
  12,26,36,
  12,27,36,
  12,28,36,
  13,24,10,
  13,33,10,
  13,26,30,
  13,27,30,
  13,28,30,
  14,24,10,
  14,33,10,
  14,26,30,
  14,27,30,
  14,28,30,
  15,24,10,
  15,33,10,
  15,31,60,
  16,24,30,
  16,33,30,
  16,32,90,
  17,24,30,
  17,33,30,
  17,32,90,
  18,24,10,
  18,33,10,
  18,25,40,
  19,24,30,
  19,33,30,
  20,24,90,
  20,33,90,
  21,33,80,
  22,24,10,
  22,33,10,
  22,29,30,
  22,30,30,
  23,24,40,
  23,33,40),
byrow = TRUE, ncol = 3))

names(links) = c("source", "target", "value")
```

```{r echo=FALSE, message=FALSE, warning=FALSE}
library(htmltools)

sn1 <- sankeyNetwork(Links = links, Nodes = nodes,
                    Source = "source", Target = "target",
                    Value = "value", NodeID = "name",
                    fontSize= 15, nodeWidth = 20, margin = list(left = 100),
                    colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20b);"))

# Change font size of fig.2 to have visible change. 
sn2 <- sankeyNetwork(Links = links, Nodes = nodes,
                    Source = "source", Target = "target",
                    Value = "value", NodeID = "name",
                    fontSize= 20, nodeWidth = 20, margin = list(left = 100),
                    colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20b);"))

# make a named list of plots for demonstration
#  the names will be the titles of the tabs
plots <- list(
  "outturn" = sn1,
  "actual" = sn2
)

# create our top-level div for the tabs
tags$div(
  # create the tabs with titles as a ul with li/a
  tags$ul(
    class="nav nav-tabs",
    role="tablist",
    lapply(
      names(plots),
      function(p){
        tags$li(
          tags$a(
            "data-toggle"="tab",
            href=paste0("#tab-",p),
            p
          )
        )
      }
    )
  ),
  # fill the tabs with the plots
  tags$div(
    class="tab-content",
    lapply(
      names(plots),
      function(p){
         tags$div(
          #  here is the trick
          class=("tab-pane active"),
          #  id will need to match the id provided to the a href above
          id=paste0("tab-",p),
            onRender(plots[[p]],'
                    function(el, x) {
                    d3.selectAll(".node text").attr("text-anchor", "begin").attr("x", 20);
                    }')
        )
      }
    )
  )
) 
```

```{js}
setTimeout(function (){

$('.nav-tabs a[href="#tab-outturn"]').tab('show')

}, 1);
```

#1


8  

If you add the following code to the end of your example, the appropriate text-anchors will be set whenever a tab is clicked/activated, which should solve your specific problem...

如果将以下代码添加到示例的末尾,则只要单击/激活选项卡,就会设置相应的文本锚点,这将解决您的特定问题...

```{js}
setTimeout(function () {
    $('.nav-tabs a').on('shown.bs.tab', function() { 
        d3.selectAll(".node text").attr("text-anchor", "begin").attr("x", 20);
      })
  }, 1)
```

You could also then remove all of your calls to onRender further up since they're no longer needed.

然后,您还可以进一步删除对onRender的所有调用,因为它们不再需要。

Here's a full example with a bit of reformatting to make it more concise...

这是一个完整的例子,有一些重新格式化,使其更简洁......

---
title: "Untitled"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)

library(networkD3)
library(htmlwidgets)

name <- c('Node0', 'Node1', 'Node2', 'Node3', 'Node4', 'Node5', 'Node6', 
          'Node7', 'Node8', 'Node9', 'Node10', 'Node11', 'Node12', 'Node13',
          'Node14', 'Node15', 'Node16', 'Node17', 'Node18', 'Node19', 'Node20',
          'Node21', 'Node22', 'Node23', 'Node24', 'Node25', 'Node26', 'Node27',
          'Node28', 'Node29', 'Node30', 'Node31', 'Node32', 'Node33')
nodes <- data.frame(name)

source <- c(0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5,
            5, 5, 6, 6, 6, 6, 7, 7, 7, 8, 8, 8, 8, 9, 9, 9, 9, 10, 10, 10, 10, 
            11, 11, 11, 11, 12, 12, 12, 12, 12, 13, 13, 13, 13, 13, 14, 14, 14, 
            14, 14, 15, 15, 15, 16, 16, 16, 17, 17, 17, 18, 18, 18, 19, 19, 20, 
            20, 21, 22, 22, 22, 22, 23, 23)
target <- c(3, 4, 5, 6, 3, 4, 5, 6, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
            16, 17, 18, 19, 20, 21, 22, 23, 24, 33, 31, 24, 33, 26, 27, 24, 33, 
            29, 30, 24, 33, 29, 30, 24, 33, 29, 30, 24, 33, 26, 27, 28, 24, 33, 
            26, 27, 28, 24, 33, 26, 27, 28, 24, 33, 31, 24, 33, 32, 24, 33, 32, 
            24, 33, 25, 24, 33, 24, 33, 33, 24, 33, 29, 30, 24, 33)
value <- c(140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, 130, 130,
           50, 50, 50, 140, 100, 100, 80, 150, 150, 60, 60, 180, 80, 80, 80, 13,
           13, 104, 13, 13, 52, 52, 10, 10, 30, 30, 10, 10, 30, 30, 10, 10, 30,
           30, 16, 16, 36, 36, 36, 10, 10, 30, 30, 30, 10, 10, 30, 30, 30, 10, 
           10, 60, 30, 30, 90, 30, 30, 90, 10, 10, 40, 30, 30, 90, 90, 80, 10, 
           10, 30, 30, 40, 40)
links <- data.frame(source, target, value)
```

## Sankey diagrams {.tabset .tabset-fade}

### Outturn

```{r }
sn <- sankeyNetwork(Links = links, Nodes = nodes, Source = "source", 
                    Target = "target", Value = "value", NodeID = "name", 
                    fontSize = 15, nodeWidth = 20, margin = list(left = 100),
                    colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20b);"))

onRender(sn, jsCode = 
  'function(el, x) { 
      d3.selectAll(".node text").attr("text-anchor", "begin").attr("x", 20);
  }')
```

### Actual

```{r }
sankeyNetwork(Links = links, Nodes = nodes, Source = "source", 
              Target = "target", Value = "value", NodeID = "name", 
              fontSize = 15, nodeWidth = 20, margin = list(left = 100),
              colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20b);"))
```

```{js}
setTimeout(function () {
    $('.nav-tabs a').on('shown.bs.tab', function() { 
        d3.selectAll(".node text").attr("text-anchor", "begin").attr("x", 20);
      })
  }, 10)
```

#2


2  

This might help (largely inspired from here). The idea is to rewrite the HTML code of tabsets from scratch (using htmltools) and define the same class for each tab item: 'tab-pane active'. The drawback of this approach is that it makes both plots visible before clicking on a tab. To solve this issue, we can add a JS script as a workaround that waits 1 millisecond before automatically switching to a tab.

这可能有所帮助(很大程度上受到启发)。我们的想法是从头开始重写标签集的HTML代码(使用htmltools),并为每个标签项定义相同的类:'tab-pane active'。这种方法的缺点是它在点击标签之前使两个图都可见。要解决此问题,我们可以添加一个JS脚本作为一种解决方法,在自动切换到选项卡之前等待1毫秒。

---
title: "Untitled"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)

library(networkD3)
library(htmlwidgets)

nodes <- data.frame('name' = 
c('Node0','Node1','Node2','Node3','Node4','Node5','Node6',                   
'Node7','Node8','Node9','Node10','Node11','Node12','Node13',
'Node14','Node15','Node16','Node17','Node18','Node19',
'Node20','Node21','Node22','Node23','Node24','Node25',
'Node26','Node27','Node28','Node29','Node30','Node31',
'Node32','Node33'))

links = as.data.frame(matrix(c(
  0, 3,140,
  0, 4,140,
  0, 5,140,
  0, 6,140,
  1, 3,140,
  1, 4,140,
  1, 5,140,
  1, 6,140,
  2, 3,140,
  2, 4,140,
  2, 5,140,
  2, 6,140,
  3, 7,130,
  3, 8,130,
  3, 9,50,
  3,10,50,
  3,11,50,
  4,12,140,
  4,13,100,
  4,14,100,
  4,15,80,
  5,16,150,
  5,17,150,
  5,18,60,
  5,19,60,
  6,20,180,
  6,21,80,
  6,22,80,
  6,23,80,
  7,24,13,
  7,33,13,
  7,31,104,
  8,24,13,
  8,33,13,
  8,26,52,
  8,27,52,
  9,24,10,
  9,33,10,
  9,29,30,
  9,30,30,
  10,24,10,
  10,33,10,
  10,29,30,
  10,30,30,
  11,24,10,
  11,33,10,
  11,29,30,
  11,30,30,
  12,24,16,
  12,33,16,
  12,26,36,
  12,27,36,
  12,28,36,
  13,24,10,
  13,33,10,
  13,26,30,
  13,27,30,
  13,28,30,
  14,24,10,
  14,33,10,
  14,26,30,
  14,27,30,
  14,28,30,
  15,24,10,
  15,33,10,
  15,31,60,
  16,24,30,
  16,33,30,
  16,32,90,
  17,24,30,
  17,33,30,
  17,32,90,
  18,24,10,
  18,33,10,
  18,25,40,
  19,24,30,
  19,33,30,
  20,24,90,
  20,33,90,
  21,33,80,
  22,24,10,
  22,33,10,
  22,29,30,
  22,30,30,
  23,24,40,
  23,33,40),
byrow = TRUE, ncol = 3))

names(links) = c("source", "target", "value")
```

```{r echo=FALSE, message=FALSE, warning=FALSE}
library(htmltools)

sn1 <- sankeyNetwork(Links = links, Nodes = nodes,
                    Source = "source", Target = "target",
                    Value = "value", NodeID = "name",
                    fontSize= 15, nodeWidth = 20, margin = list(left = 100),
                    colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20b);"))

# Change font size of fig.2 to have visible change. 
sn2 <- sankeyNetwork(Links = links, Nodes = nodes,
                    Source = "source", Target = "target",
                    Value = "value", NodeID = "name",
                    fontSize= 20, nodeWidth = 20, margin = list(left = 100),
                    colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20b);"))

# make a named list of plots for demonstration
#  the names will be the titles of the tabs
plots <- list(
  "outturn" = sn1,
  "actual" = sn2
)

# create our top-level div for the tabs
tags$div(
  # create the tabs with titles as a ul with li/a
  tags$ul(
    class="nav nav-tabs",
    role="tablist",
    lapply(
      names(plots),
      function(p){
        tags$li(
          tags$a(
            "data-toggle"="tab",
            href=paste0("#tab-",p),
            p
          )
        )
      }
    )
  ),
  # fill the tabs with the plots
  tags$div(
    class="tab-content",
    lapply(
      names(plots),
      function(p){
         tags$div(
          #  here is the trick
          class=("tab-pane active"),
          #  id will need to match the id provided to the a href above
          id=paste0("tab-",p),
            onRender(plots[[p]],'
                    function(el, x) {
                    d3.selectAll(".node text").attr("text-anchor", "begin").attr("x", 20);
                    }')
        )
      }
    )
  )
) 
```

```{js}
setTimeout(function (){

$('.nav-tabs a[href="#tab-outturn"]').tab('show')

}, 1);
```