Printing a sankey diagram in Shiny - r

I created a sankey diagram like this:
#install.packages("networkD3")
library(networkD3)
nodes = data.frame("name" =
c("Retour", # Node 0
"niet tevreden/ontevreden", # Node 1
"fout", # Node 2
"stuk",
"adres",
"verpakking",
"gebroken/glas"))# Node 3
links = as.data.frame(matrix(c(
0, 1, 10, # Each row represents a link. The first number
0, 2, 20, # represents the node being conntected from.
0, 3, 30,
2, 4, 8,
3, 5, 10,
3, 6, 12# the second number represents the node connected to.
),# The third number is the value of the node
byrow = TRUE, ncol = 3))
names(links) = c("source", "target", "value")
sankeyNetwork(Links = links, Nodes = nodes,
Source = "source", Target = "target",
Value = "value", NodeID = "name",
fontSize= 12, nodeWidth = 30)
Working fine, however now I would like to use this plot into shiny. Therefore the did the following:
## app.R ##
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(plotOutput("plot1", height = 250))
)
)
)
library(networkD3)
server <- function(input, output) {
histdata <- rnorm(500)
nodes = data.frame("name" =
c("Retour", # Node 0
"niet tevreden/ontevreden", # Node 1
"fout", # Node 2
"stuk",
"adres",
"verpakking",
"gebroken/glas"))# Node 3
links = as.data.frame(matrix(c(
0, 1, 10, # Each row represents a link. The first number
0, 2, 20, # represents the node being conntected from.
0, 3, 30,
2, 4, 8,
3, 5, 10,
3, 6, 12# the second number represents the node connected to.
),# The third number is the value of the node
byrow = TRUE, ncol = 3))
names(links) = c("source", "target", "value")
output$plot1 <- renderPlot({
sankeyNetwork(Links = links, Nodes = nodes,
Source = "source", Target = "target",
Value = "value", NodeID = "name",
fontSize= 12, nodeWidth = 30)
})
output$plot2 <- renderPlot({
data <- histdata[seq_len(10)]
hist(data)
})
}
shinyApp(ui, server)
Thing is that Shiny for some reason can read the sankey diagram. If I change the code:
box(plotOutput("plot1", height = 250))
To:
box(plotOutput("plot2", height = 250))
It is plotting the histogram. So there seems to be something wrong with the sankey diagram. Any thoughts on what is causing this?

You should use the renderSankeyNetwork and sankeyNetworkOutput functions in networkD3 instead of plotOutput and renderPlot. So with your data already loaded, it would look like...
library(shiny)
library(shinydashboard)
library(networkD3)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
sankeyNetworkOutput("plot")
)
)
)
server <- function(input, output) {
output$plot <- renderSankeyNetwork({
sankeyNetwork(Links = links, Nodes = nodes,
Source = "source", Target = "target",
Value = "value", NodeID = "name",
fontSize= 12, nodeWidth = 30)
})
}
shinyApp(ui, server)
Also see the example here

Related

How can I interactively filter nodes/edges from a visNetwork using checkboxes? (using R Shiny)

Using the Shiny and visNetwork R packages I have created an interactive network visualisation. I would like to enable users to remove/add nodes and edges by using checkboxes in the UI. I managed to get this working partially, but somehow my solution does not work when multiple items are filtered.
An example of the behaviour I am trying to achieve can be viewed here.
Please find my code below.
library(visNetwork)
library(shiny)
library(dplyr)
nodes <- data.frame("id" = 1:6)
edges <- data.frame("id" = 1:4, "to" = c(1,2,4,5), "from" = c(2,3,5,6))
ui <- fluidPage(title = "example",
fillPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput(inputId = "filterNodes",
label = "Select nodes:",
choices = nodes$id,
selected = nodes$id),
width = 3),
mainPanel(
visNetworkOutput("network_proxy_update",width = "100%", height = "90vh"),
width = 9)
)
)
)
server <- function(input, output) {
output$network_proxy_update <- renderVisNetwork({
visNetwork(nodes, edges) %>% visNodes (color = "blue")
})
observe ({
filteredNodes <- data.frame("id" = nodes[nodes$id %in% input$filterNodes, "id"])
hiddenNodes <- anti_join(nodes, filteredNodes)
visNetworkProxy("network_proxy_update") %>%
visRemoveNodes(id = hiddenNodes) %>%
visUpdateNodes(nodes = filteredNodes)
})
}
shinyApp(ui = ui, server = server)
Any help would be greatly appreciated.
Best regards,
Tim
visRemoveNodes expects a vector of id's while visUpdateNodes needs a data.frame of nodes:
library(visNetwork)
library(shiny)
library(dplyr)
nodes <- data.frame("id" = 1:6)
edges <- data.frame(
"id" = 1:4,
"to" = c(1, 2, 4, 5),
"from" = c(2, 3, 5, 6)
)
ui <- fluidPage(title = "example",
fillPage(sidebarLayout(
sidebarPanel(
checkboxGroupInput(
inputId = "filterNodes",
label = "Select nodes:",
choices = nodes$id,
selected = nodes$id
),
width = 3
),
mainPanel(
visNetworkOutput("network_proxy_update", width = "100%", height = "90vh"),
width = 9
)
)))
server <- function(input, output) {
output$network_proxy_update <- renderVisNetwork({
visNetwork(nodes, edges) %>% visNodes (color = "blue")
})
myVisNetworkProxy <- visNetworkProxy("network_proxy_update")
observe ({
filteredNodes <- nodes[nodes$id %in% input$filterNodes, , drop = FALSE]
hiddenNodes <- anti_join(nodes, filteredNodes)
visRemoveNodes(myVisNetworkProxy, id = hiddenNodes$id)
visUpdateNodes(myVisNetworkProxy, nodes = filteredNodes)
})
}
shinyApp(ui = ui, server = server)

Only certain plot points responding to row selection in shiny app?

I am attempting to adapt an example (2.1.1) from the tutorial found here on interactive plots in shiny. I have a shiny app as follows:
Data:
seats = data.table(
ID = c("1","2","3","4","5","6"),
Row = c("A", "A", "A", "B", "B", "B"),
SeatNum = c(1,2,3,1,2,3),
y = c(1,1,1,2,2,2),
price = 45)
ui.R
fluidPage(
title = 'Select Table Rows',
h1('A Client-side Table'),
fluidRow(
column(6, DT::dataTableOutput('x1')),
column(6, plotOutput('x2', height = 500)),
column(3, verbatimTextOutput('x4')),
column(4, verbatimTextOutput('x5'))
),
hr(),
)
server.R
shinyServer(function(input, output, session) {
output$x1 = DT::renderDataTable(seats, editable = "row", server = FALSE)
# highlight selected rows in the scatterplot
output$x2 = renderPlot({
s = input$x1_rows_selected
par(mar = c(4, 4, 1, 1))
plot(seats$SeatNum, seats$y)
if (length(s)) points(seats[s, , drop = FALSE], pch = 19, cex = 2)
})
output$x4 = renderPrint({
s = input$x1_rows_selected
if (length(s)) {
cat('Combined price \n of all seats:\n\n')
cat(sum(seats[s,]$price))
}
})
output$x5 = renderPrint({
s2 = input$x1_rows_selected
if (length(s2)) {
cat('Total number of seats selected:\n\n')
cat(length(s2))
}
})
})
Upon launching the app I can select any of the first three rows and the plot reacts appropriately. However, from row 4 onwards the plot does not respond. I've played around with the if (length(s)) points(seats[s, , drop = FALSE], pch = 19, cex = 2) line but I don't understand its behavior.
The table used in the linked example has two columns only, so for the points function its unambiguous what values go to x and y. But your table has multiple columns, so the indexing seats[s, , drop=FALSE] returns the selected rows and all columns:
> seats[1:2, , drop=FALSE]
ID Row SeatNum y price
1: 1 A 1 1 45
2: 2 A 2 1 45
So, when indexing this way, points does not know what to map to x and y. You need to index the selected rows and the columns needed for points (in the correct order) to highlight points on the plot:
> seats[1:2, c("SeatNum", "y"), drop=FALSE]
SeatNum y
1: 1 1
2: 2 1
Working app:
library(shiny)
library(data.table)
library(DT)
seats = data.table(
ID = c("1", "2", "3", "4", "5", "6"),
Row = c("A", "A", "A", "B", "B", "B"),
SeatNum = c(1, 2, 3, 1, 2, 3),
y = c(1, 1, 1, 2, 2, 2),
price = 45
)
ui <-
fluidPage(title = 'Select Table Rows',
h1('A Client-side Table'),
fluidRow(
column(6, DT::dataTableOutput('x1')),
column(6, plotOutput('x2', height = 500)),
column(3, verbatimTextOutput('x4')),
column(4, verbatimTextOutput('x5'))
),
hr())
server <- function(input, output, session) {
output$x1 = DT::renderDataTable(seats, editable = "row", server = FALSE)
# highlight selected rows in the scatterplot
output$x2 = renderPlot({
s = input$x1_rows_selected
par(mar = c(4, 4, 1, 1))
plot(seats$SeatNum, seats$y)
if (length(s))
points(seats[s, c("SeatNum", "y") , drop = FALSE], pch = 19, cex = 2)
})
output$x4 = renderPrint({
s = input$x1_rows_selected
if (length(s)) {
cat('Combined price \n of all seats:\n\n')
cat(sum(seats[s, ]$price))
}
})
output$x5 = renderPrint({
s2 = input$x1_rows_selected
if (length(s2)) {
cat('Total number of seats selected:\n\n')
cat(length(s2))
}
})
}
shinyApp(ui, server)

How to manually input nodes id to select/highlight nodes in visNetwork

I am building a network using visNetwork package in Shiny app.
In visNetwork package, there is a nodesIdSelection argument in visOption function to select/highlight the nodes.
However, we can only select nodes from the drop down menu, instead of manually input nodes id to select in this function. It is hard to find node id if there is a lot of nodes ids in the drop down menu.
I am wondering if there is a way to achieve this function. If it is not possible in visNetwork, I am thinking to implement possible functions in Shiny to solve it.
Below is my current code of visNetwork.
# data used in next examples
nb <- 10
nodes <- data.frame(id = 1:nb, label = paste("Label", 1:nb),
group = sample(LETTERS[1:3], nb, replace = TRUE), value = 1:nb,
title = paste0("<p>", 1:nb,"<br>Tooltip !</p>"), stringsAsFactors = FALSE)
edges <- data.frame(from = c(8,2,7,6,1,8,9,4,6,2),
to = c(3,7,2,7,9,1,5,3,2,9),
value = rnorm(nb, 10), label = paste("Edge", 1:nb),
title = paste0("<p>", 1:nb,"<br>Edge Tooltip !</p>"))
visNetwork(nodes, edges, height = "500px", width = "100%") %>%
visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE) %>%
visLayout(randomSeed = 123)
Thanks in advance.
You can use Shiny with visSelectNodes and set highlightNearest in options to achieved the same result. With this you can customize the input in shiny widget catalog as you preferred.
library(shiny)
library(visNetwork)
server <- function(input, output) {
output$network_proxy_nodes <- renderVisNetwork({
# minimal example
nodes <- data.frame(id = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3))
visNetwork(nodes, edges) %>%
visOptions(highlightNearest = TRUE)
})
observe({
visNetworkProxy("network_proxy_nodes") %>%
visSelectNodes(id = input$Focus, highlightEdges = T)
})
}
ui <- fluidPage(
fluidRow(
column(
width = 4,
selectInput("Focus", "Focus on node :",
c(1:3))
),
column(
width = 8,
visNetworkOutput("network_proxy_nodes", height = "400px")
)
)
)
shinyApp(ui = ui, server = server)

Tiny plot output from sankeyNetwork (NetworkD3) in Firefox

As per object, I get a very small plot in Firefox when using sankeyNetwork() from networkd3 in shiny but not in Chrome or RStudio.
I have not included any CSS or JS in the script - the code below produces this result for me.
Is there any CSS property I have missed?
I am using R 3.4.1, shiny 1.1.0, networkD3 0.4 and Firefox 52.9.0.
Firefox:
Chrome:
library(shiny)
library(magrittr)
library(shinydashboard)
library(networkD3)
labels = as.character(1:9)
ui <- tagList(
dashboardPage(
dashboardHeader(
title = "appName"
),
##### dasboardSidebar #####
dashboardSidebar(
sidebarMenu(
id = "sidebar",
menuItem("plots",
tabName = "sPlots")
)
),
##### dashboardBody #####
dashboardBody(
tabItems(
##### tab #####
tabItem(
tabName = "sPlots",
tabsetPanel(
tabPanel(
"Sankey plot",
fluidRow(
box(title = "title",
solidHeader = TRUE, collapsible = TRUE, status = "primary",
sankeyNetworkOutput("sankeyHSM1")
)
)
)
)
)
)
)
)
)
server <- function(input, output, session) {
HSM = matrix(rep(c(10000, 700, 10000-700, 200, 500, 50, 20, 10, 2,40,10,10,10,10),4),ncol = 4)
sankeyHSMNetworkFun = function(x,ndx) {
nodes = data.frame("name" = factor(labels, levels = labels),
"group" = as.character(c(1,2,2,3,3,4,4,4,4)))
links = as.data.frame(matrix(byrow=T,ncol=3,c(
0, 1, NA,
0, 2, NA,
1, 3, NA,
1, 4, NA,
3, 5, NA,
3, 6, NA,
3, 7, NA,
3, 8, NA
)))
links[,3] = HSM[2:(nrow(links)+1),] %>% {rowSums(.[,(ndx-1)*2+c(1,2)])}
names(links) = c("source","target","value")
sankeyNetwork(Links = links, Nodes = nodes, Source = "source", Target = "target", Value = "value", NodeID = "name",NodeGroup = "group",
fontSize=12,sinksRight = FALSE)
}
output$sankeyHSM1 = renderSankeyNetwork({
sankeyHSMNetworkFun(values$HSM,1)
})
}
# Run the application
shinyApp(ui = ui, server = server)
------------------ EDIT --------------------
Thanks to #CJYetman for indicating onRender() as a possible solution - however this fails when there are two plots generated side by side as in the MRE below (note in addition to the second sankey plot I have also added javascript code to re-draw the figures when the window size changes as the plot does not appear to do it automatically).
library(shiny)
library(magrittr)
library(shinydashboard)
library(networkD3)
library(htmlwidgets)
labels = as.character(1:9)
ui <- tagList(
tags$head(
tags$script('
var dimension = [0, 0];
$(document).on("shiny:connected", function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange("dimension", dimension);
});
$(window).resize(function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange("dimension", dimension);
});
')
),
dashboardPage(
dashboardHeader(
title = "appName"
),
##### dasboardSidebar #####
dashboardSidebar(
sidebarMenu(
id = "sidebar",
menuItem("plots",
tabName = "sPlots")
)
),
##### dashboardBody #####
dashboardBody(
tabItems(
##### tab #####
tabItem(
tabName = "sPlots",
tabsetPanel(
tabPanel(
"Sankey plot",
fluidRow(
box(title = "title",
solidHeader = TRUE, collapsible = TRUE, status = "primary",
sankeyNetworkOutput("sankeyHSM1")
),
box(title = "plot2",
solidHeader = TRUE, collapsible = TRUE, status = "primary",
sankeyNetworkOutput("sankeyHSM2"))
)
)
)
)
)
)
)
)
server <- function(input, output, session) {
HSM = matrix(rep(c(10000, 700, 10000-700, 200, 500, 50, 20, 10, 2,40,10,10,10,10),4),ncol = 4)
sankeyHSMNetworkFun = function(x,ndx) {
nodes = data.frame("name" = factor(labels, levels = labels),
"group" = as.character(c(1,2,2,3,3,4,4,4,4)))
links = as.data.frame(matrix(byrow=T,ncol=3,c(
0, 1, NA,
0, 2, NA,
1, 3, NA,
1, 4, NA,
3, 5, NA,
3, 6, NA,
3, 7, NA,
3, 8, NA
)))
links[,3] = HSM[2:(nrow(links)+1),] %>% {rowSums(.[,(ndx-1)*2+c(1,2)])}
names(links) = c("source","target","value")
sankeyNetwork(Links = links, Nodes = nodes, Source = "source", Target = "target", Value = "value", NodeID = "name",NodeGroup = "group",
fontSize=12,sinksRight = FALSE)
}
output$sankeyHSM1 = renderSankeyNetwork({
req(input$dimension)
sankeyHSMNetworkFun(values$HSM,1) %>%
onRender('document.getElementsByTagName("svg")[0].setAttribute("viewBox", "")')
})
output$sankeyHSM2 = renderSankeyNetwork({
req(input$dimension)
sankeyHSMNetworkFun(values$HSM,2) %>%
onRender('document.getElementsByTagName("svg")[0].setAttribute("viewBox", "")')
})
}
# Run the application
shinyApp(ui = ui, server = server)
------------------ EDIT2 --------------------
Second problem above solved - either by referring to the second svg item on the page as per #CJYetman's comment below using document.getElementsByTagName("svg")[1].setAttribute("viewBox",""), or by going into the objects themselves selecting their first svg element with document.getElementById("sankeyHSM2").getElementsByTagName("svg")[0].setAttribute("viewBox","").
This seems to be the result of Firefox reacting to the viewbox svg property differently than other browsers. It might be worthwhile to submit this as an issue here https://github.com/christophergandrud/networkD3/issues
In the meantime, you could work around this by resetting the viewbox attribute using some JavaScript and htmlwidgets::onRender(). Here's an example using a minimized version of your example. (Resetting the viewbox attribute may have other consequences)
library(htmlwidgets)
library(networkD3)
library(magrittr)
nodes = data.frame("name" = factor(as.character(1:9)),
"group" = as.character(c(1,2,2,3,3,4,4,4,4)))
links = as.data.frame(matrix(byrow = T, ncol = 3, c(
0, 1, 1400,
0, 2, 18600,
1, 3, 400,
1, 4, 1000,
3, 5, 100,
3, 6, 40,
3, 7, 20,
3, 8, 4
)))
names(links) = c("source","target","value")
sn <- sankeyNetwork(Links = links, Nodes = nodes, Source = "source",
Target = "target", Value = "value", NodeID = "name",
NodeGroup = "group", fontSize = 12, sinksRight = FALSE)
htmlwidgets::onRender(sn, 'document.getElementsByTagName("svg")[0].setAttribute("viewBox", "")')
UPDATE (2019.10.26)
This is probably a safer implementation of removing the viewBox...
htmlwidgets::onRender(sn, 'function(el) { el.getElementsByTagName("svg")[0].removeAttribute("viewBox") }')
UPDATE 2020.04.02
My currently preferred method to do this is to use htmlwidgets::onRender to target specifically the SVG contained by the passed htmlwidget, like this...
onRender(sn, 'function(el) { el.querySelector("svg").removeAttribute("viewBox") }')
That can then be done specifically to as many htmlwidgets on your page as necessary, for instance...
onRender(sn, 'function(el) { el.querySelector("svg").removeAttribute("viewBox") }')
onRender(sn2, 'function(el) { el.querySelector("svg").removeAttribute("viewBox") }')

Updating multiple infobox using plotly_click in R and plotly

If you please run the script, it gives you a basic Sankey Chart in R and plotly and a data table besides. Also, there are three infoBoxes on top. When I click on the Sankey lines in the plot, I see the value in the data table using plotly_click. I want a functionality when I click on any Sankey Line, it picks "pointNumber" Column value in the data table and then multiplies by 2 and put in first infobox, by 3 in second infobox, and multiply by 4 in third infobox as in the snap attached. Thanks and please help.
## app.R ##
library(shiny)
library(shinydashboard)
library(devtools)
library(ggplot2)
library(plotly)
library(proto)
library(RColorBrewer)
library(gapminder)
library(stringr)
library(broom)
library(mnormt)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Multiple hover"),
dashboardSidebar(
width = 0
),
dashboardBody(
infoBox("Multiply by 2", 2 * 2, icon = icon("credit-card")),
infoBox("Multiply by 3", 2 * 3, icon = icon("credit-card")),
infoBox("Multiply by 4", 2 * 4, icon = icon("credit-card")),
tags$br(),
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("sankey_table"))
)
)
server <- function(input, output)
{
output$sankey_plot <- renderPlotly({
trace1 <- list(
domain = list(
x = c(0, 1),
y = c(0, 1)
),
link = list(
label = c("Case1", "Case2", "Case3", "Case4", "Case5", "Case6",
"Case7"),
source = c(0, 1, 2, 3, 4, 5, 6, 7),
target = c(11, 12, 7, 10, 13, 9, 8),
value = c(5, 6, 2, 4, 10, 6, 2)
),
node = list(label = c("R1", "R2", "R3","R4","R5","R6","R7","Blood
Test","Check Out","Discuss Results",
"MRI Scan", "Registration", "Triage and Assessment",
"X-RAY")),
type = "sankey"
)
data <- list(trace1)
p <- plot_ly()
p <- add_trace(p, domain=trace1$domain, link=trace1$link,
node=trace1$node, type=trace1$type)
p
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
if(is.null(d))
{
print("Hello, Please hover to see the result" )
} else
d
})
}
shinyApp(ui, server)
Considering event_data() outputs a dataframe, the below code access that particular value pointNumber and renders dynamic UI.
Code:
## app.R ##
library(shiny)
library(shinydashboard)
library(devtools)
library(ggplot2)
library(plotly)
library(proto)
library(RColorBrewer)
library(gapminder)
library(stringr)
library(broom)
library(mnormt)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Multiple hover"),
dashboardSidebar(
width = 0
),
dashboardBody(
uiOutput('box1'),
tags$br(),
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("sankey_table"))
)
)
server <- function(input, output)
{
output$sankey_plot <- renderPlotly({
trace1 <- list(
domain = list(
x = c(0, 1),
y = c(0, 1)
),
link = list(
label = c("Case1", "Case2", "Case3", "Case4", "Case5", "Case6",
"Case7"),
source = c(0, 1, 2, 3, 4, 5, 6, 7),
target = c(11, 12, 7, 10, 13, 9, 8),
value = c(5, 6, 2, 4, 10, 6, 2)
),
node = list(label = c("R1", "R2", "R3","R4","R5","R6","R7","Blood
Test","Check Out","Discuss Results",
"MRI Scan", "Registration", "Triage and Assessment",
"X-RAY")),
type = "sankey"
)
data <- list(trace1)
p <- plot_ly()
p <- add_trace(p, domain=trace1$domain, link=trace1$link,
node=trace1$node, type=trace1$type)
p
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
if(is.null(d))
{
print("Hello, Please hover to see the result" )
} else
d
})
output$box1 <- renderUI({
tagList(
infoBox("Multiply by 2", event_data("plotly_click")$pointNumber * 2, icon = icon("credit-card")),
infoBox("Multiply by 3", event_data("plotly_click")$pointNumber * 3, icon = icon("credit-card")),
infoBox("Multiply by 4", event_data("plotly_click")$pointNumber * 4, icon = icon("credit-card"))
)
})
}
shinyApp(ui, server)
Screenshot:

Resources