1
globalVariables(c("id", "label", "sigmajsdelay", "size"))
2

3
#' Add nodes and edges
4
#'
5
#' Add nodes and edges to a \code{sigmajs} graph.
6
#'
7
#' @param sg An object of class \code{sigmajs}as intatiated by \code{\link{sigmajs}}.
8
#' @param data Data.frame (or list) of nodes or edges.
9
#' @param ... Any column name, see details.
10
#'
11
#' @details 
12
#' \strong{nodes}:
13
#' Must pass \code{id} (\emph{unique}), \code{size} and \code{color}. If \code{color} is omitted than specify 
14
#' \code{defaultNodeColor} in \code{\link{sg_settings}} otherwise nodes will be transparent. Ideally nodes 
15
#' also include \code{x} and \code{y}, 
16
#' if they are not passed then they are randomly generated, you can either get these coordinates with \code{\link{sg_get_layout}}
17
#' or \code{\link{sg_layout}}.
18
#' 
19
#' \strong{edges}:
20
#' Each edge also must include a unique \code{id} as well as two columns named \code{source} and \code{target} which correspond to
21
#' node \code{id}s. If an edges goes from or to an \code{id} that is not in node \code{id}.
22
#' 
23
#' @note \code{node} also takes a \link[crosstalk]{SharedData}.
24
#'
25
#' @section Functions:
26
#' \itemize{
27
#'		\item{Functions ending in \code{2} take a list like the original sigma.js JSON.}
28
#'		\item{Other functions take the arguments described above.}
29
#' }
30
#'
31
#' @examples
32
#' nodes <- sg_make_nodes()
33
#' edges <- sg_make_edges(nodes)
34
#'
35
#' sg <- sigmajs() %>%
36
#'   sg_nodes(nodes, id, label, size, color) %>%
37
#'   sg_edges(edges, id, source, target) 
38
#'   
39
#' sg # no layout
40
#' 
41
#' # layout
42
#' sg %>% 
43
#'   sg_layout()
44
#'
45
#' # directed graph
46
#' edges$type <- "arrow" # directed
47
#' 
48
#' # omit color
49
#' sigmajs() %>%
50
#'   sg_nodes(nodes, id, label, size) %>%
51
#'   sg_edges(edges, id, source, target, type) %>% 
52
#'   sg_settings(defaultNodeColor = "#141414")
53
#'   
54
#' # all source and target are present in node ids
55
#' all(c(edges$source, edges$target) %in% nodes$id)
56
#' 
57
#' @return A modified version of the \code{sg} object.
58
#'
59
#' @rdname graph
60
#' @export
61
sg_nodes <- function(sg, data, ...) {
62

63 1
	if (missing(sg) || missing(data))
64 1
		stop("missing sg or data", call. = FALSE)
65
  
66 1
  .test_sg(sg)
67
  
68
  # crosstalk
69 1
  if (crosstalk::is.SharedData(data)) {
70 1
    df <- data$origData()
71
    
72
    # crosstalk settings
73 1
    sg$x$crosstalk$crosstalk_key <- data$key()
74 1
    sg$x$crosstalk$crosstalk_group <- data$groupName()
75
  } else {
76 1
    df <- data
77
  }
78

79 1
  nodes <- .build_data(df, ...) %>% 
80 1
    .check_ids() %>% 
81 1
    .check_x_y() %>% 
82 1
    .as_list()
83

84 1
  sg$x$data <- append(sg$x$data, list(nodes = nodes))
85
  
86 1
  sg
87
}
88

89
#' @rdname graph
90
#' @export
91
sg_edges <- function(sg, data, ...) {
92

93 1
	if (missing(sg) || missing(data))
94 1
		stop("missing sg or data", call. = FALSE)
95

96 1
  .test_sg(sg)
97

98 1
  edges <- .build_data(data, ...) %>% 
99 1
    .check_ids() %>% 
100 1
    .as_list()
101

102 1
  sg$x$data <- append(sg$x$data, list(edges = edges))
103 1
  sg
104
}
105

106
#' @rdname graph
107
#' @export
108
sg_edges2 <- function(sg, data) {
109

110 1
	if (missing(sg) || missing(data))
111 1
		stop("missing sg or data", call. = FALSE)
112

113 1
  .test_sg(sg)
114

115 1
	sg$x$data <- append(sg$x$data, list(edges = data))
116 1
	sg
117
}
118

119
#' @rdname graph
120
#' @export
121
sg_nodes2 <- function(sg, data) {
122

123 1
	if (missing(sg) || missing(data))
124 1
		stop("missing sg or data", call. = FALSE)
125

126 1
  .test_sg(sg)
127

128 1
	sg$x$data <- append(sg$x$data, list(nodes = data))
129 1
	sg
130
}
131

132
#' Add nodes and edges
133
#' 
134
#' Add nodes or edges.
135
#' 
136
#' @inheritParams sg_nodes
137
#' @param delay Column name containing delay in milliseconds.
138
#' @param cumsum Whether to compute the cumulative sum of the delay.
139
#' @param refresh Whether to refresh the graph after node is dropped, required to take effect, if you are running force the algorithm is killed and restarted at every iteration.
140
#' 
141
#' @details The delay helps for build dynamic visualisations where nodes and edges do not appear all at the same time.
142
#' How the delay works depends on the \code{cumsum} parameter. if \code{TRUE} the function computes the cumulative sum
143
#' of the delay to effectively add each row one after the other: delay is thus applied at each row (number of seconds to wait
144
#' before the row is added *since the previous row*). If \code{FALSE} this is the number of milliseconds to wait before the node or
145
#' edge is added to the visualisation; \code{delay} is used as passed to the function.
146
#' 
147
#' @examples 
148
#' # initial nodes
149
#' nodes <- sg_make_nodes()
150
#' 
151
#' # additional nodes
152
#' nodes2 <- sg_make_nodes()
153
#' nodes2$id <- as.character(seq(11, 20))
154
#' 
155
#' # add delay
156
#' nodes2$delay <- runif(nrow(nodes2), 500, 1000)
157
#' 
158
#' sigmajs() %>%
159
#'   sg_nodes(nodes, id, label, size, color) %>%
160
#'   sg_add_nodes(nodes2, delay, id, label, size, color)
161
#'   
162
#' edges <- sg_make_edges(nodes, 25)
163
#' edges$delay <- runif(nrow(edges), 100, 2000)
164
#' 
165
#' sigmajs() %>%
166
#'   sg_force_start() %>%
167
#'   sg_nodes(nodes, id, label, size, color) %>% 
168
#'   sg_add_edges(edges, delay, id, source, target, cumsum = FALSE) %>%
169
#'   sg_force_stop(2300) # stop after all edges added
170
#' 
171
#' @return A modified version of the \code{sg} object.
172
#' 
173
#' @rdname add_static
174
#' @export
175
sg_add_nodes <- function(sg, data, delay, ..., cumsum = TRUE) {
176
  
177 1
  if (missing(data) || missing(delay) || missing(sg))
178 1
    stop("must pass sg, data and delay", call. = FALSE)
179
  
180 1
  .test_sg(sg)
181
  
182
  # crosstalk
183 1
  if (crosstalk::is.SharedData(data)) {
184 0
    df <- data$origData()
185
    
186
    # crosstalk settings
187 0
    sg$x$crosstalk$crosstalk_key <- data$key()
188 0
    sg$x$crosstalk$crosstalk_group <- data$groupName()
189
  } else {
190 1
    df <- data
191
  }
192
  
193 1
  delay_col <- eval(substitute(delay), df) # subset delay
194 1
  if (isTRUE(cumsum))
195 1
    delay_col <- cumsum(delay_col) # cumul for setTimeout
196
  
197 1
  delay_table <- dplyr::tibble(sigmajsdelay = delay_col) # build delay tibble
198
  
199
  # build data
200 1
  nodes <- .build_data(df, ...) %>%
201 1
    dplyr::bind_cols(delay_table) %>% # bind delay
202 1
    .check_ids() %>%
203 1
    .check_x_y() %>%
204 1
    dplyr::mutate(id = as.character(id)) %>% 
205 1
    dplyr::arrange(sigmajsdelay) %>% 
206 1
    .as_list()
207
  
208 1
  sg$x$addNodesDelay <- append(sg$x$addNodesDelay, nodes)
209
  
210 1
  sg
211
} 
212

213
#' @rdname add_static
214
#' @export
215
sg_add_edges <- function(sg, data, delay, ..., cumsum = TRUE, refresh = FALSE) {
216
  
217 1
  if (missing(data) || missing(delay) || missing(sg))
218 1
    stop("must pass sg, data and delay", call. = FALSE)
219
  
220 1
  .test_sg(sg)
221
  
222 1
  delay_col <- eval(substitute(delay), data) # subset delay
223 1
  if (isTRUE(cumsum))
224 1
    delay_col <- cumsum(delay_col) # cumul for setTimeout
225
  
226 1
  delay_table <- dplyr::tibble(sigmajsdelay = delay_col) # build delay tibble
227
  
228
  # build data
229 1
  nodes <- .build_data(data, ...) %>%
230 1
    dplyr::bind_cols(delay_table) %>% # bind delay
231 1
    .check_ids() %>%
232 1
    dplyr::mutate(id = as.character(id)) %>% 
233 1
    dplyr::arrange(sigmajsdelay) %>% 
234 1
    .as_list()
235
  
236 1
  sg$x$addEdgesDelay <- append(sg$x$addEdgesDelay, list(data = nodes, refresh = refresh))
237 1
  sg
238
} 
239

240

241
#' Drop
242
#' 
243
#' Drop nodes or edges.
244
#' 
245
#' @inheritParams sg_nodes
246
#' @param delay Column name containing delay in milliseconds.
247
#' @param ids Ids of elements to drop.
248
#' @param cumsum Whether to compute the cumulative sum of the delay.
249
#' @param refresh Whether to refresh the graph after node is dropped, required to take effect, if you are running force the algorithm is killed and restarted at every iteration.
250
#' 
251
#' @details The delay helps for build dynamic visualisations where nodes and edges do not disappear all at the same time.
252
#' How the delay works depends on the \code{cumsum} parameter. if \code{TRUE} the function computes the cumulative sum
253
#' of the delay to effectively drop each row one after the other: delay is thus applied at each row (number of seconds to wait
254
#' before the row is dropped *since the previous row*). If \code{FALSE} this is the number of milliseconds to wait before the node or
255
#' edge is dropped to the visualisation; \code{delay} is used as passed to the function.
256
#' 
257
#' @examples 
258
#' nodes <- sg_make_nodes(75)
259
#' 
260
#' # nodes to drop
261
#' nodes2 <- nodes[sample(nrow(nodes), 50), ]
262
#' nodes2$delay <- runif(nrow(nodes2), 1000, 3000)
263
#' 
264
#' sigmajs() %>% 
265
#'   sg_nodes(nodes, id, size, color) %>% 
266
#'   sg_drop_nodes(nodes2, id, delay, cumsum = FALSE)
267
#' 
268
#' @return A modified version of the \code{sg} object.
269
#' 
270
#' @rdname drop_static 
271
#' @export
272
sg_drop_nodes <- function(sg, data, ids, delay, cumsum = TRUE) {
273
  
274 1
  if (missing(data) || missing(sg) || missing(ids) || missing(delay))
275 0
    stop("must pass sg, data, ids and delay", call. = FALSE)
276
  
277 1
  .test_sg(sg)
278
  
279 1
  delay_col <- eval(substitute(delay), data) # subset delay
280 1
  if (isTRUE(cumsum))
281 0
    delay_col <- cumsum(delay_col) # cumul for setTimeout
282
  
283 1
  ids <- eval(substitute(ids), data) # subset ids
284
  
285 1
  to_drop <- dplyr::tibble(
286 1
    id = as.character(ids),
287 1
    sigmajsdelay = delay_col
288
  ) %>%
289 1
    dplyr::arrange(sigmajsdelay) %>% 
290 1
    .as_list()
291
  
292 1
  sg$x$dropNodesDelay <- append(sg$x$dropNodes, to_drop)
293 1
  sg
294
}
295

296
#' @rdname drop_static 
297
#' @export
298
sg_drop_edges <- function(sg, data, ids, delay, cumsum = TRUE, refresh = FALSE) {
299
  
300 1
  if (missing(data) || missing(sg) || missing(ids) || missing(delay))
301 0
    stop("must pass sg, data, ids and delay", call. = FALSE)
302
  
303 1
  .test_sg(sg)
304
  
305 1
  delay_col <- eval(substitute(delay), data) # subset delay
306 1
  if (isTRUE(cumsum))
307 1
    delay_col <- cumsum(delay_col) # cumul for setTimeout
308
  
309 1
  ids <- eval(substitute(ids), data) # subset ids
310

311 1
  to_drop <- dplyr::tibble(
312 1
    id = as.character(ids),
313 1
    sigmajsdelay = delay_col
314
  ) %>%
315 1
    dplyr::arrange(sigmajsdelay) %>% 
316 1
    .as_list()
317
  
318 1
  sg$x$dropEdgesDelay <- list(data = to_drop, refresh = refresh)
319 1
  sg
320
}
321

322
#' Read 
323
#' 
324
#' Read nodes and edges into your graph, with or without a delay.
325
#' 
326
#' @inheritParams sg_nodes
327
#' @param delay Column name containing delay in milliseconds.
328
#' @param refresh Whether to refresh the \code{\link{force}} layout.
329
#'
330
#' @section Functions:
331
#' \itemize{
332
#'   \item{\code{sg_read_nodes} read nodes.}
333
#'   \item{\code{sg_read_edges} read edges.}
334
#'   \item{\code{sg_read_exec} send read nodes and edges to JavaScript front end.}
335
#' }
336
#' 
337
#' @examples
338
#' nodes <- sg_make_nodes(50)
339
#'  nodes$batch <- c(
340
#' 	 rep(1000, 25),
341
#' 	 rep(3000, 25)
342
#' 	)
343
#' 
344
#' edges <- data.frame(
345
#'  id = 1:80,
346
#' 	 source = c(
347
#' 	  sample(1:25, 40, replace = TRUE),
348
#' 		sample(1:50, 40, replace = TRUE)
349
#' 	 ),
350
#' 	 target = c(
351
#' 	  sample(1:25, 40, replace = TRUE),
352
#' 		sample(1:50, 40, replace = TRUE)
353
#' 	 ),
354
#' 	 batch = c(
355
#' 	  rep(1000, 40),
356
#' 		rep(3000, 40)
357
#' 	 )
358
#' ) %>% 
359
#'  dplyr::mutate_all(as.character)
360
#' 
361
#' sigmajs() %>% 
362
#'   sg_force_start() %>% 
363
#'   sg_read_nodes(nodes, id, label, color, size, delay = batch) %>% 
364
#'   sg_read_edges(edges, id, source, target, delay = batch) %>% 
365
#' 	 sg_force_stop(4000) %>% 
366
#'   sg_read_exec() %>% 
367
#' 	 sg_button("read_exec", "Add nodes & edges")
368
#' 
369
#' @return A modified version of the \code{sg} object.
370
#' 
371
#' @name read-static
372
#' @export
373
sg_read_nodes <- function(sg, data, ..., delay){
374
  
375 0
  if (missing(sg) || missing(data) || missing(delay))
376 0
    stop("must pass sg, data, and delay", call. = FALSE)
377

378 0
	delay <- deparse(substitute(delay))
379

380 0
  .test_sg(sg)
381

382 0
	nodes <- data %>% 
383 0
		.build_data(..., delay = delay) %>%
384 0
		.check_ids() %>%
385 0
		.check_x_y() %>%
386 0
		split(.[["delay"]]) %>% 
387 0
		purrr::map(.as_list)
388

389 0
  sg$x$read$data$nodes <- nodes
390 0
  return(sg)
391
}
392

393
#' @rdname read-static
394
#' @export
395
sg_read_edges <- function(sg, data, ..., delay){
396
  
397 0
  if (missing(sg) || missing(data) || missing(delay))
398 0
    stop("must pass sg, data, and delay", call. = FALSE)
399

400 0
  .test_sg(sg)
401

402 0
	delay <- deparse(substitute(delay))
403

404 0
	edges <- data %>% 
405 0
		.build_data(..., delay = delay) %>%
406 0
		.check_ids() %>%
407 0
		.check_x_y() %>%
408 0
		split(.[["delay"]]) %>% 
409 0
		purrr::map(.as_list)
410

411 0
  sg$x$read$data$edges <- edges
412 0
  return(sg)
413
}
414

415
#' @rdname read-static
416
#' @export
417
sg_read_exec <- function(sg, refresh = TRUE){
418 0
	.test_sg(sg)
419

420 0
	if(is.null(sg$x$read$data$edges))
421 0
		sg$x$read$data$edges <- list()
422

423 0
	if(is.null(sg$x$read$data$nodes))
424 0
		sg$x$read$data$nodes <- list()
425

426 0
	sg$x$read$data <- sg$x$read$data$nodes %>% 
427 0
		purrr::map2(sg$x$read$data$edges, .grp) %>% 
428 0
		unname()
429

430 0
	sg$x$read$refresh <- refresh
431

432 0
	return(sg)
433
}

Read our documentation on viewing source code .

Loading