在 VisNetwork 的 nodesIdSelection 框中扩展维度，使标签适合而不被截断
Extending Dimensions in nodesIdSelection box in VisNetwork so Labels Fit Without Being Cutoff
我创建了一个效果很好的 VisNetwork 图。我遇到的问题之一是 nodesIdSelection = TRUE 中的标签。节点 ID 相当长，并且由于下拉框的默认长度而被截断。这是它的样子：
如何扩展框的大小，使其包含所有内容而不将其切断？
完整的可重现代码如下：
library(igraph)
library(visNetwork)
B = matrix(
c(1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 47, 3, 0, 3, 0, 1, 10, 13, 5,
0, 3, 19, 0, 1, 0, 1, 7, 3, 1,
0, 0, 0, 3, 0, 0, 0, 0, 0, 0,
0, 3, 1, 0, 32, 0, 0, 3, 2, 1,
0, 0, 0, 0, 0, 2, 0, 0, 0, 0,
0, 1, 1, 0, 0, 0, 2, 1, 1, 0,
0, 10, 7, 0, 3, 0, 1, 90, 12, 4,
0, 13, 3, 0, 2, 0, 1, 12, 52, 4,
0, 5, 1, 0, 1, 0, 0, 4, 4, 18),
nrow=10,
ncol=10)
colnames(B) <- c("Alpha-Bravo-Delta-BETA", "Bravo-Alpha-Delta-BETA", "Colonel-Alpha-Beta-RAT", "Demo-Test-Tester1", "Egg-Alpha-Beta-Delta-Beta", "Felix-Test-Tester-Demo", "Gasoline-Alpha-Beta-Delta-American", "Hurricane-Matthew-Example-Long-Text", "Indigo-Indigo-Indigo-Alpha", "Jab-Jabba-JabbaJabba-Delta")
rownames(B) <- c("Alpha-Bravo-Delta-BETA", "Bravo-Alpha-Delta-BETA", "Colonel-Alpha-Beta-RAT", "Demo-Test-Tester1", "Egg-Alpha-Beta-Delta-Beta", "Felix-Test-Tester-Demo", "Gasoline-Alpha-Beta-Delta-American", "Hurricane-Matthew-Example-Long-Text", "Indigo-Indigo-Indigo-Alpha", "Jab-Jabba-JabbaJabba-Delta")
g96e = t(B) %*% B
i96e = graph.adjacency(g96e, mode = "undirected", weighted = TRUE, diag=FALSE)
V(i96e)$label = V(i96e)$name
V(i96e)$label.color = rgb(0,0,.2,.8)
V(i96e)$label.cex = .1
V(i96e)$size = 2
V(i96e)$color = rgb(0,0,1,.5)
V(i96e)$frame.color = V(i96e)$color
fc<-fastgreedy.community(i96e, merges=TRUE, modularity=TRUE,
membership=TRUE, weights=E(i96e)$weight)
colors <- rainbow(max(membership(fc)))
col = c("#80FF00FF", "#FF0000FF", "#FF0000FF", "#00FFFFFF",
"#FF0000FF", "#8000FFFF", "#FF0000FF", "#FF0000FF",
"#FF0000FF", "#FF0000FF")
然后我创建了一个自定义 VisOption（我认为需要为此工作进行修改）：
visOptions_custom <- function (graph, width = NULL, height = NULL, highlightNearest = FALSE,
nodesIdSelection = FALSE, selectedBy = NULL, autoResize = NULL,
clickToUse = NULL, manipulation = NULL)
{
if (!any(class(graph) %in% c("visNetwork", "visNetwork_Proxy"))) {
stop("graph must be a visNetwork or a visNetworkProxy object")
}
options <- list()
options$autoResize <- autoResize
options$clickToUse <- clickToUse
if (is.null(manipulation)) {
options$manipulation <- list(enabled = FALSE)
}
else {
options$manipulation <- list(enabled = manipulation)
}
options$height <- height
options$width <- width
if (!is.null(manipulation)) {
if (manipulation) {
graph$x$datacss <- paste(readLines(system.file("htmlwidgets/lib/css/dataManipulation.css",
package = "visNetwork"), warn = FALSE), collapse = "\n")
}
}
if (!"nodes" %in% names(graph$x) && any(class(graph) %in%
"visNetwork")) {
highlight <- list(enabled = FALSE)
idselection <- list(enabled = FALSE)
byselection <- list(enabled = FALSE)
}
else {
highlight <- list(enabled = FALSE, hoverNearest = FALSE,
degree = 1, algorithm = "all")
if (is.list(highlightNearest)) {
if (any(!names(highlightNearest) %in% c("enabled",
"degree", "hover", "algorithm"))) {
stop("Invalid 'highlightNearest' argument")
}
if ("algorithm" %in% names(highlightNearest)) {
stopifnot(highlightNearest$algorithm %in% c("all",
"hierarchical"))
highlight$algorithm <- highlightNearest$algorithm
}
if ("degree" %in% names(highlightNearest)) {
highlight$degree <- highlightNearest$degree
}
if (highlight$algorithm %in% "hierarchical") {
if (is.list(highlight$degree)) {
stopifnot(all(names(highlight$degree) %in%
c("from", "to")))
}
else {
highlight$degree <- list(from = highlight$degree,
to = highlight$degree)
}
}
if ("hover" %in% names(highlightNearest)) {
stopifnot(is.logical(highlightNearest$hover))
highlight$hoverNearest <- highlightNearest$hover
}
if ("enabled" %in% names(highlightNearest)) {
stopifnot(is.logical(highlightNearest$enabled))
highlight$enabled <- highlightNearest$enabled
}
}
else {
stopifnot(is.logical(highlightNearest))
highlight$enabled <- highlightNearest
}
if (highlight$enabled && any(class(graph) %in% "visNetwork")) {
if (!"label" %in% colnames(graph$x$nodes)) {
#graph$x$nodes$label <- as.character(graph$x$nodes$id)
}
if (!"group" %in% colnames(graph$x$nodes)) {
graph$x$nodes$group <- 1
}
}
idselection <- list(enabled = FALSE, style = "width: 150px; height: 26px")
if (is.list(nodesIdSelection)) {
if (any(!names(nodesIdSelection) %in% c("enabled",
"selected", "style", "values"))) {
stop("Invalid 'nodesIdSelection' argument. List can have 'enabled', 'selected', 'style', 'values'")
}
if ("selected" %in% names(nodesIdSelection)) {
if (any(class(graph) %in% "visNetwork")) {
if (!nodesIdSelection$selected %in% graph$x$nodes$id) {
stop(nodesIdSelection$selected, " not in data. nodesIdSelection$selected must be valid.")
}
}
idselection$selected <- nodesIdSelection$selected
}
if ("enabled" %in% names(nodesIdSelection)) {
idselection$enabled <- nodesIdSelection$enabled
}
else {
idselection$enabled <- TRUE
}
if ("style" %in% names(nodesIdSelection)) {
idselection$style <- nodesIdSelection$style
}
}
else if (is.logical(nodesIdSelection)) {
idselection$enabled <- nodesIdSelection
}
else {
stop("Invalid 'nodesIdSelection' argument")
}
if (idselection$enabled) {
if ("values" %in% names(nodesIdSelection)) {
idselection$values <- nodesIdSelection$values
if (length(idselection$values) == 1) {
idselection$values <- list(idselection$values)
}
if ("selected" %in% names(nodesIdSelection)) {
if (!idselection$selected %in% idselection$values) {
stop(idselection$selected, " not in data/selection. nodesIdSelection$selected must be a valid value.")
}
}
}
}
byselection <- list(enabled = FALSE, style = "width: 150px; height: 26px",
multiple = FALSE)
if (!is.null(selectedBy)) {
if (is.list(selectedBy)) {
if (any(!names(selectedBy) %in% c("variable",
"selected", "style", "values", "multiple"))) {
stop("Invalid 'selectedBy' argument. List can have 'variable', 'selected', 'style', 'values', 'multiple'")
}
if ("selected" %in% names(selectedBy)) {
byselection$selected <- as.character(selectedBy$selected)
}
if (!"variable" %in% names(selectedBy)) {
stop("'selectedBy' need at least 'variable' information")
}
byselection$variable <- selectedBy$variable
if ("style" %in% names(selectedBy)) {
byselection$style <- selectedBy$style
}
if ("multiple" %in% names(selectedBy)) {
byselection$multiple <- selectedBy$multiple
}
}
else if (is.character(selectedBy)) {
byselection$variable <- selectedBy
}
else {
stop("Invalid 'selectedBy' argument. Must a 'character' or a 'list'")
}
if (any(class(graph) %in% "visNetwork_Proxy")) {
byselection$enabled <- TRUE
if ("values" %in% names(selectedBy)) {
byselection$values <- selectedBy$values
}
if ("selected" %in% names(byselection)) {
byselection$selected <- byselection$selected
}
}
else {
if (!byselection$variable %in% colnames(graph$x$nodes)) {
warning("Can't find '", byselection$variable,
"' in node data.frame")
}
else {
byselection$enabled <- TRUE
byselection$values <- unique(graph$x$nodes[,
byselection$variable])
if (byselection$multiple) {
byselection$values <- unique(gsub("^[[:space:]]*|[[:space:]]*$",
"", do.call("c", strsplit(as.character(byselection$values),
split = ","))))
}
if (any(c("integer", "numeric") %in% class(graph$x$nodes[,
byselection$variable]))) {
byselection$values <- sort(byselection$values)
}
else {
byselection$values <- sort(as.character(byselection$values))
}
if ("values" %in% names(selectedBy)) {
byselection$values <- selectedBy$values
}
if ("selected" %in% names(byselection)) {
if (!byselection$selected %in% byselection$values) {
stop(byselection$selected, " not in data/selection. selectedBy$selected must be a valid value.")
}
byselection$selected <- byselection$selected
}
if (!"label" %in% colnames(graph$x$nodes)) {
graph$x$nodes$label <- ""
}
if (!"group" %in% colnames(graph$x$nodes)) {
graph$x$nodes$group <- 1
}
}
}
}
}
x <- list(highlight = highlight, idselection = idselection,
byselection = byselection)
if (highlight$hoverNearest) {
graph <- visInteraction(graph, hover = TRUE)
}
if (any(class(graph) %in% "visNetwork_Proxy")) {
data <- list(id = graph$id, options = options)
graph$session$sendCustomMessage("visShinyOptions", data)
if (missing(highlightNearest)) {
x$highlight <- NULL
}
if (missing(nodesIdSelection)) {
x$idselection <- NULL
}
if (missing(selectedBy)) {
x$byselection <- NULL
}
data <- list(id = graph$id, options = x)
graph$session$sendCustomMessage("visShinyCustomOptions",
data)
}
else {
graph$x <- visNetwork:::mergeLists(graph$x, x)
graph$x$options <- visNetwork:::mergeLists(graph$x$options, options)
}
graph
}
i96e = graph.adjacency(g96e, mode = "undirected", weighted = TRUE, diag=FALSE)
i96e <- set.vertex.attribute(i96e, name = "group",value = col)
V(i96e)$title <- V(i96e)$name
VISNETWORK 图
visIgraph(i96e, idToLabel = F, layout = "layout_nicely") %>%
visOptions_custom(highlightNearest = TRUE, selectedBy = "group", nodesIdSelection = TRUE)
如 visOptions 的帮助中所述，您可以使用 style 参数设置 html 样式，从而增加大小。这是一个例子：
nodes <- data.frame(id = 1:15, label = paste("Label", 1:15),
group = sample(LETTERS[1:3], 15, replace = TRUE))
edges <- data.frame(from = trunc(runif(15)*(15-1))+1,
to = trunc(runif(15)*(15-1))+1)
visNetwork(nodes, edges) %>%
visOptions(nodesIdSelection = list(enabled = TRUE,
style = 'width: 300px; height: 26px;'))
我创建了一个效果很好的 VisNetwork 图。我遇到的问题之一是 nodesIdSelection = TRUE 中的标签。节点 ID 相当长，并且由于下拉框的默认长度而被截断。这是它的样子：
如何扩展框的大小，使其包含所有内容而不将其切断？
完整的可重现代码如下：
library(igraph)
library(visNetwork)
B = matrix(
c(1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 47, 3, 0, 3, 0, 1, 10, 13, 5,
0, 3, 19, 0, 1, 0, 1, 7, 3, 1,
0, 0, 0, 3, 0, 0, 0, 0, 0, 0,
0, 3, 1, 0, 32, 0, 0, 3, 2, 1,
0, 0, 0, 0, 0, 2, 0, 0, 0, 0,
0, 1, 1, 0, 0, 0, 2, 1, 1, 0,
0, 10, 7, 0, 3, 0, 1, 90, 12, 4,
0, 13, 3, 0, 2, 0, 1, 12, 52, 4,
0, 5, 1, 0, 1, 0, 0, 4, 4, 18),
nrow=10,
ncol=10)
colnames(B) <- c("Alpha-Bravo-Delta-BETA", "Bravo-Alpha-Delta-BETA", "Colonel-Alpha-Beta-RAT", "Demo-Test-Tester1", "Egg-Alpha-Beta-Delta-Beta", "Felix-Test-Tester-Demo", "Gasoline-Alpha-Beta-Delta-American", "Hurricane-Matthew-Example-Long-Text", "Indigo-Indigo-Indigo-Alpha", "Jab-Jabba-JabbaJabba-Delta")
rownames(B) <- c("Alpha-Bravo-Delta-BETA", "Bravo-Alpha-Delta-BETA", "Colonel-Alpha-Beta-RAT", "Demo-Test-Tester1", "Egg-Alpha-Beta-Delta-Beta", "Felix-Test-Tester-Demo", "Gasoline-Alpha-Beta-Delta-American", "Hurricane-Matthew-Example-Long-Text", "Indigo-Indigo-Indigo-Alpha", "Jab-Jabba-JabbaJabba-Delta")
g96e = t(B) %*% B
i96e = graph.adjacency(g96e, mode = "undirected", weighted = TRUE, diag=FALSE)
V(i96e)$label = V(i96e)$name
V(i96e)$label.color = rgb(0,0,.2,.8)
V(i96e)$label.cex = .1
V(i96e)$size = 2
V(i96e)$color = rgb(0,0,1,.5)
V(i96e)$frame.color = V(i96e)$color
fc<-fastgreedy.community(i96e, merges=TRUE, modularity=TRUE,
membership=TRUE, weights=E(i96e)$weight)
colors <- rainbow(max(membership(fc)))
col = c("#80FF00FF", "#FF0000FF", "#FF0000FF", "#00FFFFFF",
"#FF0000FF", "#8000FFFF", "#FF0000FF", "#FF0000FF",
"#FF0000FF", "#FF0000FF")
然后我创建了一个自定义 VisOption（我认为需要为此工作进行修改）：
visOptions_custom <- function (graph, width = NULL, height = NULL, highlightNearest = FALSE,
nodesIdSelection = FALSE, selectedBy = NULL, autoResize = NULL,
clickToUse = NULL, manipulation = NULL)
{
if (!any(class(graph) %in% c("visNetwork", "visNetwork_Proxy"))) {
stop("graph must be a visNetwork or a visNetworkProxy object")
}
options <- list()
options$autoResize <- autoResize
options$clickToUse <- clickToUse
if (is.null(manipulation)) {
options$manipulation <- list(enabled = FALSE)
}
else {
options$manipulation <- list(enabled = manipulation)
}
options$height <- height
options$width <- width
if (!is.null(manipulation)) {
if (manipulation) {
graph$x$datacss <- paste(readLines(system.file("htmlwidgets/lib/css/dataManipulation.css",
package = "visNetwork"), warn = FALSE), collapse = "\n")
}
}
if (!"nodes" %in% names(graph$x) && any(class(graph) %in%
"visNetwork")) {
highlight <- list(enabled = FALSE)
idselection <- list(enabled = FALSE)
byselection <- list(enabled = FALSE)
}
else {
highlight <- list(enabled = FALSE, hoverNearest = FALSE,
degree = 1, algorithm = "all")
if (is.list(highlightNearest)) {
if (any(!names(highlightNearest) %in% c("enabled",
"degree", "hover", "algorithm"))) {
stop("Invalid 'highlightNearest' argument")
}
if ("algorithm" %in% names(highlightNearest)) {
stopifnot(highlightNearest$algorithm %in% c("all",
"hierarchical"))
highlight$algorithm <- highlightNearest$algorithm
}
if ("degree" %in% names(highlightNearest)) {
highlight$degree <- highlightNearest$degree
}
if (highlight$algorithm %in% "hierarchical") {
if (is.list(highlight$degree)) {
stopifnot(all(names(highlight$degree) %in%
c("from", "to")))
}
else {
highlight$degree <- list(from = highlight$degree,
to = highlight$degree)
}
}
if ("hover" %in% names(highlightNearest)) {
stopifnot(is.logical(highlightNearest$hover))
highlight$hoverNearest <- highlightNearest$hover
}
if ("enabled" %in% names(highlightNearest)) {
stopifnot(is.logical(highlightNearest$enabled))
highlight$enabled <- highlightNearest$enabled
}
}
else {
stopifnot(is.logical(highlightNearest))
highlight$enabled <- highlightNearest
}
if (highlight$enabled && any(class(graph) %in% "visNetwork")) {
if (!"label" %in% colnames(graph$x$nodes)) {
#graph$x$nodes$label <- as.character(graph$x$nodes$id)
}
if (!"group" %in% colnames(graph$x$nodes)) {
graph$x$nodes$group <- 1
}
}
idselection <- list(enabled = FALSE, style = "width: 150px; height: 26px")
if (is.list(nodesIdSelection)) {
if (any(!names(nodesIdSelection) %in% c("enabled",
"selected", "style", "values"))) {
stop("Invalid 'nodesIdSelection' argument. List can have 'enabled', 'selected', 'style', 'values'")
}
if ("selected" %in% names(nodesIdSelection)) {
if (any(class(graph) %in% "visNetwork")) {
if (!nodesIdSelection$selected %in% graph$x$nodes$id) {
stop(nodesIdSelection$selected, " not in data. nodesIdSelection$selected must be valid.")
}
}
idselection$selected <- nodesIdSelection$selected
}
if ("enabled" %in% names(nodesIdSelection)) {
idselection$enabled <- nodesIdSelection$enabled
}
else {
idselection$enabled <- TRUE
}
if ("style" %in% names(nodesIdSelection)) {
idselection$style <- nodesIdSelection$style
}
}
else if (is.logical(nodesIdSelection)) {
idselection$enabled <- nodesIdSelection
}
else {
stop("Invalid 'nodesIdSelection' argument")
}
if (idselection$enabled) {
if ("values" %in% names(nodesIdSelection)) {
idselection$values <- nodesIdSelection$values
if (length(idselection$values) == 1) {
idselection$values <- list(idselection$values)
}
if ("selected" %in% names(nodesIdSelection)) {
if (!idselection$selected %in% idselection$values) {
stop(idselection$selected, " not in data/selection. nodesIdSelection$selected must be a valid value.")
}
}
}
}
byselection <- list(enabled = FALSE, style = "width: 150px; height: 26px",
multiple = FALSE)
if (!is.null(selectedBy)) {
if (is.list(selectedBy)) {
if (any(!names(selectedBy) %in% c("variable",
"selected", "style", "values", "multiple"))) {
stop("Invalid 'selectedBy' argument. List can have 'variable', 'selected', 'style', 'values', 'multiple'")
}
if ("selected" %in% names(selectedBy)) {
byselection$selected <- as.character(selectedBy$selected)
}
if (!"variable" %in% names(selectedBy)) {
stop("'selectedBy' need at least 'variable' information")
}
byselection$variable <- selectedBy$variable
if ("style" %in% names(selectedBy)) {
byselection$style <- selectedBy$style
}
if ("multiple" %in% names(selectedBy)) {
byselection$multiple <- selectedBy$multiple
}
}
else if (is.character(selectedBy)) {
byselection$variable <- selectedBy
}
else {
stop("Invalid 'selectedBy' argument. Must a 'character' or a 'list'")
}
if (any(class(graph) %in% "visNetwork_Proxy")) {
byselection$enabled <- TRUE
if ("values" %in% names(selectedBy)) {
byselection$values <- selectedBy$values
}
if ("selected" %in% names(byselection)) {
byselection$selected <- byselection$selected
}
}
else {
if (!byselection$variable %in% colnames(graph$x$nodes)) {
warning("Can't find '", byselection$variable,
"' in node data.frame")
}
else {
byselection$enabled <- TRUE
byselection$values <- unique(graph$x$nodes[,
byselection$variable])
if (byselection$multiple) {
byselection$values <- unique(gsub("^[[:space:]]*|[[:space:]]*$",
"", do.call("c", strsplit(as.character(byselection$values),
split = ","))))
}
if (any(c("integer", "numeric") %in% class(graph$x$nodes[,
byselection$variable]))) {
byselection$values <- sort(byselection$values)
}
else {
byselection$values <- sort(as.character(byselection$values))
}
if ("values" %in% names(selectedBy)) {
byselection$values <- selectedBy$values
}
if ("selected" %in% names(byselection)) {
if (!byselection$selected %in% byselection$values) {
stop(byselection$selected, " not in data/selection. selectedBy$selected must be a valid value.")
}
byselection$selected <- byselection$selected
}
if (!"label" %in% colnames(graph$x$nodes)) {
graph$x$nodes$label <- ""
}
if (!"group" %in% colnames(graph$x$nodes)) {
graph$x$nodes$group <- 1
}
}
}
}
}
x <- list(highlight = highlight, idselection = idselection,
byselection = byselection)
if (highlight$hoverNearest) {
graph <- visInteraction(graph, hover = TRUE)
}
if (any(class(graph) %in% "visNetwork_Proxy")) {
data <- list(id = graph$id, options = options)
graph$session$sendCustomMessage("visShinyOptions", data)
if (missing(highlightNearest)) {
x$highlight <- NULL
}
if (missing(nodesIdSelection)) {
x$idselection <- NULL
}
if (missing(selectedBy)) {
x$byselection <- NULL
}
data <- list(id = graph$id, options = x)
graph$session$sendCustomMessage("visShinyCustomOptions",
data)
}
else {
graph$x <- visNetwork:::mergeLists(graph$x, x)
graph$x$options <- visNetwork:::mergeLists(graph$x$options, options)
}
graph
}
i96e = graph.adjacency(g96e, mode = "undirected", weighted = TRUE, diag=FALSE)
i96e <- set.vertex.attribute(i96e, name = "group",value = col)
V(i96e)$title <- V(i96e)$name
VISNETWORK 图
visIgraph(i96e, idToLabel = F, layout = "layout_nicely") %>%
visOptions_custom(highlightNearest = TRUE, selectedBy = "group", nodesIdSelection = TRUE)
如 visOptions 的帮助中所述，您可以使用 style 参数设置 html 样式，从而增加大小。这是一个例子：
nodes <- data.frame(id = 1:15, label = paste("Label", 1:15),
group = sample(LETTERS[1:3], 15, replace = TRUE))
edges <- data.frame(from = trunc(runif(15)*(15-1))+1,
to = trunc(runif(15)*(15-1))+1)
visNetwork(nodes, edges) %>%
visOptions(nodesIdSelection = list(enabled = TRUE,
style = 'width: 300px; height: 26px;'))