R/helpers.R

In sigmajs: Interface to 'Sigma.js' Graph Visualization Library

#' Generate data
#' 
#' Generate nodes and edges.
#'
#' @param n Number of nodes.
#' @param colors Color palette to use.
#' @param nodes Nodes, as generated by \code{sg_make_nodes}.
#' @param ... Any other argument to pass to \link[igraph]{sample_pa}.
#' 
#' @section Functions:
#' \itemize{
#'   \item{\code{sg_make_nodes} generate data.frame nodes.}
#'   \item{\code{sg_make_edges} generate data.frame edges.}
#'   \item{\code{sg_make_nodes_edges} generate list of nodes and edges.}
#' }
#'
#' @examples
#' nodes <- sg_make_nodes()
#' edges <- sg_make_edges(nodes)
#' 
#' sigmajs() %>%
#'	sg_nodes(nodes, id, label, size, color) %>%
#'	sg_edges(edges, id, source, target) %>%
#'	sg_settings(defaultNodeColor = "#0011ff")
#' 
#' @return \code{tibble} of nodes or edges or a \code{list} of the latter.
#'
#' @importFrom grDevices colorRampPalette
#' @rdname generate
#' @export
sg_make_nodes <- function(n = 10, colors = c("#B1E2A3", "#98D3A5", "#328983", "#1C5C70", "#24C96B")) {

	dplyr::tibble(
		id = as.character(seq(1, n)),
		label = sample(paste0(LETTERS, 1:100), n, replace = TRUE),
		size = ceiling(runif(n, 1, 5)),
		color = colorRampPalette(colors)(n)
	)

}

#' @rdname generate
#' @export
sg_make_edges <- function(nodes, n = NULL) {
  
  if(missing(nodes))
    stop("mising nodes", call. = FALSE)

  if(!is.null(n))
    warning("Argument `n` is deprecated")
  
	ids <- as.character(nodes$id)
	dplyr::tibble(
		id = as.character(seq(1, length(ids))),
		source = ids,
		target = sample(ids, length(ids), replace = TRUE)
	)
}

#' @rdname generate
#' @export
sg_make_nodes_edges <- function(n, ...){
  
  g <- igraph::sample_pa(n, ...)
  
  g <- igraph::as_data_frame(g, what = 'both')
  
  edges <- g$edges %>% 
    dplyr::mutate(
      id = 1:n(),
      from = as.character(from),
      to = as.character(to)
    ) %>%
    dplyr::select(
      source = from, 
      target = to,
      id)
  
  nodes <- dplyr::tibble(
    id = as.character(c(edges$source, edges$target))
  ) %>% 
    dplyr::group_by(id) %>% 
    dplyr::summarise(size = n()) %>% 
    dplyr::ungroup() %>% 
    dplyr::mutate(
      label = id
    ) %>% 
    dplyr::select(
      id, 
      label, 
      size
    )
  
  list(
    nodes = nodes,
    edges = edges
  )
}

#' Kill or clear
#' 
#' Kill the graph to ensure new data is redrawn, useful in Shiny 
#' when graph is not updated by \code{\link{sigmajsProxy}}.
#' 
#' @inheritParams sg_nodes
#' 
#' @return A modified version of the \code{sg} object.
#' 
#' @rdname clear-kill
#' @export
sg_kill <- function(sg){
  .test_sg(sg)
  
  sg$x$kill <- TRUE
  sg
}

#' @rdname clear-kill
#' @export
sg_clear <- function(sg){
  .test_sg(sg)
  
  sg$x$clear <- TRUE
  sg
}


#' Color
#' 
#' Scale color by node size.
#' 
#' @inheritParams sg_nodes
#' @param pal Vector of color.
#' 
#' @examples 
#' nodes <- sg_make_nodes() 
#' edges <- sg_make_edges(nodes, 20)
#' 
#' sigmajs() %>% 
#'   sg_nodes(nodes, id, size) %>% 
#'   sg_scale_color(pal = c("red", "blue"))
#' 
#' @return A modified version of the \code{sg} object.
#' 
#' @name color-scale
#' @export
sg_scale_color <- function(sg, pal){
  
  size <- purrr::map(sg$x$data$nodes, "size") %>% 
    unlist() %>% 
    as.numeric()
  
  if(!length(size))
    stop("no node size passed", call. = FALSE)
  
  color <- scales::col_numeric(pal, domain = range(size))(size)
  
  sg$x$data$nodes <- purrr::map2(sg$x$data$nodes, color, function(x, y){
    x$color <- y
    return(x)
  })
  
  return(sg)
}