Мы создали диаграмму sankey, чтобы показать поток между различными городами через networkD3::sankeyNetwork()
в R. Мы получили требование клиента отображать "состояние", соответствующее городу, в подсказке/зависании узла sankey.
В следующем коде мы хотим показать значение состояния на подсказке (наведении) узла
library(shiny)
library(networkD3)
library(shinydashboard)
value <- c(12,21,41,12,81)
source <- c(4,1,5,2,1)
target <- c(0,0,1,3,3)
edges2 <- data.frame(cbind(value,source,target))
names(edges2) <- c("value","source","target")
indx <- c(0,1,2,3,4,5)
ID <- c('CITY1','CITY2','CITY3','CITY4','CITY5','CITY6')
State <- c( 'IL','CA','FL','NW','GL','TX')
nodes <-data.frame(cbind(ID,indx,State))
ui <- dashboardPage(
dashboardHeader(
),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidPage(
sankeyNetworkOutput("simple")
)
)
)
server <- function(input, output,session) {
output$simple <- renderSankeyNetwork({
sankeyNetwork(Links = edges2, Nodes = nodes,
Source = "source", Target = "target",
Value = "value", NodeID = "ID"
,units = " " )
})
}
shinyApp(ui = ui, server = server)
Поскольку пакет networkD3
не предоставляет настраиваемую всплывающую подсказку, предложите, как это можно сделать с помощью javascript или каким-либо другим способом в networkD3::sankeyNetwork()
.
Вы можете использовать технику, подобную этому ответу "Переполнение стека". Сохраните вывод функции sankeyNetwork
, затем добавьте обратно в данные, которые htmlwidgets::onRender
, затем используйте htmlwidgets::onRender
чтобы добавить JavaScript для изменения текста всплывающей подсказки узлов...
library(shiny)
library(networkD3)
library(shinydashboard)
value <- c(12,21,41,12,81)
source <- c(4,1,5,2,1)
target <- c(0,0,1,3,3)
edges2 <- data.frame(cbind(value,source,target))
names(edges2) <- c("value","source","target")
indx <- c(0,1,2,3,4,5)
ID <- c('CITY1','CITY2','CITY3','CITY4','CITY5','CITY6')
State <- c( 'IL','CA','FL','NW','GL','TX')
nodes <-data.frame(cbind(ID,indx,State))
ui <- dashboardPage(
dashboardHeader(
),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidPage(
sankeyNetworkOutput("simple")
)
)
)
server <- function(input, output,session) {
output$simple <- renderSankeyNetwork({
sn <- sankeyNetwork(Links = edges2, Nodes = nodes,
Source = "source", Target = "target",
Value = "value", NodeID = "ID"
,units = " " )
# add the states back into the nodes data because sankeyNetwork strips it out
sn$x$nodes$State <- nodes$State
# add onRender JavaScript to set the title to the value of 'State' for each node
sn <- htmlwidgets::onRender(
sn,
'
function(el, x) {
d3.selectAll(".node").select("title foreignObject body pre")
.text(function(d) { return d.State; });
}
'
)
# return the result
sn
})
}
shinyApp(ui = ui, server = server)