我正在嘗試制作一個閃亮的應用程式，其中使用 NetworkD3 生成的 Sankey 圖動態生成 x 節點標簽。我認為這需要將反應元素傳遞給onRender，但我不知道該怎么做。
我在這里看到了一個答案：如何在桑基圖 networkD3 中添加列標題，但這通過呼叫函式來解決動態命名.text("Step " (i 1));問題。onRender我的標簽不是那么通用，我只能迭代和粘貼（下面的示例使用簡化的名稱）。
這是一個例子：
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 標簽中（我很欣賞這是一個瘋狂的猜測），它就會失敗。var labels如果沒有反應函式，代碼只會根據所選變數的數量回圈。如果您選擇 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 節點？
uj5u.com熱心網友回復：
的jsCode引數htmlwidgets::onRender()只是一個恰好包含有效 JavaScript 代碼的字符向量，因此您可以像在 R 中的任何其他字串一樣構建/修改它。如果您想var labels = ["A", "B", "C"];動態設定 JavaScript 行的陣列值，您可以做這樣的事情......
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)
uj5u.com熱心網友回復：
下面發布的上述示例的完整作業代碼：
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)
轉載請註明出處，本文鏈接：https://www.uj5u.com/yidong/427191.html