Add support for nodes and edges in geographical space (#357)

DESCRIPTION

@@ -47,7 +47,8 @@ Suggests:
     seriation,
     deldir,
     gganimate,
-    covr
+    covr,
+    sf
 LinkingTo: Rcpp
 RoxygenNote: 7.2.3
 Depends:

NAMESPACE

@@ -32,6 +32,7 @@ export(GeomEdgeParallelSegment)
 export(GeomEdgePath)
 export(GeomEdgePoint)
 export(GeomEdgeSegment)
+export(GeomEdgeSf)
 export(GeomEdgeSpanPath)
 export(GeomEdgeSpanSegment)
 export(GeomEdgeTile)
@@ -76,6 +77,7 @@ export(StatEdgeParallel)
 export(StatEdgeParallel0)
 export(StatEdgeParallel2)
 export(StatFilter)
+export(StatFilterSf)
 export(StatNodeArcBar)
 export(StatNodeCircle)
 export(StatNodeVoronoi)
@@ -131,6 +133,7 @@ export(geom_edge_parallel)
 export(geom_edge_parallel0)
 export(geom_edge_parallel2)
 export(geom_edge_point)
+export(geom_edge_sf)
 export(geom_edge_span)
 export(geom_edge_span0)
 export(geom_edge_span2)
@@ -140,6 +143,7 @@ export(geom_node_circle)
 export(geom_node_label)
 export(geom_node_point)
 export(geom_node_range)
+export(geom_node_sf)
 export(geom_node_text)
 export(geom_node_tile)
 export(geom_node_voronoi)

NEWS.md

@@ -31,6 +31,7 @@
   `geom_edge_bundle_minimal()` (+ variants) to provide support for edge bundling 
   (#267)
 * Add "metro" layout from graphlayouts for metroline like layouts
+* Add `layout_sf()`, `geom_node_sf()` and `geom_edge_sf()` to support plotting of [`sfnetwork`](https://luukvdmeer.github.io/sfnetworks/) objects (#275)
 
 # ggraph 2.1.0
 

R/aaa.R

@@ -50,6 +50,23 @@ StatReverse <- ggproto('StatReverse', StatFilter,
   }
 )
 
+#' @rdname ggraph-extensions
+#' @format NULL
+#' @usage NULL
+#' @export
+StatFilterSf <- ggproto('StatFilterSf', StatSf,
+  setup_data = function(data, params) {
+    if (any(names(data) == 'filter')) {
+      if (!is.logical(data$filter)) {
+        cli::cli_abort('{.field filter} must be logical')
+      }
+      data <- data[data$filter, names(data) != 'filter']
+    }
+    data
+  },
+  default_aes = aes(filter = TRUE)
+)
+
 aes_intersect <- function(aes1, aes2) {
   aes <- c(as.list(aes1), aes2[!names(aes2) %in% names(aes1)])
   class(aes) <- 'uneval'

R/geom_edge_sf.R

@@ -0,0 +1,71 @@
+#' Draw edges as LINESTRINGs in geographical space
+#'
+#' This geom is equivalent in functionality to [ggplot2::geom_sf()] for `LINESTRING`
+#' geometries and allows for plotting of edges in their geographical space in
+#' different colours, linetypes and widths.
+#'
+#' @section Aesthetics:
+#' `geom_edge_sf` understand the following aesthetics.
+#'
+#' - alpha
+#' - colour
+#' - linetype
+#' - filter
+#'
+#' @inheritParams ggplot2::geom_sf
+#'
+#' @param mapping Set of aesthetic mappings created by [ggplot2::aes()]
+#' or [ggplot2::aes_()]. By default geometry is mapped to the geometry in
+#' the edge data.
+#'
+#' @author Lorena Abad
+#'
+#' @family geom_edge_*
+#'
+#' @examples
+#' if (require("sfnetworks", quietly = TRUE)) {
+#'   gr <- sfnetworks::as_sfnetwork(roxel)
+#'   ggraph(gr, 'sf') + geom_edge_sf()
+#' }
+#'
+#' @export
+#'
+geom_edge_sf <- function(mapping = NULL, data = get_sf_edges(),
+                         position = 'identity', show.legend = NA, ...) {
+  mapping <- complete_edge_aes(mapping)
+  mapping <- aes_intersect(mapping, aes(geometry = geometry))
+  c(
+    layer_sf(
+      geom = GeomEdgeSf, data = data, mapping = mapping, stat = StatFilterSf,
+      position = position, show.legend = show.legend, inherit.aes = FALSE,
+      params = expand_edge_aes(list2(na.rm = FALSE, ...))
+    ),
+    coord_sf(default = TRUE)
+  )
+}
+
+get_sf_edges <- function(){
+  function(layout) {
+    edges <- sf::st_as_sf(attr(layout, "graph"), "edges")
+    attr(edges, 'type_ggraph') <- 'edge_ggraph'
+    edges
+  }
+}
+
+#' @rdname ggraph-extensions
+#' @format NULL
+#' @usage NULL
+#' @export
+GeomEdgeSf = ggproto("GeomEdgeSf", GeomSf,
+  draw_panel = function(data, panel_params, coords) {
+    names(data) <- sub('edge_', '', names(data))
+    names(data)[names(data) == 'width'] <- 'linewidth'
+    GeomSf$draw_panel(data, panel_params, coords)
+  },
+  draw_key = GeomEdgePath$draw_key,
+  default_aes = aes(
+    edge_colour = 'black', edge_width = 0.5, edge_linetype = 1,
+    edge_alpha = NA
+  ),
+  rename_size = FALSE
+)

R/geom_node_sf.R

@@ -0,0 +1,54 @@
+#' Show nodes as POINTs in geographical space
+#'
+#' This geom is equivalent in functionality to [ggplot2::geom_sf()] for `POINT`
+#' geometries and allows for plotting of nodes in their geographical space in
+#' different shapes, colours and sizes.
+#'
+#' @section Aesthetics:
+#' `geom_node_sf` understand the following aesthetics.
+#'
+#' - alpha
+#' - colour
+#' - shape
+#' - size
+#' - filter
+#'
+#' @inheritParams ggplot2::geom_sf
+#'
+#' @param mapping Set of aesthetic mappings created by [ggplot2::aes()]
+#' or [ggplot2::aes_()]. By default geometry is mapped to the geometry in
+#' the node data.
+#'
+#' @author Lorena Abad
+#'
+#' @family geom_node_*
+#'
+#' @examples
+#' if (require("sfnetworks", quietly = TRUE)) {
+#'   gr <- sfnetworks::as_sfnetwork(roxel) %>%
+#'     mutate(centrality = centrality_betweenness())
+#'   ggraph(gr, 'sf') + geom_node_sf(aes(color = centrality))
+#' }
+#'
+#' @export
+#'
+geom_node_sf <- function(mapping = NULL, data = get_sf_nodes(),
+                          position = 'identity', show.legend = NA, ...) {
+  mapping <- aes_intersect(mapping, aes(geometry = geometry))
+  c(
+    layer_sf(
+      geom = GeomSf, data = data, mapping = mapping, stat = StatFilterSf,
+      position = position, show.legend = show.legend, inherit.aes = FALSE,
+      params = list2(na.rm = FALSE, ...)
+    ),
+    coord_sf(default = TRUE)
+  )
+}
+
+get_sf_nodes <- function(){
+  function(layout) {
+    nodes <- sf::st_as_sf(layout)
+    attr(nodes, 'type_ggraph') <- 'node_ggraph'
+    nodes
+  }
+}

R/layout_sf.R

@@ -0,0 +1,32 @@
+#' Place nodes on their geographical space
+#'
+#' This layout is built for objects of class `sfnetwork` and is meant to
+#' plot a graph on its geographical space, by extracting its X and Y coordinates
+#'
+#' @param graph An sfnetwork object
+#' @param circular ignored
+#'
+#' @importFrom tidygraph as_tbl_graph
+#'
+#' @return A data.frame with the columns `x`, `y`, `circular`.
+#'
+#' @family layout_tbl_graph_*
+layout_tbl_graph_sf <- function(graph, circular = FALSE) {
+  # Check the presence of sf.
+  check_installed("sf")
+  # Check if network is an sfnetwork
+  if (!inherits(graph, "sfnetwork")) {
+    cli::cli_abort("The 'sf' layout needs an {.cls sfnetwork} graph.")
+  }
+  # Extract X and Y coordinates from the nodes
+  graph <- activate(graph, "nodes")
+  x <- sf::st_coordinates(graph)[,"X"]
+  y <- sf::st_coordinates(graph)[,"Y"]
+  # Create layout data frame
+  nodes <- data_frame0(x = x, y = y, circular = FALSE)
+  # Convert to tbl_graph to 'unstick' geometry column
+  extra_data <- as_tibble(as_tbl_graph(graph), active = "nodes")
+  nodes <- combine_layout_nodes(nodes, extra_data)
+  attr(nodes, 'graph') <- graph
+  nodes
+}

R/tbl_graph.R

@@ -94,7 +94,11 @@ prepare_graph <- function(graph, layout, direction = 'out', ...) {
     if (!graph_is_treeish) graph <- graph_to_tree(graph, mode = direction)
     graph <- permute(graph, match(seq_len(gorder(graph)), order(node_depth(graph, direction))))
   }
-  as_tbl_graph(graph)
+  if (inherits(graph, "sfnetwork")) {
+    graph
+  } else {
+    as_tbl_graph(graph)
+  }
 }
 #' @importFrom igraph degree unfold_tree components induced_subgraph vertex_attr vertex_attr<- is.directed simplify
 graph_to_tree <- function(graph, mode) {