Merge commit '8d8787cce038bcf9c787d913f92add7af7e255a7'

DESCRIPTION

@@ -46,10 +46,12 @@ Suggests:
     seriation,
     deldir,
     gganimate,
-    covr
+    covr,
+    sf,
+    sfnetworks
 LinkingTo: 
     cpp11
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 Depends:
     R (>= 2.10),
     ggplot2 (>= 3.0.0)

NAMESPACE

@@ -2,6 +2,9 @@
 
 S3method(as.data.frame,layout_ggraph)
 S3method(autograph,default)
+S3method(collect_connections,default)
+S3method(collect_edges,default)
+S3method(collect_edges,layout_tbl_graph)
 S3method(create_layout,default)
 S3method(create_layout,layout_ggraph)
 S3method(create_layout,tbl_graph)
@@ -32,6 +35,7 @@ export(GeomEdgeParallelSegment)
 export(GeomEdgePath)
 export(GeomEdgePoint)
 export(GeomEdgeSegment)
+export(GeomEdgeSf)
 export(GeomEdgeSpanPath)
 export(GeomEdgeSpanSegment)
 export(GeomEdgeTile)
@@ -76,6 +80,7 @@ export(StatEdgeParallel)
 export(StatEdgeParallel0)
 export(StatEdgeParallel2)
 export(StatFilter)
+export(StatFilterSf)
 export(StatNodeArcBar)
 export(StatNodeCircle)
 export(StatNodeVoronoi)
@@ -131,6 +136,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 +146,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)
@@ -385,6 +392,7 @@ importFrom(igraph,simplify)
 importFrom(igraph,unfold_tree)
 importFrom(igraph,vertex_attr)
 importFrom(lifecycle,deprecated)
+importFrom(memoise,memoise)
 importFrom(rlang,.data)
 importFrom(rlang,as_quosure)
 importFrom(rlang,enquo)

NEWS.md

@@ -31,6 +31,8 @@
   `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/connections.R

@@ -91,6 +91,7 @@ get_con <- function(from = integer(), to = integer(), paths = NULL, ..., weight
 collect_connections <- function(layout, from, to, ...) {
   UseMethod('collect_connections', layout)
 }
+#' @export
 collect_connections.default <- function(layout, ...) {
   cli::cli_abort('Don\'t know how to get connections from an object of class {.cls {class(layout)[1]}}')
 }

R/edges.R

@@ -110,6 +110,7 @@ get_edges <- function(format = 'short', collapse = 'none', ...) {
 collect_edges <- function(layout) {
   UseMethod('collect_edges', layout)
 }
+#' @export
 collect_edges.default <- function(layout) {
   attr(layout, 'edges')
 }

R/geom_edge_bundle_force.R

@@ -291,5 +291,4 @@ force_bundle <- function(data, K, C, P, S, P_rate, I, I_rate, compatibility_thre
   )
 }
 
-#force_bundle_mem <- memoise::memoise(force_bundle)
-force_bundle_mem <- force_bundle
+force_bundle_mem <- memoise(force_bundle)

R/geom_edge_bundle_minimal.R

@@ -274,4 +274,4 @@ minimal_bundle <- function(graph, nodes, from, to, max_distortion = 2, weight_fa
   data_frame0(x = nodes$x[paths], y = nodes$y[paths], group = ids)
 }
 
-minimal_bundle_mem <- memoise::memoise(minimal_bundle)
+minimal_bundle_mem <- memoise(minimal_bundle)

R/geom_edge_bundle_path.R

@@ -325,4 +325,4 @@ path_bundle <- function(graph, nodes, from, to, directed = directed, max_distort
   data_frame0(x = nodes$x[paths], y = nodes$y[paths], group = ids)
 }
 
-path_bundle_mem <- memoise::memoise(path_bundle)
+path_bundle_mem <- memoise(path_bundle)

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)
+  )
+}
+#' @rdname get_edges
+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,57 @@
+#' 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
+#' library(tidygraph)
+#'
+#' if (require("sfnetworks", quietly = TRUE)) {
+#'   gr <- sfnetworks::as_sfnetwork(roxel)
+#'   ggraph(gr, 'sf') +
+#'     geom_node_sf(aes(color = centrality_betweenness()))
+#' }
+#'
+#' @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)
+  )
+}
+
+#' @rdname get_nodes
+get_sf_nodes <- function(){
+  function(layout) {
+    nodes <- sf::st_as_sf(layout)
+    attr(nodes, 'type_ggraph') <- 'node_ggraph'
+    nodes
+  }
+}

R/ggraph-package.R

@@ -1,11 +1,11 @@
-#' @aliases ggraph-package
 #' @keywords internal
 '_PACKAGE'
 
 # The following block is used by usethis to automatically manage
 # roxygen namespace tags. Modify with care!
 ## usethis namespace: start
 #' @import ggplot2 tidygraph rlang vctrs
+#' @importFrom memoise memoise
 #' @importFrom lifecycle deprecated
 #' @useDynLib ggraph, .registration = TRUE
 ## usethis namespace: end

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

@@ -27,6 +27,7 @@ create_layout.tbl_graph <- function(graph, layout, circular = FALSE, ...) {
   )
   check_layout(layout)
 }
+#' @export
 collect_edges.layout_tbl_graph <- function(layout) {
   gr <- attr(layout, 'graph')
   edges <- as_tibble(gr, active = 'edges')
@@ -94,7 +95,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) {

_pkgdown.yml

@@ -79,6 +79,8 @@ reference:
       - layout_tbl_graph_matrix
       - layout_tbl_graph_hive
       - layout_tbl_graph_fabric
+      - layout_tbl_graph_sf
+      - layout_tbl_graph_metro
   - title: "Nodes"
     desc: >
       While nodes are often thought of as points in a hairball graph, they are
@@ -91,6 +93,7 @@ reference:
       - geom_node_circle
       - geom_node_arc_bar
       - geom_node_range
+      - geom_node_sf
   - title: "Edges"
     desc: >
       Edges are the entities connecting nodes, often drawn with some sort of
@@ -113,6 +116,7 @@ reference:
       - geom_edge_bundle_force
       - geom_edge_bundle_path
       - geom_edge_bundle_minimal
+      - geom_edge_sf
   - title: "Connections"
     desc: >
       Connections are meta-edges, connecting nodes that are not direct