1#' Network visualization general options 2#' 3#' Network visualization general options. For full documentation, have a look at \link{visDocumentation}. 4#' 5#'@param graph : a visNetwork object 6#'@param width : String. Default to "100\%". The width of the network in pixels or as a percentage. 7#'@param height : String. Default to "100\%". The height of the network in pixels or as a percentage. 8#'@param highlightNearest : Custom Option. Just a Boolean, or a named list. Default to false. Highlight nearest when clicking a node ? Not available for DOT and Gephi. 9#'\itemize{ 10#' \item{"enabled"}{ : Boolean. Default to false. Activated or not ?.} 11#' \item{"degree"}{ : Optional. Integer. Degree of depth of nodes to be colored. Default to 1. Set high number to have the entire sub-network. In case of "hierarchical" algorithm, you can also pass a list(from = 1, to = 1) to control degree in both direction} 12#' \item{"hover"}{ : Optional. Boolean. Enable highlightNearest alos hovering a node ? Default to FALSE} 13#' \item{"algorithm"}{ : Optional. String. highlightNearest algorithm. "all" highlight all nodes, without taking direction information. "hierarchical" look only at inputs/outputs nodes.} 14#' \item{"hideColor"}{ : Optional. String. Color for hidden nodes/edges. Use a rgba definition. Default to rgba(200,200,200,0.5)} 15#' \item{"labelOnly"}{ : Optional. Boolean. Keep just label for nodes on degree + 1 ? Default to TRUE} 16#'} 17#'@param nodesIdSelection : Custom Option. Just a Boolean, or a named list. Default to false. Add an id node selection creating an HTML select element. This options use click event. Not available for DOT and Gephi. 18#'\itemize{ 19#' \item{"enabled"}{ : Boolean. Default to false. Activated or not ?.} 20#' \item{"values}{ : Optional. Vector of possible values (node's id), and so order is preserve. Default to all id in nodes data.frame.} 21#' \item{"selected"}{ : Optional. Integer/Character. Initial id selection. Default to NULL} 22#' \item{"style"}{ : Optional. Character. HTML style of list. Default to 'width: 150px; height: 26px'.} 23#' \item{"useLabels"}{ : Optional. Boolean. Use labels instead of id ? Default to TRUE.} 24#' \item{"main"}{ : Optional. Default to "Select by id"} 25#'} 26#'@param selectedBy : Custom option. Character or a named list. Add a multiple selection based on column of node data.frame creating an HTML select element. Not available for DOT and Gephi. 27#'\itemize{ 28#' \item{"variable"}{ : Character. Column name of selection variable.} 29#' \item{"values}{ : Optional. Vector of possible values. Default to all values in nodes data.frame.} 30#' \item{"selected"}{ : Optional. Integer/Character. Initial selection. Default to NULL} 31#' \item{"style"}{ : Optional. Character. HTML style of list. Default to 'width: 150px; height: 26px'.} 32#' \item{"multiple"}{ : Optional. Boolean. Default to FALSE. If TRUE, you can affect multiple groups per nodes using a comma ("gr1,gr2")} 33#' \item{"hideColor"}{ : Optional. String. Color for hidden nodes/edges. Use a rgba definition. Default to rgba(200,200,200,0.5)} 34#' \item{"main"}{ : Optional. Default to "Select by variable"} 35#' \item{"sort"}{ : Optional. If values is NULL, sort all possible values ?. Default to TRUE} 36#' \item{"highlight"}{ : Optional. Boolean. Run highlightNearest if defined on each selected node ? Default to FALSE} 37#'} 38#'@param collapse : Custom option. Just a Boolean, or a named list. Collapse / Uncollapse nodes using double-click. In dev. 39#'\itemize{ 40#' \item{"enabled"}{ : Boolean. Default to false. Activated or not ?} 41#' \item{"fit"}{ : Optional. Boolean. Default to FALSE. Call fit method after collapse/uncollapse event ?} 42#' \item{"resetHighlight"}{ : Optional. Boolean. Default to TRUE to reset highlighted nodes after collapse/uncollapse event.} 43#' \item{"clusterOptions"}{ : Optional. List. Default to NULL. A list of all options you want to pass to cluster collapsed node} 44#' \item{"keepCoord"}{ : Optional. Boolean. Default to TRUE to keep nodes coordinates on collapse} 45#' \item{"labelSuffix"}{ : Optional. Character. Use node label + suffix or just suffix. Default to '(cluster)'} 46#'} 47#'@param autoResize : Boolean. Default to true. If true, the Network will automatically detect when its container is resized, and redraw itself accordingly. If false, the Network can be forced to repaint after its container has been resized using the function redraw() and setSize(). 48#'@param clickToUse : Boolean. Default to false. When a Network is configured to be clickToUse, it will react to mouse, touch, and keyboard events only when active. When active, a blue shadow border is displayed around the Network. The Network is set active by clicking on it, and is changed to inactive again by clicking outside the Network or by pressing the ESC key. 49#'@param manipulation : Just a Boolean or a list. See \link{visDocumentation}. You can also choose the columns to edit : 50#'\itemize{ 51#' \item{"editEdgeCols"}{ : Optional. Default to NULL, and so you can just move edge. If set, you can't move edge but just edit.} 52#' \item{"editNodeCols"}{ : Optional. Default to c("id", "label"). See examples.} 53#' \item{"addNodeCols"}{ : Optional. Default to c("id", "label"). See examples.} 54#'} 55#'@examples 56#' nodes <- data.frame(id = 1:15, label = paste("Label", 1:15), 57#' group = sample(LETTERS[1:3], 15, replace = TRUE)) 58#' 59#' edges <- data.frame(from = trunc(runif(15)*(15-1))+1, 60#' to = trunc(runif(15)*(15-1))+1) 61#' 62#' ################### 63#' # highlight nearest 64#' ################### 65#' 66#' visNetwork(nodes, edges) %>% visOptions(highlightNearest = TRUE) 67#' visNetwork(nodes, edges) %>% visOptions(highlightNearest = list(enabled = TRUE, degree = 2)) 68#' 69#' # also when hover a node ? 70#' visNetwork(nodes, edges) %>% visOptions(highlightNearest = list(enabled = TRUE, hover = TRUE)) 71#' 72#' # don't show nodes/edges 73#' visNetwork(nodes, edges) %>% visOptions(highlightNearest = list(enabled = TRUE, 74#' hover = TRUE, hideColor = 'rgba(200,200,200,0)')) 75#' 76#' # Using hierarchical information 77#' nodes = data.frame(id = 1:6, level = c(1, 2, 3, 3, 4, 2)) 78#' edges = data.frame(from = c(1, 2, 2, 4, 6), to = c(2, 3, 4, 5, 4)) 79#' 80#' visNetwork(nodes, edges) %>% visHierarchicalLayout() %>% visEdges(arrows = "to") %>% 81#' visOptions(highlightNearest = list(enabled = TRUE, algorithm = "hierarchical")) 82#' 83#' visNetwork(nodes, edges) %>% visHierarchicalLayout() %>% visEdges(arrows = "to") %>% 84#' visOptions(highlightNearest = list(enabled = TRUE, algorithm = "hierarchical", 85#' degree = list(from = 0, to = 2))) 86#' 87#' ########################## 88#' # nodesIdSelection 89#' ########################## 90#' 91#' visNetwork(nodes, edges) %>% 92#' visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE) 93#' 94#' # add a default selected node ? 95#' visNetwork(nodes, edges) %>% 96#' visOptions(highlightNearest = TRUE, 97#' nodesIdSelection = list(enabled = TRUE, selected = "1")) 98#' 99#' # subset on id values & don't use labels ? 100#' visNetwork(nodes, edges) %>% 101#' visOptions(highlightNearest = TRUE, 102#' nodesIdSelection = list(enabled = TRUE, 103#' selected = "2", values = c(2:10), useLabels = FALSE)) 104#' 105#' # some style 106#' visNetwork(nodes, edges) %>% 107#' visOptions(highlightNearest = TRUE, 108#' nodesIdSelection = list(enabled = TRUE, style = 'width: 200px; height: 26px; 109#' background: #f8f8f8; 110#' color: darkblue; 111#' border:none; 112#' outline:none;')) 113#' 114#' ########################## 115#' # collapse 116#' ########################## 117#' 118#' nodes <- data.frame(id = 1:15, label = paste("Label", 1:15), 119#' group = sample(LETTERS[1:3], 15, replace = TRUE)) 120#' 121#' edges <- data.frame(from = trunc(runif(15)*(15-1))+1, 122#' to = trunc(runif(15)*(15-1))+1) 123#' 124#' # keeping all parent node attributes 125#' visNetwork(nodes, edges) %>% visEdges(arrows = "to") %>% 126#' visOptions(collapse = TRUE) 127#' 128#' # setting some properties 129#' visNetwork(nodes, edges) %>% visEdges(arrows = "to") %>% 130#' visOptions(collapse = list(enabled = TRUE, clusterOptions = list(shape = "square"))) 131#' 132#' # enable / disable open cluster (proxy only) : 133#' # visEvents(type = "off", doubleClick = "networkOpenCluster") 134#' # visEvents(type = "on", doubleClick = "networkOpenCluster") 135#' 136#' ########################## 137#' # selectedBy 138#' ########################## 139#' nodes <- data.frame(id = 1:15, label = paste("Label", 1:15), 140#' group = sample(LETTERS[1:3], 15, replace = TRUE)) 141#' 142#' edges <- data.frame(from = trunc(runif(15)*(15-1))+1, 143#' to = trunc(runif(15)*(15-1))+1) 144#' 145#' visNetwork(nodes, edges) %>% 146#' visOptions(selectedBy = "group") 147#' 148#' # add a default value ? 149#' visNetwork(nodes, edges) %>% 150#' visOptions(selectedBy = list(variable = "group", selected = "A")) 151#' 152#' # subset on values ? 153#' visNetwork(nodes, edges) %>% 154#' visOptions(selectedBy = list(variable = "group", 155#' selected = "C", 156#' values = c("A", "C"))) 157#' 158#' # highlight also 159#' visNetwork(nodes, edges) %>% 160#' visOptions(selectedBy = list(variable = "group", 161#' highlight = TRUE), highlightNearest = TRUE) 162#' 163#' # add some style 164#' visNetwork(nodes, edges) %>% 165#' visOptions(selectedBy = list(variable = "group", style = 'width: 200px; height: 26px; 166#' background: #f8f8f8; 167#' color: darkblue; 168#' border:none; 169#' outline:none;')) 170#' 171#' # can also be on new column 172#' nodes$sample <- sample(c("sample 1", "sample 2"), nrow(nodes), replace = TRUE) 173#' visNetwork(nodes, edges) %>% 174#' visOptions(selectedBy = "sample") 175#' 176#' # and with multiple groups ? 177#' nodes$group <- sample(c("group 1", "group 2", "group 1, group 2, group 3"), 178#' nrow(nodes), replace = TRUE) 179#' 180#' visNetwork(nodes, edges) %>% 181#' visOptions(selectedBy = list(variable = "group", multiple = TRUE)) 182#' 183#' ########################## 184#' # manipulation 185#' ########################## 186#' 187#'visNetwork(nodes, edges) %>% 188#' visOptions(manipulation = TRUE) 189#' 190#'visNetwork(nodes, edges) %>% 191#' visOptions(manipulation = list(enabled = TRUE, addNode = FALSE, addEdge = FALSE)) 192#' 193#'visNetwork(nodes, edges) %>% 194#' visOptions(manipulation = list(enabled = TRUE, deleteNode = FALSE, deleteEdge = FALSE)) 195#' 196#'visNetwork(nodes, edges) %>% 197#' visOptions(manipulation = list(enabled = TRUE, editNode = FALSE, editEdge = FALSE)) 198#' 199#' # choose columns to edit 200#' visNetwork(nodes, edges) %>% 201#' visOptions(manipulation = list(enabled = TRUE, 202#' editEdgeCols = c("label"), 203#' editNodeCols = c("id", "label", "title", "size"), 204#' addNodeCols = c("label", "group"))) 205#' 206#' # choose columns to edit + input html type (text, number, ...) 207#' # https://www.w3schools.com/tags/att_input_type.asp 208#' visNetwork(nodes, edges) %>% 209#' visOptions(manipulation = list(enabled = TRUE, 210#' editEdgeCols = c("label"), 211#' editNodeCols = list( 212#' "text" = c("id", "label", "title"), 213#' "number" = c("size") 214#' ), 215#' addNodeCols = c("label", "group"))) 216#'visNetwork(nodes, edges) %>% 217#' visOptions(manipulation = list(enabled = TRUE, 218#' editEdge = htmlwidgets::JS("function(data, callback) { 219#' callback(data); 220#' console.info('edit edge') 221#' }") 222#' ) 223#' ) 224#' ########################## 225#' # collapse 226#' ########################## 227#' visNetwork(nodes, edges) %>% 228#' visEdges(arrows = "to") %>% 229#' visOptions(collapse = list(enabled = TRUE, 230#' clusterOptions = list(shape = "square"))) 231#' 232#'@seealso \link{visNodes} for nodes options, \link{visEdges} for edges options, \link{visGroups} for groups options, 233#'\link{visLegend} for adding legend, \link{visOptions} for custom option, \link{visLayout} & \link{visHierarchicalLayout} for layout, 234#'\link{visPhysics} for control physics, \link{visInteraction} for interaction, \link{visNetworkProxy} & \link{visFocus} & \link{visFit} for animation within shiny, 235#'\link{visDocumentation}, \link{visEvents}, \link{visConfigure} ... 236#' 237#'@export 238#'@references See online documentation \url{http://datastorm-open.github.io/visNetwork/} 239visOptions <- function(graph, 240 width = NULL, 241 height = NULL, 242 highlightNearest = FALSE, 243 nodesIdSelection = FALSE, 244 selectedBy = NULL, 245 collapse = FALSE, 246 autoResize = NULL, 247 clickToUse = NULL, 248 manipulation = NULL){ 249 250 if(!any(class(graph) %in% c("visNetwork", "visNetwork_Proxy"))){ 251 stop("graph must be a visNetwork or a visNetworkProxy object") 252 } 253 254 options <- list() 255 256 options$autoResize <- autoResize 257 options$clickToUse <- clickToUse 258 259 if(is.null(manipulation)){ 260 options$manipulation <- list(enabled = FALSE) 261 }else{ 262 263 graph$x$opts_manipulation$datacss <- paste(readLines(system.file("htmlwidgets/lib/css/dataManipulation.css", package = "visNetwork"), warn = FALSE), collapse = "\n") 264 265 if(is.logical(manipulation)){ 266 options$manipulation <- list(enabled = manipulation) 267 268 } else if(is.list(manipulation)){ 269 options$manipulation <- manipulation 270 } else { 271 stop("Invalid 'manipulation' argument. logical or list") 272 } 273 274 if(!"addNodeCols" %in% names(manipulation)){ 275 graph$x$opts_manipulation$addNodeCols <- c("id", "label") 276 addNodeCols_html_input_type <- rep("text", 2) 277 } else { 278 if(is.list(manipulation$addNodeCols)){ 279 graph$x$opts_manipulation$addNodeCols <- unname(do.call("c", manipulation$addNodeCols)) 280 addNodeCols_html_input_type <- rep(names(manipulation$addNodeCols), sapply(manipulation$addNodeCols, length)) 281 } else if(is.vector(manipulation$addNodeCols)){ 282 graph$x$opts_manipulation$addNodeCols <- manipulation$addNodeCols 283 addNodeCols_html_input_type <- rep("text", length(manipulation$addNodeCols)) 284 } 285 options$manipulation$addNodeCols <- NULL 286 } 287 288 if(!"editNodeCols" %in% names(manipulation)){ 289 graph$x$opts_manipulation$editNodeCols <- c("id", "label") 290 editNodeCols_html_input_type <- rep("text", 2) 291 } else { 292 if(is.list(manipulation$editNodeCols)){ 293 graph$x$opts_manipulation$editNodeCols <- unname(do.call("c", manipulation$editNodeCols)) 294 editNodeCols_html_input_type <- rep(names(manipulation$editNodeCols), sapply(manipulation$editNodeCols, length)) 295 } else if(is.vector(manipulation$editNodeCols)){ 296 graph$x$opts_manipulation$editNodeCols <- manipulation$editNodeCols 297 editNodeCols_html_input_type <- rep("text", length(manipulation$editNodeCols)) 298 } 299 options$manipulation$editNodeCols <- NULL 300 } 301 302 if("editEdgeCols" %in% names(manipulation) && !is.null(manipulation$editEdgeCols) && length(manipulation$editEdgeCols) > 0){ 303 if(is.list(manipulation$editEdgeCols)){ 304 graph$x$opts_manipulation$editEdgeCols <- unname(do.call("c", manipulation$editEdgeCols)) 305 editEdgeCols_html_input_type <- rep(names(manipulation$editEdgeCols), sapply(manipulation$editEdgeCols, length)) 306 } else if(is.vector(manipulation$editEdgeCols)){ 307 graph$x$opts_manipulation$editEdgeCols <- manipulation$editEdgeCols 308 editEdgeCols_html_input_type <- rep("text", length(manipulation$editEdgeCols)) 309 } 310 options$manipulation$editEdgeCols <- NULL 311 } 312 313 if(length(graph$x$opts_manipulation$addNodeCols) == 1){ 314 graph$x$opts_manipulation$addNodeCols <- list(graph$x$opts_manipulation$addNodeCols) 315 } 316 if(length(graph$x$opts_manipulation$editNodeCols) == 1){ 317 graph$x$opts_manipulation$editNodeCols <- list(graph$x$opts_manipulation$editNodeCols) 318 } 319 if(length(graph$x$opts_manipulation$editEdgeCols) == 1){ 320 graph$x$opts_manipulation$editEdgeCols <- list(graph$x$opts_manipulation$editEdgeCols) 321 } 322 323 if(!is.null(graph$x$opts_manipulation$addNodeCols)){ 324 graph$x$opts_manipulation$tab_add_node <- build_manipulation_table( 325 col = graph$x$opts_manipulation$addNodeCols, 326 type = addNodeCols_html_input_type, 327 id = "addnode") 328 } 329 330 if(!is.null(graph$x$opts_manipulation$editNodeCols)){ 331 graph$x$opts_manipulation$tab_edit_node <- build_manipulation_table( 332 col = graph$x$opts_manipulation$editNodeCols, 333 type = editNodeCols_html_input_type, 334 id = "editnode") 335 } 336 337 if(!is.null(graph$x$opts_manipulation$editEdgeCols)){ 338 graph$x$opts_manipulation$tab_edit_edge <- build_manipulation_table( 339 col = graph$x$opts_manipulation$editEdgeCols, 340 type = editEdgeCols_html_input_type, 341 id = "editedge") 342 } 343 344 } 345 346 options$height <- height 347 options$width <- width 348 349 if(!"nodes"%in%names(graph$x) && any(class(graph) %in% "visNetwork")){ 350 highlight <- list(enabled = FALSE) 351 idselection <- list(enabled = FALSE) 352 byselection <- list(enabled = FALSE) 353 list_collapse <- list(enabled = FALSE, fit = FALSE, resetHighlight = TRUE, 354 keepCoord = TRUE, labelSuffix = "(cluster)") 355 }else{ 356 ############################# 357 # collapse 358 ############################# 359 list_collapse <- list(enabled = FALSE, fit = FALSE, resetHighlight = TRUE, 360 clusterOptions = NULL, keepCoord = TRUE, labelSuffix = "(cluster)") 361 if(is.list(collapse)){ 362 if(any(!names(collapse)%in%c("enabled", "fit", "resetHighlight", "clusterOptions", "keepCoord", "labelSuffix"))){ 363 stop("Invalid 'collapse' argument") 364 } 365 366 if("enabled"%in%names(collapse)){ 367 stopifnot(is.logical(collapse$enabled)) 368 list_collapse$enabled <- collapse$enabled 369 } 370 if("fit"%in%names(collapse)){ 371 stopifnot(is.logical(collapse$fit)) 372 list_collapse$fit <- collapse$fit 373 } 374 if("resetHighlight"%in%names(collapse)){ 375 stopifnot(is.logical(collapse$resetHighlight)) 376 list_collapse$resetHighlight <- collapse$resetHighlight 377 } 378 if("keepCoord"%in%names(collapse)){ 379 stopifnot(is.logical(collapse$keepCoord)) 380 list_collapse$keepCoord <- collapse$keepCoord 381 } 382 if("labelSuffix"%in%names(collapse)){ 383 stopifnot(is.character(collapse$labelSuffix)) 384 list_collapse$labelSuffix <- collapse$labelSuffix 385 } 386 if("clusterOptions"%in%names(collapse)){ 387 stopifnot(is.list(collapse$clusterOptions)) 388 list_collapse$clusterOptions <- collapse$clusterOptions 389 } 390 } else { 391 stopifnot(is.logical(collapse)) 392 list_collapse$enabled <- collapse 393 } 394 395 ############################# 396 # highlightNearest 397 ############################# 398 highlight <- list(enabled = FALSE, hoverNearest = FALSE, degree = 1, algorithm = "all", hideColor = 'rgba(200,200,200,0.5)', labelOnly = TRUE) 399 if(is.list(highlightNearest)){ 400 if(any(!names(highlightNearest)%in%c("enabled", "degree", "hover", "algorithm", "hideColor", "labelOnly"))){ 401 stop("Invalid 'highlightNearest' argument") 402 } 403 404 if("algorithm"%in%names(highlightNearest)){ 405 stopifnot(highlightNearest$algorithm %in% c("all", "hierarchical")) 406 highlight$algorithm <- highlightNearest$algorithm 407 } 408 409 if("hideColor"%in%names(highlightNearest)){ 410 highlight$hideColor <- highlightNearest$hideColor 411 } 412 413 if("degree"%in%names(highlightNearest)){ 414 highlight$degree <- highlightNearest$degree 415 } 416 417 if(highlight$algorithm %in% "hierarchical"){ 418 if(is.list(highlight$degree)){ 419 stopifnot(all(names(highlight$degree) %in% c("from", "to"))) 420 }else{ 421 highlight$degree <- list(from = highlight$degree, to = highlight$degree) 422 } 423 } 424 425 if("labelOnly"%in%names(highlightNearest)){ 426 stopifnot(is.logical(highlightNearest$labelOnly)) 427 highlight$labelOnly <- highlightNearest$labelOnly 428 } 429 430 if("hover"%in%names(highlightNearest)){ 431 stopifnot(is.logical(highlightNearest$hover)) 432 highlight$hoverNearest <- highlightNearest$hover 433 } 434 435 if("enabled"%in%names(highlightNearest)){ 436 stopifnot(is.logical(highlightNearest$enabled)) 437 highlight$enabled <- highlightNearest$enabled 438 } 439 440 } else { 441 stopifnot(is.logical(highlightNearest)) 442 highlight$enabled <- highlightNearest 443 } 444 445 if(highlight$enabled && any(class(graph) %in% "visNetwork")){ 446 if(!"label"%in%colnames(graph$x$nodes)){ 447 if(is.data.frame(graph$x$nodes)){ 448 graph$x$nodes$label <- as.character(graph$x$nodes$id) 449 } else if(is.list(graph$x$nodes)){ 450 ctrl <- lapply(1:length(graph$x$nodes), function(x){ 451 graph$x$nodes[[x]]$label <<- as.character(graph$x$nodes[[x]]$id) 452 }) 453 } 454 } 455 # if(!"group"%in%colnames(graph$x$nodes)){ 456 # if(is.data.frame(graph$x$nodes)){ 457 # graph$x$nodes$group <- 1 458 # } else if(is.list(graph$x$nodes)){ 459 # ctrl <- lapply(1:length(graph$x$nodes), function(x){ 460 # graph$x$nodes[[x]]$group <<- 1 461 # }) 462 # } 463 # } 464 } 465 466 ############################# 467 # nodesIdSelection 468 ############################# 469 idselection <- list(enabled = FALSE, style = 'width: 150px; height: 26px', useLabels = TRUE, main = "Select by id") 470 if(is.list(nodesIdSelection)){ 471 if(any(!names(nodesIdSelection)%in%c("enabled", "selected", "style", "values", "useLabels", "main"))){ 472 stop("Invalid 'nodesIdSelection' argument. List can have 'enabled', 'selected', 'style', 'values', 'useLabels', 'main'") 473 } 474 if("selected"%in%names(nodesIdSelection)){ 475 if(any(class(graph) %in% "visNetwork")){ 476 if(!nodesIdSelection$selected%in%graph$x$nodes$id ){ 477 stop(nodesIdSelection$selected, " not in data. nodesIdSelection$selected must be valid.") 478 } 479 } 480 idselection$selected <- nodesIdSelection$selected 481 } 482 if("enabled"%in%names(nodesIdSelection)){ 483 idselection$enabled <- nodesIdSelection$enabled 484 }else{ 485 idselection$enabled <- TRUE 486 } 487 488 if("main"%in%names(nodesIdSelection)){ 489 idselection$main <- nodesIdSelection$main 490 } 491 492 if("useLabels"%in%names(nodesIdSelection)){ 493 idselection$useLabels <- nodesIdSelection$useLabels 494 }else if(any(class(graph) %in% "visNetwork_Proxy")){ 495 idselection$useLabels <- NULL 496 } 497 498 if("style"%in%names(nodesIdSelection)){ 499 idselection$style <- nodesIdSelection$style 500 }else if(any(class(graph) %in% "visNetwork_Proxy")){ 501 idselection$style <- NULL 502 } 503 504 }else if(is.logical(nodesIdSelection)){ 505 idselection$enabled <- nodesIdSelection 506 if(any(class(graph) %in% "visNetwork_Proxy")){ 507 idselection$useLabels <- NULL 508 idselection$style <- NULL 509 } 510 }else{ 511 stop("Invalid 'nodesIdSelection' argument") 512 } 513 514 if(idselection$enabled){ 515 if("values"%in%names(nodesIdSelection)){ 516 idselection$values <- nodesIdSelection$values 517 if(length(idselection$values) == 1){ 518 idselection$values <- list(idselection$values) 519 } 520 if("selected"%in%names(nodesIdSelection)){ 521 if(!idselection$selected%in%idselection$values){ 522 stop(idselection$selected, " not in data/selection. nodesIdSelection$selected must be a valid value.") 523 } 524 } 525 } 526 } 527 528 ############################# 529 # selectedBy 530 ############################# 531 byselection <- list(enabled = FALSE, style = 'width: 150px; height: 26px', multiple = FALSE, 532 hideColor = 'rgba(200,200,200,0.5)', highlight = FALSE) 533 534 if(!is.null(selectedBy)){ 535 if(is.list(selectedBy)){ 536 if(any(!names(selectedBy)%in%c("variable", "selected", "style", "values", "multiple", "hideColor", "main", "sort", "highlight"))){ 537 stop("Invalid 'selectedBy' argument. List can have 'variable', 'selected', 'style', 'values', 'multiple', 'hideColor', 'main', 'sort', 'highlight'") 538 } 539 if("selected"%in%names(selectedBy)){ 540 byselection$selected <- as.character(selectedBy$selected) 541 } 542 543 if("hideColor"%in%names(selectedBy)){ 544 byselection$hideColor <- selectedBy$hideColor 545 } 546 547 if("highlight"%in%names(selectedBy)){ 548 byselection$highlight <- selectedBy$highlight 549 } 550 551 if(!"variable"%in%names(selectedBy)){ 552 stop("'selectedBy' need at least 'variable' information") 553 } 554 555 byselection$variable <- selectedBy$variable 556 557 if("main" %in% names(selectedBy)){ 558 byselection$main <- selectedBy$main 559 } else { 560 byselection$main <- paste0("Select by ", selectedBy$variable) 561 } 562 563 if("style"%in%names(selectedBy)){ 564 byselection$style <- selectedBy$style 565 }else if(any(class(graph) %in% "visNetwork_Proxy")){ 566 byselection$style <- NULL 567 } 568 569 if("multiple"%in%names(selectedBy)){ 570 byselection$multiple <- selectedBy$multiple 571 }else if(any(class(graph) %in% "visNetwork_Proxy")){ 572 byselection$multiple <- NULL 573 } 574 575 }else if(is.character(selectedBy)){ 576 byselection$variable <- selectedBy 577 578 byselection$main <- paste0("Select by ", selectedBy) 579 580 if(any(class(graph) %in% "visNetwork_Proxy")){ 581 byselection$style <- NULL 582 byselection$multiple <- NULL 583 } 584 585 }else{ 586 stop("Invalid 'selectedBy' argument. Must a 'character' or a 'list'") 587 } 588 589 if(any(class(graph) %in% "visNetwork_Proxy")){ 590 byselection$enabled <- TRUE 591 592 if("values"%in%names(selectedBy)){ 593 if(length(selectedBy$values) > 1){ 594 byselection$values <- selectedBy$values 595 } else { 596 byselection$values <- list(selectedBy$values) 597 } 598 } 599 600 if("selected"%in%names(byselection)){ 601 byselection$selected <- byselection$selected 602 } 603 }else{ 604 if(!byselection$variable%in%colnames(graph$x$nodes)){ 605 warning("Can't find '", byselection$variable, "' in node data.frame") 606 }else{ 607 byselection$enabled <- TRUE 608 byselection$values <- unique(graph$x$nodes[, byselection$variable]) 609 if(byselection$multiple){ 610 byselection$values <- unique(gsub("^[[:space:]]*|[[:space:]]*$", "", 611 do.call("c",strsplit(as.character(byselection$values), split = ",")))) 612 } 613 if(any(c("integer", "numeric") %in% class(graph$x$nodes[, byselection$variable]))){ 614 byselection$values <- byselection$values 615 }else{ 616 byselection$values <- as.character(byselection$values) 617 } 618 619 if("sort"%in%names(selectedBy)){ 620 if(selectedBy$sort){ 621 byselection$values <- sort(byselection$values) 622 } 623 } else { 624 byselection$values <- sort(byselection$values) 625 } 626 627 if("values"%in%names(selectedBy)){ 628 # byselection$values <- intersect(byselection$values, selectedBy$values) 629 byselection$values <- selectedBy$values 630 } 631 632 if("values"%in%names(byselection)){ 633 if(length(byselection$values) == 1){ 634 byselection$values <- list(byselection$values) 635 } 636 } 637 638 if("selected"%in%names(byselection)){ 639 if(!byselection$selected%in%byselection$values){ 640 stop(byselection$selected, " not in data/selection. selectedBy$selected must be a valid value.") 641 } 642 byselection$selected <- byselection$selected 643 } 644 645 if(!"label"%in%colnames(graph$x$nodes)){ 646 if(is.data.frame(graph$x$nodes)){ 647 graph$x$nodes$label <- "" 648 } else if(is.list(graph$x$nodes)){ 649 ctrl <- lapply(1:length(graph$x$nodes), function(x){ 650 graph$x$nodes[[x]]$label <<- "" 651 }) 652 } 653 } 654 # if(!"group"%in%colnames(graph$x$nodes)){ 655 # if(is.data.frame(graph$x$nodes)){ 656 # graph$x$nodes$group <- 1 657 # } else if(is.list(graph$x$nodes)){ 658 # ctrl <- lapply(1:length(graph$x$nodes), function(x){ 659 # graph$x$nodes[[x]]$group <<- 1 660 # }) 661 # } 662 # } 663 } 664 } 665 } 666 } 667 668 # x <- list(highlight = highlightNearest, hoverNearest = hoverNearest, degree = degree, 669 # idselection = idselection, byselection = byselection) 670 671 x <- list(highlight = highlight, idselection = idselection, byselection = byselection, collapse = list_collapse) 672 673 if(highlight$hoverNearest){ 674 graph <- visInteraction(graph, hover = TRUE) 675 } 676 677 if(any(class(graph) %in% "visNetwork_Proxy")){ 678 679 data <- list(id = graph$id, options = options) 680 graph$session$sendCustomMessage("visShinyOptions",data) 681 682 if(missing(highlightNearest)){ 683 x$highlight <- NULL 684 } 685 if(missing(nodesIdSelection)){ 686 x$idselection <- NULL 687 } 688 if(missing(selectedBy)){ 689 x$byselection <- NULL 690 } 691 if(missing(collapse)){ 692 x$collapse <- NULL 693 } 694 695 data <- list(id = graph$id, options = x) 696 graph$session$sendCustomMessage("visShinyCustomOptions",data) 697 698 }else{ 699 graph$x <- mergeLists(graph$x, x) 700 graph$x$options <- mergeLists(graph$x$options, options) 701 } 702 graph 703} 704 705 706build_manipulation_table <- function(col, type, id = "node"){ 707 708 if(length(col) > 0){ 709 table <- paste0('<span id="', id, '-operation" class = "operation">node</span> <br><table style="margin:auto;">') 710 711 for(i in 1:length(col)){ 712 713 add <- paste0('<tr><td>', col[i], '</td><td><input id="', id, "-", col[i], '" type= "', type[i], '" value="new value"></td></tr>') 714 table <- paste0(table, add) 715 } 716 717 table <- paste0(table, '</table><input type="button" value="save" id="', id, '-saveButton"></button><input type="button" value="cancel" id="', id, '-cancelButton"></button>') 718 } else { 719 table <- "" 720 } 721 722 table 723 724}