动态命名 networkD3 sankey 的 x 节点
Dynamically name x-node of networkD3 sankey
我正在尝试生成一个闪亮的应用程序，其中使用 NetworkD3 生成的 Sankey 图动态生成 x 节点标签。我认为这需要将反应元素传递给 onRender，但我不确定该怎么做。
我在这里看到一个答案：，但这通过在onRender函数中调用.text("Step " + (i + 1));解决了动态命名问题。我的标签不是那么通用，我只能重复和粘贴（下面的示例使用简化的名称）。
这是一个例子：
library('shiny')
library('tidyverse')
library('networkD3')
library(shinyWidgets)
library(htmlwidgets)
#Create the data
df <- data.frame('A' = c('a', 'b', 'b', 'c', 'a'),
'B' = c('1', '1', '1', '2', '3'),
'C' = c('red', 'blue', 'blue', 'green', 'green'))
#Create the UI
ui <- fluidPage(
#Sidebar to select x-nodes
sidebarLayout(
sidebarPanel(
pickerInput(inputId = 'var_select',
label = 'Variables',
choices = colnames(df),
selected = colnames(df),
multiple = TRUE,
pickerOptions(actionsBox = TRUE))
),
#Mainpanel to show sankey plot
mainPanel(
sankeyNetworkOutput('plot',
height = '800px')
)
)
)
#Create the server
server <- function(input, session, output) {
#create a reactive function that outputs the selected variables
df_sankey <- reactive({
df %>%
select(input$var_select)
})
#Prepare for plotting in NetworkD3
links1 <- reactive({
df_sankey() %>%
mutate(row = row_number()) %>% # add a row id
pivot_longer(-row, names_to = "col", values_to = "source") %>% # gather all columns
mutate(col = match(col, names(df_sankey()))) %>% # convert col names to col ids
mutate(source = paste0(source, '_', col)) %>% # add col id to node names
group_by(row) %>%
mutate(target = lead(source, order_by = col)) %>% # get target from following node in row
ungroup() %>%
filter(!is.na(target)) %>% # remove links from last column in original data
group_by(source, target) %>%
summarise(value = n(), .groups = "drop") # aggregate and count similar links
})
#Now create the nodes
nodes <- reactive({
data.frame(id = unique(c(links1()$source, links1()$target)),
stringsAsFactors = F) %>%
mutate(name = sub('_[0-9]*$', '', id))
})
#Mutate a soutrce id variable - have to create this as links2 to prevent endless recursion
links2 <- reactive({
mutate(links1(), source_id = match(links1()$source, nodes()$id) - 1)
})
#Do the same for target id
links <- reactive({
mutate(links2(), target_id = match(links2()$target, nodes()$id) - 1) %>%
data.frame()
})
#Build the sankey plot
plot1 <- reactive({
sankeyNetwork(Links = links(), Nodes = nodes(),
Source = 'source_id', Target = 'target_id', Value = 'value', NodeID = 'name',
fontSize = 14)
})
#Here is the problematic code
#under code starting var labels - i need that to be produced by a reactive element: colnames(df_sankey())
#Without this it just take the number of var labels as there are selected variables
output$plot <- renderSankeyNetwork({
onRender(plot1(), '
function(el) {
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 = ["A", "B", "C"];
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}
')
})
}
#call the application
shinyApp(ui, server)
我在 onRender 函数上方的评论中指出了问题。实际上，我需要 var 标签来获取由类似 colnames(df_sankey()) 生成的反应函数。如果我将该代码放入 var 标签中（我很欣赏这是一个疯狂的猜测），它就会失败。如果没有反应函数，代码只是根据 selected 变量的数量循环遍历 var labels。如果你 select var A 和 C - C 被标记为 B，你就会看到问题。我也试过（另一个猜测）：
output$plot <- renderSankeyNetwork({
onRender(plot1(), '
function(el, node_labels) {
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 = [node_labels];
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}
', node_labels = colnames(df_sankey()))
但这也失败了。我似乎找不到如何将反应函数传递给 onRender.
的解释
如何将反应函数传递给 onRender 函数以便我可以动态命名我的 x 节点？
htmlwidgets::onRender() 的 jsCode 参数只是一个恰好包含有效 JavaScript 代码的字符向量，因此您可以 build/modify 就像您可以使用任何其他代码一样R 中的字符串。如果你想动态设置 JavaScript 的 var labels = ["A", "B", "C"]; 行的数组值，你可以这样做...
col_labels <- c("A", "B", "C")
col_lables_js_arrray_string <- paste0('["', paste(col_labels, collapse = '", "'), '"]')
render_js <- paste('
function(el) {
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 = ', col_lables_js_arrray_string, ';
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}
')
htmlwidgets::onRender(x = p, jsCode = render_js)
下面发布了上述示例的完整工作代码：
library('shiny')
library('tidyverse')
library('networkD3')
library('shinyWidgets')
library('htmlwidgets')
#Create the data
df <- data.frame('A' = c('a', 'b', 'b', 'c', 'a'),
'B' = c('1', '1', '1', '2', '3'),
'C' = c('red', 'blue', 'blue', 'green', 'green'))
#Create the UI
ui <- fluidPage(
#Sidebar to select x-nodes
sidebarLayout(
sidebarPanel(
pickerInput(inputId = 'var_select',
label = 'Variables',
choices = colnames(df),
selected = colnames(df),
multiple = TRUE,
pickerOptions(actionsBox = TRUE))
),
#Mainpanel to show sankey plot
mainPanel(
sankeyNetworkOutput('plot',
height = '800px')
)
)
)
#Create the server
server <- function(input, session, output) {
#create a reactive function that outputs the selected variables
df_sankey <- reactive({
df %>%
select(input$var_select)
})
#create a reactive function for the array that will populate the var labels
col_lables_js_arrray_string <- reactive({
paste0('["', paste(colnames(df_sankey()), collapse = '", "'), '"]')
})
#Prepare for plotting in NetworkD3
links1 <- reactive({
df_sankey() %>%
mutate(row = row_number()) %>% # add a row id
pivot_longer(-row, names_to = "col", values_to = "source") %>% # gather all columns
mutate(col = match(col, names(df_sankey()))) %>% # convert col names to col ids
mutate(source = paste0(source, '_', col)) %>% # add col id to node names
group_by(row) %>%
mutate(target = lead(source, order_by = col)) %>% # get target from following node in row
ungroup() %>%
filter(!is.na(target)) %>% # remove links from last column in original data
group_by(source, target) %>%
summarise(value = n(), .groups = "drop") # aggregate and count similar links
})
#Now create the nodes
nodes <- reactive({
data.frame(id = unique(c(links1()$source, links1()$target)),
stringsAsFactors = F) %>%
mutate(name = sub('_[0-9]*$', '', id))
})
#Mutate a soutrce id variable - have to create this as links2 to prevent endless recursion
links2 <- reactive({
mutate(links1(), source_id = match(links1()$source, nodes()$id) - 1)
})
#Do the same for target id
links <- reactive({
mutate(links2(), target_id = match(links2()$target, nodes()$id) - 1) %>%
data.frame()
})
#Build the sankey plot
plot1 <- reactive({
sankeyNetwork(Links = links(), Nodes = nodes(),
Source = 'source_id', Target = 'target_id', Value = 'value', NodeID = 'name',
fontSize = 14)
})
#paste the array for the var labels into the string that will run as valid js code
render_js <- reactive({
paste('function(el) {
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 = ',col_lables_js_arrray_string(),';
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}')
})
#render the sankey network, by calling the reactive js code string
output$plot <- renderSankeyNetwork({
onRender(plot1(), jsCode = render_js())
})
}
#call the application
shinyApp(ui, server)
我正在尝试生成一个闪亮的应用程序，其中使用 NetworkD3 生成的 Sankey 图动态生成 x 节点标签。我认为这需要将反应元素传递给 onRender，但我不确定该怎么做。
我在这里看到一个答案：onRender函数中调用.text("Step " + (i + 1));解决了动态命名问题。我的标签不是那么通用，我只能重复和粘贴（下面的示例使用简化的名称）。
这是一个例子：
library('shiny')
library('tidyverse')
library('networkD3')
library(shinyWidgets)
library(htmlwidgets)
#Create the data
df <- data.frame('A' = c('a', 'b', 'b', 'c', 'a'),
'B' = c('1', '1', '1', '2', '3'),
'C' = c('red', 'blue', 'blue', 'green', 'green'))
#Create the UI
ui <- fluidPage(
#Sidebar to select x-nodes
sidebarLayout(
sidebarPanel(
pickerInput(inputId = 'var_select',
label = 'Variables',
choices = colnames(df),
selected = colnames(df),
multiple = TRUE,
pickerOptions(actionsBox = TRUE))
),
#Mainpanel to show sankey plot
mainPanel(
sankeyNetworkOutput('plot',
height = '800px')
)
)
)
#Create the server
server <- function(input, session, output) {
#create a reactive function that outputs the selected variables
df_sankey <- reactive({
df %>%
select(input$var_select)
})
#Prepare for plotting in NetworkD3
links1 <- reactive({
df_sankey() %>%
mutate(row = row_number()) %>% # add a row id
pivot_longer(-row, names_to = "col", values_to = "source") %>% # gather all columns
mutate(col = match(col, names(df_sankey()))) %>% # convert col names to col ids
mutate(source = paste0(source, '_', col)) %>% # add col id to node names
group_by(row) %>%
mutate(target = lead(source, order_by = col)) %>% # get target from following node in row
ungroup() %>%
filter(!is.na(target)) %>% # remove links from last column in original data
group_by(source, target) %>%
summarise(value = n(), .groups = "drop") # aggregate and count similar links
})
#Now create the nodes
nodes <- reactive({
data.frame(id = unique(c(links1()$source, links1()$target)),
stringsAsFactors = F) %>%
mutate(name = sub('_[0-9]*$', '', id))
})
#Mutate a soutrce id variable - have to create this as links2 to prevent endless recursion
links2 <- reactive({
mutate(links1(), source_id = match(links1()$source, nodes()$id) - 1)
})
#Do the same for target id
links <- reactive({
mutate(links2(), target_id = match(links2()$target, nodes()$id) - 1) %>%
data.frame()
})
#Build the sankey plot
plot1 <- reactive({
sankeyNetwork(Links = links(), Nodes = nodes(),
Source = 'source_id', Target = 'target_id', Value = 'value', NodeID = 'name',
fontSize = 14)
})
#Here is the problematic code
#under code starting var labels - i need that to be produced by a reactive element: colnames(df_sankey())
#Without this it just take the number of var labels as there are selected variables
output$plot <- renderSankeyNetwork({
onRender(plot1(), '
function(el) {
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 = ["A", "B", "C"];
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}
')
})
}
#call the application
shinyApp(ui, server)
我在 onRender 函数上方的评论中指出了问题。实际上，我需要 var 标签来获取由类似 colnames(df_sankey()) 生成的反应函数。如果我将该代码放入 var 标签中（我很欣赏这是一个疯狂的猜测），它就会失败。如果没有反应函数，代码只是根据 selected 变量的数量循环遍历 var labels。如果你 select var A 和 C - C 被标记为 B，你就会看到问题。我也试过（另一个猜测）：
output$plot <- renderSankeyNetwork({
onRender(plot1(), '
function(el, node_labels) {
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 = [node_labels];
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}
', node_labels = colnames(df_sankey()))
但这也失败了。我似乎找不到如何将反应函数传递给 onRender.
如何将反应函数传递给 onRender 函数以便我可以动态命名我的 x 节点？
htmlwidgets::onRender() 的 jsCode 参数只是一个恰好包含有效 JavaScript 代码的字符向量，因此您可以 build/modify 就像您可以使用任何其他代码一样R 中的字符串。如果你想动态设置 JavaScript 的 var labels = ["A", "B", "C"]; 行的数组值，你可以这样做...
col_labels <- c("A", "B", "C")
col_lables_js_arrray_string <- paste0('["', paste(col_labels, collapse = '", "'), '"]')
render_js <- paste('
function(el) {
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 = ', col_lables_js_arrray_string, ';
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}
')
htmlwidgets::onRender(x = p, jsCode = render_js)
下面发布了上述示例的完整工作代码：
library('shiny')
library('tidyverse')
library('networkD3')
library('shinyWidgets')
library('htmlwidgets')
#Create the data
df <- data.frame('A' = c('a', 'b', 'b', 'c', 'a'),
'B' = c('1', '1', '1', '2', '3'),
'C' = c('red', 'blue', 'blue', 'green', 'green'))
#Create the UI
ui <- fluidPage(
#Sidebar to select x-nodes
sidebarLayout(
sidebarPanel(
pickerInput(inputId = 'var_select',
label = 'Variables',
choices = colnames(df),
selected = colnames(df),
multiple = TRUE,
pickerOptions(actionsBox = TRUE))
),
#Mainpanel to show sankey plot
mainPanel(
sankeyNetworkOutput('plot',
height = '800px')
)
)
)
#Create the server
server <- function(input, session, output) {
#create a reactive function that outputs the selected variables
df_sankey <- reactive({
df %>%
select(input$var_select)
})
#create a reactive function for the array that will populate the var labels
col_lables_js_arrray_string <- reactive({
paste0('["', paste(colnames(df_sankey()), collapse = '", "'), '"]')
})
#Prepare for plotting in NetworkD3
links1 <- reactive({
df_sankey() %>%
mutate(row = row_number()) %>% # add a row id
pivot_longer(-row, names_to = "col", values_to = "source") %>% # gather all columns
mutate(col = match(col, names(df_sankey()))) %>% # convert col names to col ids
mutate(source = paste0(source, '_', col)) %>% # add col id to node names
group_by(row) %>%
mutate(target = lead(source, order_by = col)) %>% # get target from following node in row
ungroup() %>%
filter(!is.na(target)) %>% # remove links from last column in original data
group_by(source, target) %>%
summarise(value = n(), .groups = "drop") # aggregate and count similar links
})
#Now create the nodes
nodes <- reactive({
data.frame(id = unique(c(links1()$source, links1()$target)),
stringsAsFactors = F) %>%
mutate(name = sub('_[0-9]*$', '', id))
})
#Mutate a soutrce id variable - have to create this as links2 to prevent endless recursion
links2 <- reactive({
mutate(links1(), source_id = match(links1()$source, nodes()$id) - 1)
})
#Do the same for target id
links <- reactive({
mutate(links2(), target_id = match(links2()$target, nodes()$id) - 1) %>%
data.frame()
})
#Build the sankey plot
plot1 <- reactive({
sankeyNetwork(Links = links(), Nodes = nodes(),
Source = 'source_id', Target = 'target_id', Value = 'value', NodeID = 'name',
fontSize = 14)
})
#paste the array for the var labels into the string that will run as valid js code
render_js <- reactive({
paste('function(el) {
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 = ',col_lables_js_arrray_string(),';
cols_x.forEach((d, i) => {
d3.select(el).select("svg")
.append("text")
.attr("x", d)
.attr("y", 12)
.text(labels[i]);
})
}')
})
#render the sankey network, by calling the reactive js code string
output$plot <- renderSankeyNetwork({
onRender(plot1(), jsCode = render_js())
})
}
#call the application
shinyApp(ui, server)