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}