R/helpers.R

Defines functions sg_scale_color sg_clear sg_kill sg_make_nodes_edges sg_make_edges sg_make_nodes

Documented in sg_clear sg_kill sg_make_edges sg_make_nodes sg_make_nodes_edges sg_scale_color

#' 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)
}
JohnCoene/sigmajs documentation built on Feb. 1, 2021, 12:12 p.m.