I am creating graph structure
id <- c(1,2,3,4,5,6,7,8,9)
label <- c("All", "Cat", "Dog", "Rice","Fish", "Bread","Rice","Fish", "Bread")
nodes <- data.frame(id, label)
edges <- data.frame(
from = c(1,1,2,2,2,3,3,3),
to = c(2,3,4,5,6,7,8,9)
)
visNetwork(nodes, edges, width = "100%",height = "800px") %>% visNodes(shape = "square") %>%
visEdges(arrows = "to") %>%
visInteraction(navigationButtons = TRUE)%>%
visHierarchicalLayout(levelSeparation = 200) %>%
visOptions(manipulation = TRUE)
expecting it to show up like this.
However the actual output is like this
The node positions are incorrect , I cannot manually move the nodes and this makes it very hard to explain. Need help rearranging the nodes based on the expected output above.
You can specify the level for each node to get the orientation you want.
library(visNetwork)
id <- c(1,2,3,4,5,6,7,8,9)
label <- c("All", "Cat", "Dog", "Rice","Fish", "Bread","Rice","Fish", "Bread")
nodes <- data.frame(id, label, level = c( 1,2,2,3,3,3,3,3,3))
edges <- data.frame(
from = c(1,1,2,2,2,3,3,3),
to = c(2,3,4,5,6,7,8,9)
)
visNetwork(nodes, edges, width = "100%",height = "800px") %>% visNodes(shape = "square") %>%
visEdges(arrows = "to") %>%
visInteraction(navigationButtons = TRUE)%>%
visHierarchicalLayout(levelSeparation = 200) %>%
visOptions(manipulation = TRUE)
Related
I have the shiny app below in which I create a process map. What I want to do is subset this process map based on the transitions selectInput().
All the transitions can be seen from the obect edges which I extract from the process_map() object at the beginning but then how can I pass the selected from the selectInput() again to the process_map() object?what I acually need is to hide/display the edges between the nodes if deselect/select one transition pair.
This is how I make it work but I cannot make it work for multiple selection ,using multiple=T inside the selectInput().
library(shiny)
library(bupaR)
library(svgPanZoom)
library(DiagrammeRsvg)
library(DiagrammeR)
library(processmapR)
edges <- patients %>% process_map(performance(mean, "days"))
edges <- attr(edges, "edges")
colnames(edges)[1]<-"predecessor"
colnames(edges)[2]<-"successor"
graph <- process_map(patients
, type_nodes = frequency("absolute",color_scale = "Greys")
,type_edges = frequency("absolute",color_edges = "Greys"),
rankdir = "LR", render = FALSE)
ui <-shinyUI(fluidPage(
selectInput("tran","transitions"
,choices = c("All",paste(edges$predecessor,"-",edges$successor)),
#multiple=T
,selected = "All"),
svgPanZoomOutput("pmap",height = 500,width = 1600)
))
server <- function(input, output) {
output$pmap <- renderSvgPanZoom({
req(input$tran)
if (input$tran != "All"){
pre <- strsplit(input$tran, " - ")[[1]][[1]]
suc <- strsplit(input$tran, " - ")[[1]][[2]]
#creating copy of graph for processing
ndf = get_node_df(graph)
edf = get_edge_df(graph)
newg = create_graph(nodes_df = ndf, edges_df = edf)
newg$global_attrs <- graph$global_attrs
#Finding edges to remove based on pre/suc nodes, selecting edge, removing
#using startWith due termination chars being added
from_nodes = newg %>% clear_selection() %>%
select_nodes(conditions = startsWith(tooltip,pre)) %>% get_selection()
to_nodes = newg %>% clear_selection() %>%
select_nodes(conditions = startsWith(tooltip,suc)) %>% get_selection()
newg <- newg %>% clear_selection() %>%
select_edges(from = from_nodes, to = to_nodes) %>% delete_edges_ws
# newg %>% render_graph # debugging
} else {
newg <- graph
}
newg %>% generate_dot() %>% grViz(width = 1000, height = 2000) %>%
export_svg %>% svgPanZoom(height=800, controlIconsEnabled = TRUE)
})
}
shinyApp(ui=ui,server=server)
The (naive) solution simply revolves around iterating over selected values and filtering the graph accordingly.
library(shiny)
library(bupaR)
library(svgPanZoom)
library(DiagrammeRsvg)
library(DiagrammeR)
library(processmapR)
edges <- patients %>% process_map(performance(mean, "days"))
edges <- attr(edges, "edges")
colnames(edges)[1]<-"predecessor"
colnames(edges)[2]<-"successor"
graph <- process_map(patients
, type_nodes = frequency("absolute",color_scale = "Greys")
,type_edges = frequency("absolute",color_edges = "Greys"),
rankdir = "LR", render = FALSE)
ui <-shinyUI(fluidPage(
checkboxGroupInput("tran","Filter Transitions"
,choices = paste(edges$predecessor,"-",edges$successor)),
svgPanZoomOutput("pmap",height = 500,width = 1600)
))
server <- function(input, output) {
output$pmap <- renderSvgPanZoom({
if (all(!is.null(input$tran))){
#creating copy of graph for processing
ndf = get_node_df(graph)
edf = get_edge_df(graph)
newg = create_graph(nodes_df = ndf, edges_df = edf)
newg$global_attrs <- graph$global_attrs
for (t in input$tran){
pre <- strsplit(t, " - ")[[1]][[1]]
suc <- strsplit(t, " - ")[[1]][[2]]
#Finding edges to remove based on pre/suc nodes, selecting edge, removing
#using startWith due termination chars being added
from_nodes = newg %>% clear_selection() %>%
select_nodes(conditions = startsWith(tooltip,pre)) %>% get_selection()
to_nodes = newg %>% clear_selection() %>%
select_nodes(conditions = startsWith(tooltip,suc)) %>% get_selection()
newg <- newg %>% clear_selection() %>%
select_edges(from = from_nodes, to = to_nodes) %>% delete_edges_ws
# newg %>% render_graph # debugging
}
} else {
newg <- graph
}
newg %>% generate_dot() %>% grViz(width = 1000, height = 2000) %>%
export_svg %>% svgPanZoom(height=800, controlIconsEnabled = TRUE)
})
}
shinyApp(ui=ui,server=server)
Potential performance improvement would be to pre-calculate the edges selection, then the loop iteration would "just" take care of removing these.
I have a network diagram with a few nodes, each node having some data, including an ID and its name.
I'm building the visNetwork object like this:
getDiagramPlot <- function(nodes, edges){
v <- visNetwork(
nodes,
edges
) %>%
visPhysics(stabilization = TRUE, enabled = TRUE) %>%
visOptions(highlightNearest = list(enabled = T, degree = 1, hover = F), autoResize = TRUE, collapse = FALSE) %>%
visEdges(color = list(highlight = "red")) %>% # The colour of the edge linking nodes
visLayout(improvedLayout = TRUE) %>%
visEdges(arrows = edges$arrows) %>%
visInteraction(multiselect = F)
return(v)
}
What I'm after is being able to pipe in visEvents and call a function in my code, ideally passing the ID as a parameter. Something like:
testFunction <- function(node_id){
print(paste("The selected node ID is:", node_id))
}
The examples I've seen online are mostly using the javascript alert() in their examples, but I'm looking to break out of javascript and call an R function in my code.
Any help with this would be much appreciated! Thank you in advance.
You can use Shiny.onInputChange in javascript to set anything as a Shiny input variable. This does the trick.
EDIT: Use doubleClick in visEvents to trigger the code on double click. See https://rdrr.io/cran/visNetwork/man/visEvents.html
library(shiny)
library(visNetwork)
ui <- fluidPage(
visNetworkOutput('network')
)
server <- function(input, output, session) {
getDiagramPlot <- function(nodes, edges){
v <- visNetwork(
nodes,
edges
) %>%
visPhysics(stabilization = TRUE, enabled = TRUE) %>%
visOptions(highlightNearest = list(enabled = T, degree = 1, hover = F), autoResize = TRUE, collapse = FALSE) %>%
visEdges(color = list(highlight = "red")) %>% # The colour of the edge linking nodes
visLayout(improvedLayout = TRUE) %>%
visEdges(arrows = edges$arrows) %>%
visInteraction(multiselect = F) %>%
visEvents(doubleClick = "function(nodes) {
Shiny.onInputChange('current_node_id', nodes.nodes);
;}")
return(v)
}
testFunction <- function(node_id){
print(paste("The selected node ID is:", node_id))
}
nodes <- data.frame(id = 1:3, label = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3))
output$network <- renderVisNetwork(
getDiagramPlot(nodes, edges)
)
observeEvent(input$current_node_id,{
testFunction(input$current_node_id)
})
}
shinyApp(ui, server)
How can I explicitly place nodes on a visNetwork graph?
Or: How can I recreate that graphic in R using visNetwork or an alternative?
Background: The ultimate goal is to represent Causal Loop Diagrams coming from Vensim files. Placing the nodes explicitly is just the first (crucial) step, because in Causal Loop Diagrams the visual mapping of nodes is part of the information (unlike in general graph theory). So if anybody has advice on the bigger picture aka. 'Bringing Causal Loop Diagram Modeling to R', I'll be more than happy.
What I tried:
library("visNetwork")
nodes <- data.frame(id = 1:3, label = c("one", "two", "three"))
edges <- data.frame(from = c(1,1,2), to = c(2,3,1))
visNetwork(nodes, edges, width = "100%", title = nodes$labels, stringsAsFactors = FALSE) %>% visEdges(arrows = "to")
which plots something like (exact layout will change, because of random seed):
With the Q&A from here I tried to place nodes manually by setting x and y values.
library("visNetwork")
nodes <- data.frame(id = 1:3, label = c("one", "two", "three"), x = c(0,1,2), y = c(0,1,2))
edges <- data.frame(from = c(1,1,2), to = c(2,3,1))
visNetwork(nodes, edges, width = "100%", title = nodes$labels, stringsAsFactors = FALSE) %>% visEdges(arrows = "to")
which plots:
..and I really don't understand what's the correspondance between x, y and the placing on the screen..
Also I could not find anything in the docs for visLayout.
It somehow turns out, that the x and y args are not working. Here a solution:
library("visNetwork")
nodes <- data.frame(id = 1:3, label = c("one", "two", "three"))
edges <- data.frame(from = c(1,1,2), to = c(2,3,1))
coords <- as.matrix(data.frame(x = c(0,1,2),
y = c(0,1,2),
stringsAsFactors = FALSE))
visNetwork(nodes, edges, width = "100%", title = nodes$labels) %>%
visNodes() %>%
visOptions(highlightNearest = TRUE) %>%
visInteraction(navigationButtons = TRUE,
dragNodes = TRUE, dragView = TRUE,
zoomView = FALSE) %>%
visEdges(arrows = 'to') %>%
visIgraphLayout(layout = "layout.norm", layoutMatrix = coords)
For history see also here.
Perhaps these links might be helpful for what you want to achive: causaleffect and plot.CLD
Using ggraph instead of visNetwork simplifies things.
library(ggraph)
library(igraph)
g <- make_graph(edges = c(1,2,2,1,1,3))
V(g)$name <- c('one', 'two', 'three')
ggraph(g, layout = 'manual', node.positions = data.frame(x = c(1,1,2), y = c(2,1,2.1))) +
geom_edge_arc(aes(start_cap = label_rect(node1.name),
end_cap = label_rect(node2.name)),
angle_calc = 'along',
label_dodge = unit(2.5, 'mm'),
arrow = arrow(length = unit(4, 'mm'))) +
geom_node_text(aes(label = name, x = x, y = y))
This plots
which is (apart from gridlines and colours) what I was searching for.
I am currently working with the java script wrapper highcharter in R.
I would like to manually set the Y axis for each of the layer, as well as the title for each layer but have not been able to find a way to do so.
E.g the title for all layers are currently "Basic Drilldown", and i would like to update this for each of the drilldowns. As well as I would like to manually set the y axis.
Thanks in advance.
Current code below.
df <- data_frame(
name = c("Animals", "Fruits", "Cars"),
y = c(5, 2, 4),
drilldown = tolower(name)
)
df
hc <- highchart() %>%
hc_chart(type = "column") %>%
hc_title(text = "Basic drilldown") %>%
hc_xAxis(type = "category") %>%
hc_legend(enabled = FALSE) %>%
hc_plotOptions(
series = list(
boderWidth = 0,
dataLabels = list(enabled = TRUE)
)
) %>%
hc_add_series(
data = df,
name = "Things",
colorByPoint = TRUE
)
dfan <- data_frame(
name = c("Cats", "Dogs", "Cows", "Sheep", "Pigs"),
value = c(4, 3, 1, 2, 1)
)
dffru <- data_frame(
name = c("Apple", "Organes"),
value = c(4, 2)
)
dfcar <- data_frame(
name = c("Toyota", "Opel", "Volkswagen"),
value = c(4, 2, 2)
)
hc <- hc %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(
id = "animals",
data = list_parse2(dfan)
),
list(
id = "fruits",
data = list_parse2(dffru)
),
list(
id = "cars",
data = list_parse2(dfcar)
)
)
)
hc
EDIT* updated with answer to dynamically set yaxis for R highcharts.
drilldown = JS('function(e) {
console.log(e.seriesOptions);
this.setTitle({text: e.seriesOptions.name || e.seriesOptions.id });
this.yAxis[0].update({ min: this.yAxis[0].getExtremes().max * 0.5 })}')
First of all, you need to refactor your code a bit, because it's not correct. For example, try to create new variable with all series names and assign this list of names to drilldown field in your data.frame:
names <- c("Animals", "Fruits", "Cars")
df <- data.frame(
name = names,
y = c(5, 2, 4),
drilldown = names
)
Then, change the drilldown id's in your drilldown object definition, because it's not necessary to make them start from lowercase:
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(
id = "Animals",
data = list_parse2(dfan)
),
list(
id = "Fruits",
data = list_parse2(dffru)
),
list(
id = "Cars",
data = list_parse2(dfcar)
)
)
)
The final step is defining the chart.events.drilldown and chart.events.drillup function handlers, inside of which you will set the chart.title.text using Chart.update() function. In order to define it, you have to use JS() R built-in function, just like below:
hc_chart(type = "column", events = list(
load = JS("function() {console.log(this)}"),
drilldown = JS("function(e) {this.update({title: {text: e.seriesOptions.id}})}"),
drillup = JS("function() {this.update({title: {text: 'Basic drilldown' }})}")
)) %>%
Actually, i don't quite understand this part of the question:
As well as I would like to manually set the y axis.
If you describe it more precisely then I will extend the answer.
The following code produces a nice network diagram:
library(igraph);library(visNetwork);library(dplyr)
set.seed(123)
nnodes <- 10
nnedges <- 20
nodes <- data.frame(id = 1:nnodes)
edges <- data.frame(from = sample(1:nnodes, nnedges, replace = T),
to = sample(1:nnodes, nnedges, replace = T))
visNetwork(nodes, edges) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visNodes(shape="circle") %>%
visOptions(highlightNearest = list(enabled = T, hover = T), nodesIdSelection = T)
My question is: How can I disable that edges that leave from a neighboring node are displayed as well (e.g. when node 8 is selected, I don't want the edge from 3 to 9 to be shown).
Edit: Libraries added, thx for poining that out
Using the comment from Djack and wici, I achieved the following solution:
library(igraph);library(visNetwork);library(dplyr)
set.seed(123)
nnodes <- 10
nnedges <- 20
nodes <- data.frame(id = 1:nnodes, label = 1:nnodes)
edges <- data.frame(from = sample(1:nnodes, nnedges, replace = T),
to = sample(1:nnodes, nnedges, replace = T))
visNetwork(nodes, edges) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visNodes(shape="circle") %>%
visOptions(highlightNearest = list(enabled = T, hover = T, algorithm="hierarchical"),nodesIdSelection = T) %>%
visInteraction(hover = T)
I hope, thats what you're looking for.