Nothing
visnetwork_init <- function(
network,
label = NULL,
label_break = "\n",
label_width = 30L,
level_separation = NULL,
degree_from = 1L,
degree_to = 1L,
zoom_speed = 1,
physics = FALSE
) {
visnetwork_new(
network = network,
label = label,
label_break = label_break,
label_width = label_width,
level_separation = level_separation,
degree_from = degree_from,
degree_to = degree_to,
zoom_speed = zoom_speed,
physics = physics
)
}
visnetwork_new <- function(
network = NULL,
label = NULL,
label_break = NULL,
label_width = NULL,
level_separation = NULL,
degree_from = NULL,
degree_to = NULL,
zoom_speed = NULL,
physics = NULL
) {
visnetwork_class$new(
network = network,
label = label,
label_break = label_break,
label_width = label_width,
level_separation = level_separation,
degree_from = degree_from,
degree_to = degree_to,
zoom_speed = zoom_speed,
physics = physics
)
}
visnetwork_class <- R6::R6Class(
classname = "tar_visnetwork",
inherit = visual_class,
class = FALSE,
portable = FALSE,
cloneable = FALSE,
public = list(
level_separation = NULL,
degree_from = NULL,
degree_to = NULL,
zoom_speed = NULL,
physics = NULL,
initialize = function(
network = NULL,
label = NULL,
label_break = NULL,
label_width = NULL,
level_separation = NULL,
degree_from = NULL,
degree_to = NULL,
zoom_speed = NULL,
physics = NULL
) {
super$initialize(
network = network,
label = label,
label_break = label_break,
label_width = label_width
)
self$level_separation <- level_separation
self$degree_from <- degree_from
self$degree_to <- degree_to
self$zoom_speed <- zoom_speed
self$physics <- physics
},
produce_shapes = function(type) {
shapes <- c(
object = "triangleDown",
`function` = "triangle",
stem = "dot",
pattern = "square"
)
shapes[type]
},
produce_legend = function() {
vertices <- self$network$vertices
colors <- vertices[vertices$status != "none", c("status", "color")]
shapes <- vertices[, c("type", "shape")]
colors <- colors[!duplicated(colors),, drop = FALSE] # nolint
shapes <- shapes[!duplicated(shapes),, drop = FALSE] # nolint
colors$shape <- rep("dot", nrow(colors))
shapes$color <- rep("#899DA4", nrow(shapes))
colnames(colors) <- c("label", "color", "shape")
colnames(shapes) <- c("label", "shape", "color")
legend <- rbind(colors, shapes)
rownames(legend) <- NULL
legend$label <- gsub("uptodate", "Up to date", legend$label)
legend$label <- capitalize(legend$label)
legend
},
produce_visual = function() {
tar_assert_package("visNetwork")
vertices <- self$network$vertices
edges <- self$network$edges
out <- visNetwork::visNetwork(nodes = vertices, edges = edges, main = "")
out <- visNetwork::visNodes(out, physics = self$physics)
out <- visNetwork::visEdges(
out,
smooth = list(type = "cubicBezier", forceDirection = "horizontal")
)
out <- visNetwork::visOptions(
graph = out,
collapse = TRUE,
highlightNearest = list(
enabled = TRUE,
algorithm = "hierarchical",
degree = list(
from = min(self$degree_from, nrow(vertices)),
to = min(self$degree_to, nrow(vertices))
)
)
)
out <- visNetwork::visLegend(
graph = out,
useGroups = FALSE,
addNodes = self$legend,
ncol = 1L,
position = "right"
)
out <- visNetwork::visPhysics(
graph = out,
stabilization = FALSE
)
out <- visNetwork::visInteraction(
graph = out,
zoomSpeed = self$zoom_speed
)
visNetwork::visHierarchicalLayout(
graph = out,
direction = "LR",
levelSeparation = self$level_separation
)
},
update_ids = function() {
self$network$vertices$id <- self$network$vertices$name
},
update_arrows = function() {
edges <- self$network$edges
edges$arrows <- rep("to", nrow(edges))
self$network$edges <- edges
},
update_positions = function() {
vertices <- self$network$vertices
if (!nrow(vertices)) {
return()
}
vertices <- position_level(vertices, self$network$edges)
self$network$vertices <- vertices
},
update_shapes = function() {
vertices <- self$network$vertices
vertices$shape <- self$produce_shapes(vertices$type)
self$network$vertices <- vertices
},
update_extra = function() {
self$update_ids()
self$update_positions()
self$update_arrows()
self$update_shapes()
},
validate = function() {
super$validate()
if (!is.null(self$visual)) {
tar_assert_identical(class(self$visual)[1], "visNetwork")
}
tar_assert_scalar(self$degree_from)
tar_assert_scalar(self$degree_to)
tar_assert_dbl(self$degree_from)
tar_assert_dbl(self$degree_to)
tar_assert_ge(self$degree_from, 0L)
tar_assert_ge(self$degree_to, 0L)
tar_assert_scalar(self$zoom_speed)
tar_assert_dbl(self$zoom_speed)
tar_assert_positive(self$zoom_speed)
}
)
)
position_level <- function(vertices, edges) {
level <- 0L
vertices$level <- rep(level, nrow(vertices))
if (!nrow(vertices) || !nrow(edges)) {
return(vertices)
}
igraph <- igraph::graph_from_data_frame(edges)
while (length(igraph::V(igraph))) {
level <- level + 1L
leaves <- igraph_leaves(igraph)
vertices[vertices$name %in% leaves, "level"] <- level
igraph <- igraph::delete_vertices(graph = igraph, v = leaves)
}
vertices
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.