I am trying to produce a Sankey diagram with the help of this page:
https://www.r-graph-gallery.com/321-introduction-to-interactive-sankey-diagram-2.html
Now, I modified the data a bit, and was wondering if I can right and left-sink the nodes, i.e. that the top-nodes are always to the left (aligned) and the last nodes always to the right. It appears that networkd3 only has the sinkright option.
Using the following code:
library(networkD3)
library(dplyr)
# A connection data frame is a list of flows with intensity for each flow
links <- data.frame(
source=c("group_A", "group_B", "group_C", "group_C"),
target=c("group_D", "group_C", "group_F", "group_G"),
value=c(3, 4, 3, 1)
)
# From these flows we need to create a node data frame: it lists every entities involved in the flow
nodes <- data.frame(
name=c(as.character(links$source),
as.character(links$target)) %>% unique()
)
# With networkD3, connection must be provided using id, not using real name like in the links dataframe.. So we need to reformat it.
links$IDsource <- match(links$source, nodes$name)-1
links$IDtarget <- match(links$target, nodes$name)-1
# Make the Network
p <- sankeyNetwork(Links = links, Nodes = nodes,
Source = "IDsource", Target = "IDtarget",
Value = "value", NodeID = "name",
fontSize=20)
p
Gives me this output:
Sankey Plot
It looks already promising, but I would like to move group_A to the left side (while keeping the right side aligned). Is this possible?
It appears this seems to be not possible with networkD3 out of the box. However, I found out that plotly offers a x position option, which worked in the end:
fig <- plot_ly(
type = "sankey",
arrangement = "snap",
node = list(
label = nodes$name,
x = c(0.1, 0.1, 0.5, 0.7, 0.7, 0.7),
pad = 10), # 10 Pixel
link = list(
source = links$IDsource,
target = links$IDtarget,
value = links$value))
fig <- fig %>% layout(title = "Sankey with manually positioned node")
fig
Related
I am using sankeyNetwork() from the networkD3 package for visualizing some data. I was wondering if theres a way to "isolate" a branch from start to finish, ignoring the irrelevant links.
Example: I've got this: SankeyGot
And I want to extract this: SankeyWant
reproducible example:
set.seed(9)
df <- tibble(
source = sample(stringr::words, 5) %>% rep(2),
target = c(sample(words, 7), source[1:3]),
values = rnorm(10, 10, 7) %>% round(0) %>% abs)
nodes <- data.frame(names = unique(c(df$source, df$target)))
links <- tibble(
source = match(
df$source, nodes$names) -1,
target = match(
df$target, nodes$names) -1,
value = df$values
)
sankeyNetwork(Links = links, Nodes = nodes, Source = "source",
Target = "target", Value = "value", NodeID = "names",
iterations = 64, sinksRight = F, fontSize = 14)
I'd like to be able to filter out "name" for example and get everything that connects to that on all levels upstream and downstream - how would i go about doing this?
Calculating the paths from a node in a graph is non-trivial, but the igraph package can help with the all_simple_paths(). However, heed that warning in the help file...
Note that potentially there are exponentially many paths between two
vertices of a graph, and you may run out of memory when using this
function, if your graph is lattice-like.
(I don't know what your words vector is, so I recreated the links data.frame manually)
library(dplyr)
library(networkD3)
set.seed(9)
df <- read.csv(header = TRUE, text = "
source,target
summer,obvious
summer,structure
however,either
however,match
obvious,about
obvious,non
either,contract
either,produce
contract,paint
contract,name
")
df$values <- rnorm(10, 10, 7) %>% round(0) %>% abs()
# use graph to calculate the paths from a node
library(igraph)
graph <- graph_from_data_frame(df)
start_node <- "name"
# get nodes along a uni-directional path going IN to the start_node
connected_nodes_in <-
all_simple_paths(graph, from = start_node, mode = "in") %>%
unlist() %>%
names() %>%
unique()
# get nodes along a uni-directional path going OUT of the start_node
connected_nodes_out <-
all_simple_paths(graph, from = start_node, mode = "out") %>%
unlist() %>%
names() %>%
unique()
# combine them
connected_nodes <- unique(c(connected_nodes_in, connected_nodes_out))
# filter your data frame so it only includes links/edges that start and
# end at connected nodes
df <- df %>% filter(source %in% connected_nodes & target %in% connected_nodes)
nodes <- data.frame(names = unique(c(df$source, df$target)))
links <- tibble(
source = match(
df$source, nodes$names) -1,
target = match(
df$target, nodes$names) -1,
value = df$values
)
sankeyNetwork(Links = links, Nodes = nodes, Source = "source",
Target = "target", Value = "value", NodeID = "names",
iterations = 64, sinksRight = F, fontSize = 14)
If you code sankeyNetwork as an object you can use str(object) to identify it as a list, with a matrix called x that holds your input df
list_sankey <- sankeyNetwork(Links = links, Nodes = nodes, Source = "source", Target = "target", Value = "value", NodeID = "names", iterations = 64, sinksRight = F, fontSize = 14)
str(list_sankey)
You can then filter the x matrix to only contrain your desired input source and output target nodes
list_sankey_filter <- list_sankey
list_sankey_filter$x$links <- list_sankey_filter$x$links %>% filter(source %in% c(4, 2, 0), target %in% c(4, 2, 0, 10))
This then gives you the object below.
I generated a random network by using 620 nodes and 2102 edges. I want to visualize it by using plot.But, 1. not sure how to make the plot nicer (make nodes more separated at least)? 2.adjust the node size based on 'degree'.
my codes are:
set.seed(42)
Network_random <- erdos.renyi.game(620,2102,type='gnm')
plot(Network_random, vertex.col="degree", main="Network Random",layout=layout_nicely,margin=-0.25)
my current plot is as below:
What about this?
set.seed(42)
Network_random <- erdos.renyi.game(620, 2102, type = "gnm") %>%
set_vertex_attr(name = "size", value = pmax(degree(.), 5)) %>%
plot(vertex.label = NA, vertex.color = degree(.), main = "Network Random", margin = -0.25)
I have been trying for some time to debug my Shiny gadget but still cannot manage it. Really appreciate any help.
My gadget consists of a scatterplot generated with Plotly. The user can click one of the points, which will allow you to change some parameters associated with that point. To emphasise the fact that the user has selected that point, I wanted to highlight the selected point.
Alternatively, the user can also select a point from a dropdown menu, which also should highlight the corresponding point.
As an added feature, I want to additionally highlight points that are below a certain threshold on the x axis. This threshold is represented by a dotted line, which you can turn on and off, and move the value of the threshold.
In summary, the points on the plot should all be blue circles, except for the following two cases:
if it is clicked, i.e. it is the "active point" (this should create a red border around the point)
if it is below the threshold on the x-axis (the point should turn to an orange square)
If it is active AND below the threshold, it should be an orange square with a red border, as you would expect.
My gadget works, kind of. But in some cases not. In the example below, one of the points is already below the threshold, but when I select that point, the red marker appears on another point! Despite the active variable being the correct one.
I also get a weird behaviour that the points turn purple if the threshold is below all of the points. But if I move the threshold to be above one of the points, the colours are corrected.
I have a suspicion that this is something to do with the points being on different traces? Therefore when I try to highlight certain points, perhaps I am not indexing the vector as I am expecting. But I am finding it really difficult to debug inside Shiny and Plotly, and I have no good understanding of the Plotly object, so I don't have much clue as to what is going on.
The code below is a reproducible example. You have to run "dat1" through the "rew8r" function. I have taken out other features of the app to try to focus on the problem. Thanks very much to anyone who might take the time to have a look at this, and give any hints!
library(plotly)
library(dplyr)
library(shiny)
library(reactable)
dat1 <- data.frame(
Indicator = c("v1","v2","v3"),
Weight = rep(1,3),
Correlation = c(0.1, 0.8, 0.6) )
rew8r <- function(dat){
# get indicator names
inames <- dat$Indicator
## Create the shiny UI layout
ui <- fluidPage(
# the side panel
sidebarPanel(
selectInput("vseldrop", "Select indicator here or by clicking a point on plot.",
c("<Select>",inames)),
hr(style = "border-top: 1px solid #000000;"),
fluidRow(
column(6,numericInput("locorval", "Low correlation threshold:", 0.2, min = -1, max = 1, step = 0.05)),
column(6,br(),checkboxInput("locorsw", "Enable", value = FALSE)))
),
# the main panel (graph, table, etc)
mainPanel(
plotlyOutput("corrplot"),
textOutput("info")
)
)
## Create the Shiny Server layout
server <- function(input, output, session) {
# this is the plotly click data
event.data <- reactive({event_data(event = "plotly_click", source = "scplot")})
# First, monitor which variable is active
# Create reactive value for active var
acvar <- reactiveVal(NULL)
# update active variable via plot click
observeEvent(event.data(),{
acvar(event.data()$key)})
# update active variable via dropdown
observeEvent(input$vseldrop,
acvar(input$vseldrop))
## Create the plotly plot that compares price vs scoops
output$corrplot <- renderPlotly({
# colours around markers when selected or not
lincol <- ifelse(inames %in% acvar(), "red", "blue")
# size of line around marker (set to 0 if not selected)
linsize <- ifelse(inames %in% acvar(), 3, 0)
# symbol when above/below corr threshold
symbs <- if(input$locorsw==TRUE){c(16,15)}else{c(16,16)}
# colour when above/below threshold
pcols <- if(input$locorsw==TRUE){c("blue", "orange")}else{c("blue", "blue")}
# generate main plot
p <- plot_ly(dat, x = ~Correlation, y = ~Weight, type = "scatter", mode = "markers",
text = ~Indicator, key = ~Indicator, source = "scplot",
marker = list(size = 10, line = list(color = lincol, width = linsize)),
symbol = ~Correlation < input$locorval, symbols = symbs,
color = ~Correlation < input$locorval, colors = pcols) %>%
layout(showlegend = FALSE, yaxis = list(
range = c(0, 1.25),
autotick = FALSE,
dtick = 0.25),
xaxis = list(
range = c(-0.5, 1),
autotick = FALSE,
dtick = 0.2))
# add low correlation line, if activated
if(input$locorsw==TRUE){
p <- p %>% add_segments(x = input$locorval, xend = input$locorval, y = 0, yend = 1.25,
marker = list(color = 'red', opacity=0),
line = list(dash = 'dash')) %>%
layout(showlegend = FALSE)
}
p
})
# Text info
output$info <- renderText({
paste(acvar(), class(acvar()))
})
# update dropdown menu
observeEvent(acvar(),{
updateSelectInput(session, "vseldrop", selected = acvar())
})
}
runGadget(ui, server, viewer = browserViewer())
}
I simulated some data and created a graph network in R using visnetwork:
library(igraph)
library(dplyr)
library(visNetwork)
#create file from which to sample from
x5 <- sample(1:100, 1100, replace=T)
#convert to data frame
x5 = as.data.frame(x5)
#create first file (take a random sample from the created file)
a = sample_n(x5, 1000)
#create second file (take a random sample from the created file)
b = sample_n(x5, 1000)
#combine
c = cbind(a,b)
#create dataframe
c = data.frame(c)
#rename column names
colnames(c) <- c("a","b")
#create graph
graph <- graph.data.frame(c, directed=F)
graph <- simplify(graph)
plot(graph)
fc <- fastgreedy.community(graph)
V(graph)$community <- fc$membership
library(visNetwork)
nodes <- data.frame(id = V(graph)$name, title = V(graph)$name, group = V(graph)$community)
nodes <- nodes[order(nodes$id, decreasing = F),]
edges <- get.data.frame(graph, what="edges")[1:2]
#visnet graph
visNetwork(nodes, edges) %>% visIgraphLayout(layout = "layout_with_fr") %>%
visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE)
Right now, the graph only displays node information when you click on it. Suppose if each node had observed properties in the "original file". E.g.
#add some information corresponding to the original data
other_damages_in_dollars <- rnorm(1000,104,9)
location <- c("canada","usa")
location <- sample(location, 1000, replace=TRUE, prob=c(0.3, 0.7))
type_of_house <- c("single","townhome", "rental" )
type_of_house<- sample(type_of_house , 1000, replace=TRUE, prob=c(0.5, 0.3, 0.2))
#heres how the original data would have looked like
original_data = data.frame(a,b, other_damages_in_dollars, location, type_of_house)
Is there a way to add this information when you click on each node?
#visnet graph - is it possible to use the '$' operator to add these properties?
visNetwork(nodes, edges) %>% visIgraphLayout(layout = "layout_with_fr") %>%
%>% visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE)visEvents(selectEdge = "function(properties) { alert(this.body.data.edges._data[properties.edges[0]].original_data$location); }") %>% visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE)visEvents(selectEdge = "function(properties) { alert(this.body.data.edges._data[properties.edges[0]].original_data$type_of_house); }") %>% visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE)visEvents(selectEdge = "function(properties) { alert(this.body.data.edges._data[properties.edges[0]].original_data$other_damage_in_dollars); }")
You don't need an event. This is built into many of the vis.js elements.
So, I'll start with designing the content of my tooltip. Of the 1000 rows you made of location, home types, and costs, I created a subset with the same number of rows as there are nodes. This is what will be shown in my tooltip.
newTitle = paste0("Location: ", toupper(location[1:nrow(nodes)]),
"<br>Home Type: ", type_of_house[1:nrow(nodes)],
"<br>Damage Related Costs: ",
sprintf("$%.2f", other_damages_in_dollars[1:nrow(nodes)]))
#check it; looks okay
Now I'm going to make my tooltips the titles of my nodes.
# replace the node titles:
nodes$title = newTitle
Call the network and click anywhere on the graph once to activate it. Now you just have to hover....(note the blue box, that means it's listening). There are a lot of nodes really close together, so there will be a bit of delayed response when you move from node to node.
You can get rid of the need to click to activate with visOptions(clickToUse = F).
visNetwork(nodes, edges) %>% visIgraphLayout(layout = "layout_with_fr")
FYI
I didn't go through all of the code in the original question; there's a lot! I'm going to include what I ran before creating my graph, so you know what was in and what was not. This code is not changed from your question.
library(igraph)
library(dplyr)
library(visNetwork)
#create file from which to sample from
x5 <- sample(1:100, 1100, replace=T)
#convert to data frame
x5 = as.data.frame(x5)
#create first file (take a random sample from the created file)
a = sample_n(x5, 1000)
#create second file (take a random sample from the created file)
b = sample_n(x5, 1000)
#combine
c = cbind(a,b)
#create dataframe
c = data.frame(c)
#rename column names
colnames(c) <- c("a","b")
#create graph
graph <- graph.data.frame(c, directed=F)
graph <- simplify(graph)
fc <- fastgreedy.community(graph)
V(graph)$community <- fc$membership
nodes <- data.frame(id = V(graph)$name, title = V(graph)$name, group = V(graph)$community)
nodes <- nodes[order(nodes$id, decreasing = F),]
edges <- get.data.frame(graph, what="edges")[1:2]
#add some information corresponding to the original data
other_damages_in_dollars <- rnorm(1000,104,9)
location <- c("canada","usa")
location <- sample(location, 1000, replace=TRUE, prob=c(0.3, 0.7))
type_of_house <- c("single","townhome", "rental" )
type_of_house<- sample(type_of_house , 1000, replace=TRUE, prob=c(0.5, 0.3, 0.2))
#heres how the original data would have looked like
original_data = data.frame(a,b, other_damages_in_dollars, location, type_of_house)
I am using igraph in R for network analysis. I want to display an edge attribute on each line in the plot. An example is below
df <- data.frame(a = c(0,1,2,3,4),b = c(3,4,5,6,7))
nod <- data.frame(node = c(0:7),wt = c(1:8))
pg <- graph_from_data_frame(d = df, vertices = nod,directed = F)
plot(pg)
I want the value of the "wt" feature to show up between each node on the line, or preferably, in a little gap where the line breaks.
Is it possible to make this happen?
Use the parameter edge.label to assign labels of the edges, I used - probably wrong - nod$wt. Of course, you could assign other labels.
You could use the following code:
# load the package
library(igraph)
# your code
df <- data.frame(a = c(0,1,2,3,4),b = c(3,4,5,6,7))
nod <- data.frame(node = c(0:7),wt = c(1:8))
pg <- graph_from_data_frame(d = df, vertices = nod,directed = F)
# plot function with edge.label added
plot(pg, edge.label = nod$wt)
Please, let me know whether this is what you want.