First implementation of smoothed network morpher. Refs #70

NAMESPACE

@@ -56,6 +56,7 @@ export(to_spatial_directed)
 export(to_spatial_explicit_edges)
 export(to_spatial_implicit_edges)
 export(to_spatial_shortest_paths)
+export(to_spatial_smoothed)
 export(to_spatial_subgraph)
 importFrom(crayon,silver)
 importFrom(graphics,plot)
@@ -81,6 +82,7 @@ importFrom(sf,NA_agr_)
 importFrom(sf,st_agr)
 importFrom(sf,st_as_sf)
 importFrom(sf,st_bbox)
+importFrom(sf,st_boundary)
 importFrom(sf,st_cast)
 importFrom(sf,st_collection_extract)
 importFrom(sf,st_coordinates)
@@ -114,7 +116,9 @@ importFrom(tidygraph,activate)
 importFrom(tidygraph,active)
 importFrom(tidygraph,as_tbl_graph)
 importFrom(tidygraph,as_tibble)
+importFrom(tidygraph,centrality_degree)
 importFrom(tidygraph,convert)
+importFrom(tidygraph,filter)
 importFrom(tidygraph,morph)
 importFrom(tidygraph,mutate)
 importFrom(tidygraph,pull)
@@ -123,5 +127,6 @@ importFrom(tidygraph,select)
 importFrom(tidygraph,slice)
 importFrom(tidygraph,tbl_graph)
 importFrom(tidygraph,to_directed)
+importFrom(tidygraph,with_graph)
 importFrom(tools,toTitleCase)
 importFrom(utils,modifyList)

R/checks.R

@@ -76,6 +76,25 @@ is_spatially_explicit = function(x) {
   any(sapply(x, is.sfc), na.rm = TRUE)
 }
 
+#' Check if sf features have the same attributes
+#'
+#' @param x A single feature of an object of class \code{\link[sf]{sf}}, or an
+#' object of class \code{\link[sf]{sf}} with multiple features.
+#'
+#' @param y A single feature of an object of class \code{\link[sf]{sf}}.
+#' Ignored when x contains multiple features.
+#'
+#' @return \code{TRUE} when the attributes of x and y are the same, 
+#' \code{FALSE} otherwise.
+#'
+#' @noRd
+same_attributes = function(x, y = NULL) {
+  if (nrow(x) == 1 & !is.null(y)) {
+    x = rbind(x, y)
+  }
+  all(duplicated(sf::st_drop_geometry(x))[-1])
+}
+
 #' Check if the CRS of two objects are the same
 #'
 #' @param x An object of class \code{\link{sfnetwork}}, \code{\link[sf]{sf}} or

R/morphers.R

@@ -7,11 +7,9 @@
 #'
 #' @param graph An object of class \code{\link{sfnetwork}}.
 #'
-#' @param ... Arguments to be passed on to other function. See the description
+#' @param ... Arguments to be passed on to other functions. See the description
 #' of each morpher for details.
 #'
-#' @param subset_by Whether to create subgraphs based on nodes or edges.
-#'
 #' @return A list of \code{\link{sfnetwork}} objects.
 #'
 #' @name spatial_morphers
@@ -149,8 +147,142 @@ to_spatial_shortest_paths = function(graph, ...) {
   lapply(c(1:length(paths$vpath)), get_single_path)
 }
 
+#' @describeIn spatial_morphers Reconstruct the network by iteratively removing 
+#' all nodes that have only one incoming and one outgoing edge (or simply a 
+#' degree centrality of 2 in the case of undirected networks), but at the same 
+#' time preserving the connectivity of the graph by merging the incoming and
+#' outgoing edge of the removed node.
+#' @param require_equal_attrs Should selected nodes only be removed when the
+#' attributes of their adjacent edges are equal? Defaults to \code{FALSE}.
+#' @param keep_orig Should the original edge data be kept in a special
+#' \code{.orig_data} column? Defaults to \code{TRUE}.
+#' @importFrom sf st_boundary st_geometry st_cast st_reverse st_union
+#' @importFrom tidygraph filter
+#' @export
+to_spatial_smoothed = function(graph, require_equal_attrs = FALSE,
+                               keep_orig = TRUE) {
+  expect_spatially_explicit_edges(graph)
+  # Check which nodes in the graph are pseudo nodes.
+  pseudo = is_pseudo_node(activate(graph, "nodes"))
+  # Initialize a list indicating the pseudo nodes that still need to be processed.
+  # At first this is equal to the full pseudo node list.
+  pseudo_remaining = pseudo
+  # Retrieve the edges from the graph.
+  edges = st_as_sf(graph, "edges")
+  new_edges = edges
+  # Iteratively process pseudo nodes until none remain.
+  # Preserve the connectivity of the graph while doing so.
+  while (any(pseudo_remaining)) {
+    # Get the node index of the first remaining pseudo node.
+    # This is the one that will be processed in this iteration.
+    idx = which(pseudo_remaining)[1]
+    # Find the adjacent edges to the pseudo node.
+    adj_edges = rbind(edges[edges$to == idx, ], edges[edges$from == idx, ])
+    # Normally, there should be two adjacent edges to a pseudo node.
+    # If there is only one adjacent edge, this means this edge is a loop.
+    # In that case, mark the node as processed and move to next iteration.
+    if (nrow(adj_edges) == 1) {
+      pseudo_remaining[idx] = FALSE
+      next
+    }
+    # If equal attributes of adjacent edges are required:
+    # Check if the attributes of the edges are equal.
+    # If not, then the node is not a real pseudo node.
+    # Hence, change the value of the current node to FALSE in both:
+    # - The list of all pseudo nodes.
+    # - The list of remaining pseudo nodes.
+    # And move on to the next iteration.
+    if (require_equal_attrs) {
+      if (!same_attributes(adj_edges[, !names(adj_edges) %in% c("from", "to")])) {
+        pseudo[idx] = FALSE
+        pseudo_remaining[idx] = FALSE
+        next
+      }
+    }
+    # In directed networks, a pseudo node will always have:
+    # - One linestring moving towards the node (the in edge).
+    # - One linestring moving away from the node (the out edge).
+    # In undirected networks, it can also have either 2 in or 2 out edges.
+    # Note that in or out in that case does not mean anything.
+    # But we do need arranged geometries to correctly merge the edges.
+    # Hence, there is a need to rearrange the edges before proceeding.
+    # The arrangement should be:
+    # - Edge one has a geometry that moves towards the pseudo node.
+    # - Edge two has a geometry that moves away from the pseudo node.
+    if (!is_directed(graph)) {
+      edge_1_bounds = sf::st_boundary(sf::st_geometry(adj_edges[1, ]))
+      if (sf::st_cast(edge_1_bounds, "POINT")[1] == node_geoms[idx]) {
+        adj_edges[1, ] = sf::st_reverse(adj_edges[1, ])
+      }
+      if (adj_edges[1, ]$from == idx) {
+        adj_edges[1, ]$from = adj_edges[1, ]$to
+        adj_edges[1, ]$to = idx
+      }
+      edge_2_bounds = sf::st_boundary(sf::st_geometry(adj_edges[2, ]))
+      if (sf::st_cast(edge_2_bounds, "POINT")[2] == node_geoms[idx]) {
+        adj_edges[2, ] = sf::st_reverse(adj_edges[2, ])
+      }
+      if (adj_edges[2, ]$to == idx) {
+        adj_edges[2, ]$to = adj_edges[2, ]$from
+        adj_edges[2, ]$from = idx
+      }
+    }
+    # Decompose the in and out edges into their vertices.
+    # The pseudo node vertice is in both of them, so should be removed once.
+    in_pts = sf::st_cast(sf::st_geometry(adj_edges[1, ]), "POINT")
+    out_pts = sf::st_cast(sf::st_geometry(adj_edges[2, ]), "POINT")[-1]
+    all_pts = sf::st_union(c(in_pts, out_pts))
+    # Merge the in and out edges into a single edge.
+    new_edge = adj_edges[1, ]
+    new_edge$to = adj_edges[2, ]$to
+    new_edge$.tidygraph_edge_index = list(adj_edges$.tidygraph_edge_index)
+    sf::st_geometry(new_edge) = sf::st_cast(all_pts, "LINESTRING")
+    # Add the new edge to the existing edges.
+    new_edges = rbind(new_edges, new_edge)
+    # Mark the current pseudo node as processed.
+    pseudo_remaining[idx] = FALSE
+  }
+  # Remove attributes from edges.
+  keep_attrs = c("from", "to", ".tidygraph_edge_index")
+  new_edges = new_edges[, names(new_edges) %in% keep_attrs]
+  # Keep the original edge data in a special column if requested.
+  if (keep_orig) {
+    new_edges$.orig_data = lapply(
+      new_edges$.tidygraph_edge_index, 
+      function(i) edges[i, , drop = FALSE]
+    )
+  }
+  # Create a new graph which includes the newly added edges.
+  new_graph = sfnetwork(
+    nodes = st_as_sf(graph, "nodes"), 
+    edges = new_edges, 
+    directed = is_directed(graph),
+    force = TRUE
+  )
+  # Remove the pseudo nodes and their adjacent edges from this graph.
+  new_graph = tidygraph::filter(new_graph, !pseudo)
+  list(
+    smoothed_graph = new_graph %preserve_active% graph
+  )
+}
+
+#' @importFrom tidygraph centrality_degree with_graph
+is_pseudo_node = function(x) {
+  if (is_directed(x)) {
+    # A node is a pseudo node if its in degree is 1 and its out degree is 1.
+    d_in = tidygraph::with_graph(x, tidygraph::centrality_degree(mode = "in"))
+    d_out = tidygraph::with_graph(x, tidygraph::centrality_degree(mode = "out"))
+    d_in == 1 & d_out == 1
+  } else {
+    # A node is a pseudo node if its degree is 2.
+    d = tidygraph::with_graph(x, tidygraph::centrality_degree())
+    d == 2
+  }
+}
+
 #' @describeIn spatial_morphers Limit a graph to a single spatial subset. 
-#' \code{...} is evaluated in the same manner as \code{\link{st_filter}}. 
+#' \code{...} is evaluated in the same manner as \code{\link{st_filter}}.
+#' @param subset_by Whether to create subgraphs based on nodes or edges.
 #' @export
 to_spatial_subgraph = function(graph, ..., subset_by = NULL) {
   if (is.null(subset_by)) {