Adds automatic legend

NAMESPACE

@@ -45,4 +45,5 @@ importFrom(igraph,layout_with_fr)
 importFrom(igraph,vcount)
 importFrom(network,as.edgelist)
 importFrom(sna,gplot.layout.kamadakawai)
+importFrom(stats,quantile)
 importFrom(stats,terms)

NEWS.md

@@ -11,7 +11,9 @@
 
 *  The argument `sample.edges` now works as expected.
 
-*  `vertex.color` now accepts formulas to color vertices by a vertex attribute.
+*  `vertex.color`, `vertex.size`, and `vertex.nsides` now accepts formulas.
+
+*  `edge.width` now accepts formulas.
 
 *  New function: `locate_vertex()`.
 

R/attribute-extraction.R

@@ -0,0 +1,68 @@
+#' Extract a graph attribute
+#' @param graph A graph object of class igraph or network.
+#' @param attribute A character string specifying the name of the attribute.
+#' @return A vector of the attribute values. If the attribute does not exist, an error is thrown.
+#' @noRd
+get_vertex_attribute <- function(graph, attribute) UseMethod("get_vertex_attribute")
+
+get_vertex_attribute.igraph <- function(graph, attribute) {
+
+  # Check if the attribute exists
+  if (!(attribute %in% igraph::vertex_attr_names(graph))) {
+    stop("Attribute does not exist in graph")
+  }
+
+  # Extract the attribute
+  igraph::vertex_attr(graph, name = attribute)
+
+}
+
+get_vertex_attribute.network <- function(graph, attribute) {
+
+  # Check if the attribute exists
+  if (!(attribute %in% network::list.vertex.attributes(graph))) {
+    stop("Attribute does not exist in graph")
+  }
+
+  # Extract the attribute
+  network::get.vertex.attribute(graph, attribute)
+
+}
+
+get_vertex_attribute.default <- function(graph, attribute) {
+
+  stop("Graph type not supported")
+
+}
+
+get_edge_attribute <- function(graph, attribute) UseMethod("get_edge_attribute")
+
+get_edge_attribute.igraph <- function(graph, attribute) {
+
+  # Check if the attribute exists
+  if (!(attribute %in% igraph::edge_attr_names(graph))) {
+    stop("Attribute does not exist in graph")
+  }
+
+  # Extract the attribute
+  igraph::edge_attr(graph, name = attribute)
+
+}
+
+get_edge_attribute.network <- function(graph, attribute) {
+
+  # Check if the attribute exists
+  if (!(attribute %in% network::list.edge.attributes(graph))) {
+    stop("Attribute does not exist in graph")
+  }
+
+  # Extract the attribute
+  network::get.edge.attribute(graph, attribute)
+
+}
+
+get_edge_attribute.default <- function(graph, attribute) {
+
+  stop("Graph type not supported")
+
+}

R/color_nodes_function.R

@@ -1,40 +1,3 @@
-#' Extract a graph attribute
-#' @param graph A graph object of class igraph or network.
-#' @param attribute A character string specifying the name of the attribute.
-#' @return A vector of the attribute values. If the attribute does not exist, an error is thrown.
-#' @noRd
-get_graph_attribute <- function(graph, attribute) UseMethod("get_graph_attribute")
-
-get_graph_attribute.igraph <- function(graph, attribute) {
-
-  # Check if the attribute exists
-  if (!(attribute %in% igraph::vertex_attr_names(graph))) {
-    stop("Attribute does not exist in graph")
-  }
-
-  # Extract the attribute
-  igraph::vertex_attr(graph, name = attribute)
-
-}
-
-get_graph_attribute.network <- function(graph, attribute) {
-
-  # Check if the attribute exists
-  if (!(attribute %in% network::list.vertex.attributes(graph))) {
-    stop("Attribute does not exist in graph")
-  }
-
-  # Extract the attribute
-  network::get.vertex.attribute(graph, attribute)
-
-}
-
-get_graph_attribute.default <- function(graph, attribute) {
-
-  stop("Graph type not supported")
-
-}
-
 color_nodes <- function(...) UseMethod("color_nodes")
 
 color_nodes.formula <- function(formula, ...) {
@@ -64,7 +27,7 @@ color_nodes.default <- function(
   ) {
 
   # Extracting the attribute from the graph
-  value <- get_graph_attribute(graph, attribute)
+  value <- get_vertex_attribute(graph, attribute)
   attr_type <- class(value)
 
   # Identifying NAs
@@ -76,8 +39,25 @@ color_nodes.default <- function(
     value <- as.factor(value)
     attr_type <- "factor"
 
+  } else if (inherits(value, "numeric")) {
+
+    # Checking if it is numeric, but if it can be converted to int
+    test_int <- abs(as.integer(value) - value) < .Machine$double.eps^.5
+
+    if (all(test_int, na.rm = TRUE)) {
+
+      value <- as.integer(value)
+      attr_type <- "integer"
+
+    }
+
   }
 
+
+
+  # Saving the original
+  value_orig <- value
+
   # Handle factors
   if (attr_type == "factor") {
 
@@ -97,22 +77,19 @@ color_nodes.default <- function(
 
     # Create color scale
     value <- grDevices::colorRamp(palette)(
-      (attr_min:attr_max - attr_min)/(attr_max - attr_min)
+      (value - attr_min)/(attr_max - attr_min)
     )
 
-    cpal <- grDevices::rgb(
-      grDevices::colorRamp(palette)(c(0, 1)),
+    cpal <- function(val) {grDevices::rgb(
+      grDevices::colorRamp(palette)(val),
       maxColorValue = 255
-    )
-
-    names(cpal) <- c(attr_min, attr_max)
+    )}
 
     # Color nodes based on attribute value
     value <- grDevices::rgb(value, maxColorValue = 255)
 
   } else if ("logical" %in% attr_type) { # Handle logicals
 
-
     # Creating mapping to recover colors
     cpal <- palette[1:2]
     names(cpal) <- c("FALSE", "TRUE")
@@ -151,11 +128,50 @@ color_nodes.default <- function(
     attr_type = attr_type,
     palette   = palette,
     na_color  = na_color,
-    map       = cpal
+    cpal      = cpal,
+    value     = value_orig,
+    attr_name = attribute
   )
 
 }
 
+#' @noRd 
+#' @importFrom stats quantile
+color_nodes_legend <- function(object) {
+
+  # Extracting the fill legend
+  x <- object$.legend_vertex_fill
+
+  if (!length(x))
+    return(invisible(NULL))
+
+  if (!inherits(x, "netplot_color_nodes")) {
+    stop("Object is not of class netplot_color_nodes")
+  }
+
+  # Acts depending on the type
+  values <- if (attr(x, "attr_type") %in% c("logical", "factor", "integer")) {
+    attr(x, "cpal")
+  } else {
+
+    # Generating values
+    structure(
+      attr(x, "cpal")(c(0, .25, .5, .75, 1)),
+      names = stats::quantile(attr(x, "value"), probs = c(0, .25, .5, .75, 1))
+      )
+
+  }
+
+  print(nplot_legend(
+    object,
+    labels = names(values),
+    pch    = 21,
+    gp     = grid::gpar(fill = values)
+  ))
+
+}
+
+
 if (FALSE) {
 
   # Factor attribute

R/gpar.R

@@ -209,6 +209,10 @@ set_vertex_gpar <- function(x, element, idx, ...) {
       dots$fill <- color_nodes(x$.graph, fill_var)
     }
 
+    # Adding information for the legend
+    x$.legend_vertex_col <- dots$col
+    x$.legend_vertex_fill <- dots$fill
+
   }
 
   do.call(

R/grob_vertex.R

@@ -19,11 +19,11 @@
 #' @noRd
 grob_vertex <- function(netenv, v) {
 
-  # Add formula handling
-  if(inherits(netenv$vertex.nsides, "formula")) {
-    var_name <- all.vars(netenv$vertex.nsides)[1]
-    netenv$vertex.nsides <- eval(netenv$vertex.nsides, envir = data)
-  }
+  # # Add formula handling
+  # if(inherits(netenv$vertex.nsides, "formula")) {
+  #   var_name <- all.vars(netenv$vertex.nsides)[1]
+  #   netenv$vertex.nsides <- eval(netenv$vertex.nsides, envir = data)
+  # }
 
   # Relax vertex.nsides validation
   if(!is.numeric(netenv$vertex.nsides[v]) & !is.character(netenv$vertex.nsides[v])) {
@@ -80,8 +80,8 @@ grob_vertex <- function(netenv, v) {
   # Create color palette
   nsides <- unique(netenv$vertex.nsides)
   ncolors <- length(nsides)
-  colors <- hsv(h = seq(0, 1, length.out = ncolors), v = 1, a = 1)
-  pal <- setNames(colors, nsides)
+  colors <- grDevices::hsv(h = seq(0, 1, length.out = ncolors), v = 1, a = 1)
+  pal <- stats::setNames(colors, nsides)
 
   # Lookup color for this vertex based on number of sides
   col <- pal[as.character(netenv$vertex.nsides[v])]

R/netplot.R

@@ -262,7 +262,7 @@ nplot.default <- function(
   ) {
 
   # We turn off the device if not need
-  if (length(dev.list()) == 0L) {
+  if (length(grDevices::dev.list()) == 0L) {
     on.exit(
       grDevices::dev.off(grDevices::dev.cur())
     )
@@ -279,9 +279,9 @@ nplot.default <- function(
       "'"
       )
 
-  netenv$N <- nrow(layout)
-  netenv$M <- nrow(edgelist)
-  netenv$graph_class <- class(x)
+  N <- nrow(layout)
+  M <- nrow(edgelist)
+  graph_class <- class(x)
 
   # Mapping attributes ---------------------------------------------------------
 
@@ -290,7 +290,7 @@ nplot.default <- function(
 
     rhs <- as.character(vertex.nsides[[2]])
     vertex.nsides <- map_attribute_to_shape(
-      get_graph_attribute(graph = x, attribute = rhs)
+      get_vertex_attribute(graph = x, attribute = rhs)
     )
 
   }
@@ -299,7 +299,7 @@ nplot.default <- function(
   if (length(vertex.size) && inherits(vertex.size, "formula")) {
 
     rhs <- as.character(vertex.size[[2]])
-    vertex.size <- get_graph_attribute(graph = x, attribute = rhs)
+    vertex.size <- get_vertex_attribute(graph = x, attribute = rhs)
 
     # Now check if it is numeric. If not, it should return an error
     if (!is.numeric(vertex.size)) {
@@ -308,6 +308,19 @@ nplot.default <- function(
 
   }
 
+  # Edges width
+  if (length(edge.width) && inherits(edge.width, "formula")) {
+
+    rhs <- as.character(edge.width[[2]])
+    edge.width <- get_edge_attribute(graph = x, attribute = rhs)
+
+    # Now check if it is numeric. If not, it should return an error
+    if (!is.numeric(edge.width)) {
+      stop("edge.width must be numeric")
+    }
+
+  }
+
   # Sampling edges -------------------------------------------------------------
   if (sample.edges < 1) {
 
@@ -574,10 +587,11 @@ nplot.default <- function(
 
 
 #' @rdname nplot
+#' @param legend Logical scalar. When `TRUE` it adds a legend.
 #' @export
 #' @param newpage Logical scalar. When `TRUE` calls [grid::grid.newpage].
 #' @param y,... Ignored
-print.netplot <- function(x, y = NULL, newpage = TRUE, ...) {
+print.netplot <- function(x, y = NULL, newpage = TRUE, legend = TRUE, ...) {
 
   # Drawing
   if (newpage) {
@@ -586,6 +600,13 @@ print.netplot <- function(x, y = NULL, newpage = TRUE, ...) {
 
   grid::grid.draw(x)
 
+  # If legend
+  if (legend) {
+
+    color_nodes_legend(x)
+
+  }
+
   # Storing the value
   .Last.netplot$set(x)