✨ Add function to create midpoint network

NAMESPACE

@@ -13,7 +13,9 @@ export(bbox_to_polygon)
 export(create_bbox)
 export(create_graph)
 export(create_graph_links)
+export(create_graph_nodes)
 export(create_linestring)
+export(create_midpoint_graph)
 export(create_road_network)
 export(create_segmented_network)
 export(decompose_linestring)
@@ -48,6 +50,7 @@ importFrom(sf,st_agr)
 importFrom(sf,st_as_sf)
 importFrom(sf,st_boundary)
 importFrom(sf,st_cast)
+importFrom(sf,st_centroid)
 importFrom(sf,st_collection_extract)
 importFrom(sf,st_contains)
 importFrom(sf,st_coordinates)

R/create-graph-links.R

@@ -9,6 +9,7 @@
 #'   If `TRUE`, the links are directed.
 #' @param unique_links If `TRUE`, the default, the links are unique.
 #'   Duplicate links are removed. If `FALSE`, duplicate links are retained.
+#' @param link_ids A vector of link IDs.
 #' @return A data frame of graph links with columns `from` and `to`.
 #' @export
 #' @examples
@@ -21,11 +22,16 @@
 create_graph_links <- function(source_nodes,
                                target_nodes,
                                directed     = FALSE,
-                               unique_links = TRUE) {
+                               unique_links = TRUE,
+                               link_id      = NULL) {
   # Check if the number of source and target nodes are the same
   if (length(source_nodes) != length(target_nodes)) {
     stop("number of source and target nodes must be the same")
   }
+  # Check if the number of link IDs are the same as the number of links
+  if (!is.null(link_id) && length(link_id) != length(source_nodes)) {
+    stop("number of link IDs must be the same as the number of links")
+  }
 
   # Create links matrix of links
   links_mat <- cbind(source_nodes, target_nodes)
@@ -37,10 +43,13 @@ create_graph_links <- function(source_nodes,
   if (unique_links) links_mat <- unique(links_mat)
 
   # Create a data frame of links
-  links <- data.frame(
+  graph_links <- data.frame(
     from = links_mat[, 1],
     to   = links_mat[, 2]
   )
 
-  return(links)
+  # Add link ID if provided
+  if (!is.null(link_id)) graph_links$id <- link_id
+
+  return(graph_links)
 }

R/create-graph-nodes.R

@@ -0,0 +1,37 @@
+#' Create a data frame of nodes for a graph
+#'
+#' This function creates a data frame of nodes for a graph from a set of node
+#' IDs and geometries.
+#'
+#' @param node_ids A vector of node IDs.
+#' @param node_geometries A `sfc_POINT` object containing node geometries.
+#' @return A data frame of nodes with columns `id`, `x`, and `y`.
+#' @export
+#' @examples
+#' library(sf)
+#'
+#' # Create node IDs and geometries
+#' node_ids <- c("jn_000001", "jn_000002", "jn_000003")
+#'
+#' # Create some node geometries
+#' node_geometries <- st_sfc(
+#'   st_point(c(0, 1)),
+#'   st_point(c(1, 0)),
+#'   st_point(c(2, 1))
+#' )
+#'
+#' # Create a data frame of nodes
+#' create_graph_nodes(node_ids, node_geometries)
+create_graph_nodes <- function(node_ids, node_geometries) {
+  # Extract node coordinates
+  coordinates <- st_coordinates(node_geometries)
+
+  # Create a data frame of nodes
+  graph_nodes <- data.frame(
+    id = node_ids,
+    x  = coordinates[, 1],
+    y  = coordinates[, 2]
+  )
+
+  return(graph_nodes)
+}

R/create-graph.R

@@ -19,17 +19,12 @@
 #' plot(graph)
 create_graph <- function(nodes, links, directed = FALSE) {
   # Create graph from nodes and links
-  edges <- st_drop_geometry(links)[, c("from", "to")]
-  node_coordinates <- st_coordinates(nodes)
-  vertices <- data.frame(
-    id = nodes$id,
-    x  = node_coordinates[, 1],
-    y  = node_coordinates[, 2]
-  )
+  graph_links <- st_drop_geometry(links)[, c("from", "to", "id")]
+  graph_nodes <- create_graph_nodes(nodes$id, nodes$geometry)
   graph <- graph_from_data_frame(
-    edges,
+    graph_links,
     directed = directed,
-    vertices = vertices
+    vertices = graph_nodes
   )
 
   # Set edge weights based on link length

R/create-midpoint-graph.R

@@ -0,0 +1,56 @@
+#' Create a midpoint graph from a network
+#'
+#' This function creates a midpoint graph where nodes represent the midpoints
+#' of links in the input network.
+#'
+#' @param network A `road_network` or `segmented_network` object.
+#' @return A `igraph` object representing the midpoint graph.
+#' @export
+#' @examples
+#' # Create a road network
+#' network <- create_road_network(demo_roads)
+#'
+#' # Plot the road network
+#' plot(network$graph)
+#'
+#' # Create a midpoint graph from a road network
+#' graph <- create_midpoint_graph(network)
+#'
+#' # Plot the midpoint graph
+#' plot(graph)
+create_midpoint_graph <- function(network) {
+  # Get adjacent links for each link
+  adjacent_links <- get_adjacent_links(
+    network,
+    network$links$id,
+    reachable_only = TRUE
+  )
+
+  # Create a data frame of links for midpoint graph
+  midpoint_graph_links <- create_graph_links(
+    rep(network$links$id, lengths(adjacent_links)),
+    unlist(adjacent_links),
+    directed     = is_directed(network$graph),
+    unique_links = TRUE
+  )
+
+  # Create a data frame of nodes for midpoint graph
+  midpoint_graph_nodes <- create_graph_nodes(
+    network$links$id,
+    st_centroid(network$links$geometry)
+  )
+
+  # Create a midpoint graph from the links and nodes
+  midpoint_graph <- graph_from_data_frame(
+    midpoint_graph_links,
+    directed = is_directed(network$graph),
+    vertices = midpoint_graph_nodes
+  )
+
+  # Calculate weights for each edge
+  link_indices <- match(as.matrix(midpoint_graph_links), network$links$id)
+  link_length <- st_length(network$links$geometry[link_indices])
+  E(midpoint_graph)$weight <- rowMeans(matrix(link_length, ncol = 2))
+
+  return(midpoint_graph)
+}

R/pavement-package.R

@@ -16,6 +16,7 @@
 #' @importFrom sf st_as_sf
 #' @importFrom sf st_boundary
 #' @importFrom sf st_cast
+#' @importFrom sf st_centroid
 #' @importFrom sf st_collection_extract
 #' @importFrom sf st_contains
 #' @importFrom sf st_coordinates