问题
Referring back to one of my previous post which contains the full reproducible code: VisNetwork from IGraph - Can't Implement Cluster Colors to Vertices
My goal here is to change some of the visualization options from the visNetwork package graph. There are too many labels currently when I zoom in and it is very tough to distinguish which node belongs to which label. Is it possible to remove the labels from the visNetwork graph, and only display the labels when I hover over a node?
I have tried setting idToLabel = FALSE, but the labels come back when I include selectedBy = "group".
library('visNetwork')
col = c("#80FF00FF", "#FF0000FF", "#FF0000FF", "#00FFFFFF",
"#FF0000FF", "#8000FFFF", "#FF0000FF", "#FF0000FF",
"#FF0000FF", "#FF0000FF")
i96e = graph.adjacency(g96e, mode = "undirected", weighted = TRUE, diag=FALSE)
i96e <- set.vertex.attribute(i96e, name = "group",value = col)
visIgraph(i96e, idToLabel = TRUE, layout = "layout_nicely") %>%
visOptions(highlightNearest = TRUE, selectedBy = "group")
I feel like I practically completed what I wanted to do with this project, but it is just this last final step of only displaying the nodes when hovering over it with the cursor seems to be the issue.
Any help would be great, thanks!
回答1:
You could do
names(vertex_attr(i96e))[which(names(vertex_attr(i96e)) == "label")] <- "title"
visIgraph(i96e, idToLabel = F, layout = "layout_nicely") %>%
visOptions_custom(highlightNearest = TRUE, selectedBy = "group")
with visOptions_custom beeing:
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
}
and i96e beeing:
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("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
rownames(B) <- c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
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")
i96e <- set.vertex.attribute(i96e, name = "group",value = col)
来源：https://stackoverflow.com/questions/39918955/display-edge-label-only-when-hovering-over-it-with-cursor-visnetwork-igraph