✨ Add function to set events to network

NAMESPACE

@@ -4,6 +4,8 @@ S3method(create_linestring,coordinates)
 S3method(create_linestring,numeric)
 S3method(create_points,coordinates)
 S3method(create_points,numeric)
+S3method(create_road_network,sf)
+S3method(create_segmented_network,road_network)
 S3method(create_spatiotemporal_event,sf)
 S3method(extract_segmented_network_nodes,road_network)
 S3method(plot,road_network)
@@ -12,6 +14,8 @@ S3method(print,coordinates)
 S3method(print,road_network)
 S3method(print,segmented_network)
 S3method(print,spatiotemporal_event)
+S3method(set_events,road_network)
+S3method(set_events,segmented_network)
 S3method(split_linestring,LINESTRING)
 S3method(split_linestring,sfc_LINESTRING)
 S3method(summary,road_network)
@@ -47,6 +51,7 @@ export(get_adjacent_links)
 export(get_connected_links)
 export(remove_points_near_endpoints)
 export(sample_points_along_linestring)
+export(set_events)
 export(split_linestring)
 export(transform_to_cartesian)
 export(transform_to_geographic)

R/create-road-network.R

@@ -6,7 +6,11 @@
 #'
 #' @param roads A linestring object representing roads.
 #' @param directed Logical indicating whether the road network is directed.
+#' @param events A `sf` object representing events.
+#' @param ... Additional arguments passed to or from other methods.
 #' @returns A road network object.
+#' @name road_network
+#' @aliases create_road_network
 #' @export
 #' @examples
 #' # Create the road network
@@ -15,7 +19,14 @@
 #'
 #' # Plot the road network
 #' plot(road_network)
-create_road_network <- function(roads, directed = FALSE) {
+create_road_network <- function(roads, directed = FALSE, events = NULL, ...) {
+  UseMethod("create_road_network")
+}
+
+#' @export
+create_road_network.sf <- function(roads,
+                                   directed = FALSE,
+                                   events = NULL, ...) {
   # Extract nodes and links of road network
   nodes <- extract_road_network_nodes(roads)
   links <- extract_road_network_links(roads, nodes)
@@ -31,6 +42,11 @@ create_road_network <- function(roads, directed = FALSE) {
     roads = roads
   ), class = "road_network")
 
+  # Assign events to the road network
+  if (!is.null(events)) {
+    road_network <- set_events(road_network, events)
+  }
+
   return(road_network)
 }
 
@@ -52,17 +68,42 @@ print.road_network <- function(x, ...) {
     print(as.data.frame(x$links)[1:5, ], ...)
     cat("...", nrow(x$links) - 5, "more links\n")
   }
+  if ("events" %in% names(x)) {
+    cat("\n")
+    cat("Events:\n")
+    if (nrow(x$links) <= 5) {
+      print(as.data.frame(x$events), ...)
+    } else {
+      print(as.data.frame(x$events)[1:5, ], ...)
+      cat("...", nrow(x$links) - 5, "more events\n")
+    }
+  }
 }
 
 #' @export
-plot.road_network <- function(x, y, ...) {
+plot.road_network <- function(x, y, mode = c("default", "event"), ...) {
+  # Match the mode argument
+  mode <- match.arg(mode)
+
+  # Check if events are assigned to the road network
+  if (mode == "event" && !("events" %in% names(x))) {
+    stop("no events assigned to the road network")
+  }
+
   plot(x$links$geometry, lwd = 1, ...)
-  plot(x$nodes$geometry, cex = 1, pch = 16, add = TRUE, ...)
+  if (mode == "event") {
+    plot(x$events$geometry, cex = 1, pch = 4, col = "red", add = TRUE, ...)
+  } else {
+    plot(x$nodes$geometry, cex = 1, pch = 16, add = TRUE, ...)
+  }
 }
 
 #' @export
 summary.road_network <- function(object, ...) {
   cat("Road network summary\n")
-  cat("Number of nodes: ", nrow(object$nodes), "\n")
-  cat("Number of links: ", nrow(object$links), "\n")
+  cat("Number of nodes:  ", nrow(object$nodes), "\n")
+  cat("Number of links:  ", nrow(object$links), "\n")
+  if ("events" %in% names(object)) {
+    cat("Number of events: ", nrow(object$events), "\n")
+  }
 }

R/create-segmented-network.R

@@ -6,7 +6,11 @@
 #' @param road_network A `road_network` object representing the input road
 #'   network.
 #' @param segment_length A numeric value specifying the length of each segment.
+#' @param events A `sf` object representing events.
+#' @param ... Additional arguments passed to or from other methods.
 #' @return A `segmented_network` object.
+#' @name segmented_network
+#' @aliases create_segmented_network
 #' @export
 #' @examples
 #' # Create a road network
@@ -21,7 +25,17 @@
 #'
 #' # Plot the segmented road network
 #' plot(segmented_network)
-create_segmented_network <- function(road_network, segment_length = 1) {
+create_segmented_network <- function(road_network,
+                                     segment_length = 1,
+                                     events = NULL, ...) {
+  UseMethod("create_segmented_network")
+}
+
+#' @rdname segmented_network
+#' @export
+create_segmented_network.road_network <- function(road_network,
+                                                  segment_length = 1,
+                                                  events = NULL, ...) {
   # Extract nodes and links of segmented road network
   nodes <- extract_segmented_network_nodes(road_network, segment_length)
   links <- extract_segmented_network_links(road_network, nodes)
@@ -38,11 +52,20 @@ create_segmented_network <- function(road_network, segment_length = 1) {
     graph          = graph,
     nodes          = nodes,
     links          = links,
-    events         = NULL,
     origin_network = road_network,
     segment_length = segment_length
   ), class = "segmented_network")
 
+  # Assign events to the segmented network
+  if (!is.null(events)) {
+    if (!is.null(road_network$events)) {
+      warning("events already exist in the road network")
+    }
+    segmented_network <- set_events(segmented_network, events)
+  } else if ("events" %in% names(road_network)) {
+    segmented_network <- set_events(segmented_network, road_network$event)
+  }
+
   return(segmented_network)
 }
 
@@ -110,13 +133,17 @@ plot_coloured_segmented_network <- function(network_linestrings,
                                             ...) {
   par(fig = c(0, 0.8, 0, 1), mar = c(5, 4, 4, 2))
   plot(network_linestrings, lwd = 1, ...)
-  plot(
-    network_linestrings,
-    col = get_heatmap_colours(segment_values),
-    lwd = ifelse(segment_values == 0, 1, 2),
-    add = TRUE,
-    ...
-  )
+  if (max(segment_values) == 0) {
+    warning("all segment values are zero")
+  } else {
+    plot(
+      network_linestrings,
+      col = get_heatmap_colours(segment_values),
+      lwd = ifelse(segment_values == 0, 1, 2),
+      add = TRUE,
+      ...
+    )
+  }
 }
 
 plot_legends <- function(segment_values, mode, ...) {

R/create-spatiotemporal-event.R

@@ -40,17 +40,7 @@ create_spatiotemporal_event.sf <- function(x,
   return(x)
 }
 
-#' Print a spatiotemporal event collection
-#'
-#' This function prints a summary of a spatiotemporal event collection object.
-#'
-#' @param x A `spatiotemporal_event` object.
-#' @param ... Additional arguments passed to or from other methods.
-#' @return The `spatiotemporal_event` object, invisibly.
 #' @export
-#' @examples
-#' spatiotemporal_events <- create_spatiotemporal_event(sample_accidents)
-#' print(spatiotemporal_events)
 print.spatiotemporal_event <- function(x, ...) {
   cat("Spatiotemporal event collection with",
       nrow(x), "events and", ncol(x) - 2, "fields", fill = TRUE)

R/set-events.R

@@ -0,0 +1,53 @@
+#' Set events on a space.
+#'
+#' This function sets events on a space.
+#'
+#' @param x A `road_network` or `segmented_network` object.
+#' @param events A `sf` object representing events.
+#' @param ... Additional arguments passed to or from other methods.
+#' @return The input object with the events added.
+#' @export
+#' @examples
+#' # Create the road network
+#' road_network <- create_road_network(sample_roads)
+#'
+#' # Set accidents on the road network
+#' road_network <- set_events(road_network, sample_accidents)
+set_events <- function(x, events, ...) {
+  UseMethod("set_events")
+}
+
+#' @rdname set_events
+#' @export
+set_events.road_network <- function(x, events, ...) {
+  x <- validate_and_set_events(x, events)
+
+  return(x)
+}
+
+#' @rdname set_events
+#' @export
+set_events.segmented_network <- function(x, events, ...) {
+  x <- validate_and_set_events(x, events)
+
+  # Count events on each link
+  event_counts <- table(st_nearest_feature(events, x$links))
+  # Get the indices of the links with events
+  link_indices <- as.integer(names(event_counts))
+  # Update the count of events of each link
+  x$links$count[link_indices] <- event_counts
+
+  return(x)
+}
+
+validate_and_set_events <- function(x, events) {
+  if (!inherits(events, "sf")) {
+    stop("events must be a `sf` object")
+  }
+  if ("events" %in% names(x)) {
+    warning("events have already been set on the road network")
+  }
+  x$events <- events
+
+  return(x)
+}

README.Rmd

@@ -49,10 +49,12 @@ library(pavement)
 
 segmented_network <- sample_roads |>
   create_road_network() |>
+  set_events(sample_accidents) |>
   create_segmented_network(segment_length = 0.5) |>
-  assign_event_to_link(events = sample_accidents)
+  convolute_segmented_network()
 plot(segmented_network, mode = "event")
 plot(segmented_network, mode = "count")
+plot(segmented_network, mode = "density")
 ```
 
 ## Code of conduct

README.md

@@ -46,8 +46,9 @@ library(pavement)
 
 segmented_network <- sample_roads |>
   create_road_network() |>
+  set_events(sample_accidents) |>
   create_segmented_network(segment_length = 0.5) |>
-  assign_event_to_link(events = sample_accidents)
+  convolute_segmented_network()
 plot(segmented_network, mode = "event")
 ```
 
@@ -59,6 +60,12 @@ plot(segmented_network, mode = "count")
 
 <img src="man/figures/README-example-2.png" width="100%" />
 
+``` r
+plot(segmented_network, mode = "density")
+```
+
+<img src="man/figures/README-example-3.png" width="100%" />
+
 ## Code of conduct
 
 Please note that this project is released with a [Contributor Code of