Merge pull request #13 from CityRiverSpaces/bug-ring-fn

Bug fix for closed rings

R/stroke.R

@@ -212,14 +212,23 @@ cross_check_links <- function(best_links, flow_mode = FALSE) {
 }
 
 #' @noRd
-get_nodes <- function(node_id, segment_id, segments) {
-  # find the node connected to the given one via the given segment(s)
-  # 1. get the nodes that are part of the given segment(s)
-  nds <- segments[segment_id, ]
+get_next_node <- function(node, segment, segments) {
+  # find the node connected to the given one via the given segment
+  # 1. get the nodes that are part of the given segment
+  nodes <- segments[segment, ]
   # 2. exclude the given node from the list
-  is_current_node <- nds == node_id
-  linked_nodes <- nds[!is_current_node]
-  return(linked_nodes)
+  is_current <- nodes == node
+  return(nodes[!is_current])
+}
+
+#' @noRd
+get_next_segment <- function(segment, link, links) {
+  # find the segment connected to the given one via the given link
+  #  1. get the segments connected to the given link
+  segments <- links[link, ]
+  #  2. exclude the given segment from the list
+  is_current <- segments == segment
+  return(segments[!is_current])
 }
 
 #' @noRd
@@ -234,36 +243,38 @@ merge_lines  <- function(nodes, segments, links, from_edge = NULL) {
 
   is_segment_used <- array(FALSE, dim = nrow(segments))
   strokes <- sf::st_sfc()
+
   for (iseg in seq_len(nrow(segments))) {
     if (is_segment_used[iseg]) next
-    stroke  <- c()
 
-    point <- segments[iseg, "start"]
+    stroke <- segments[iseg, ]
+
+    is_segment_used[iseg] <- TRUE
+
+    node  <- segments[iseg, "start"]
     link <- links[iseg, "start"]
-    current <- iseg
-    is_closed_loop <- FALSE
+    segment <- iseg
     while (TRUE) {
-      stroke <- c(point, stroke)
-      is_segment_used[current] <- TRUE
-      if (is.na(link) || is_closed_loop) break
-      point <- get_nodes(point, link, segments)
-      is_closed_loop <- point %in% stroke
-      current <- link
-      link <- links[current, names(point)]
+      if (is.na(link) || is_segment_used[link]) break
+      node <- get_next_node(node, link, segments)
+      stroke <- c(node, stroke)
+      is_segment_used[link] <- TRUE
+      new <- get_next_segment(segment, link, links)
+      segment <- link
+      link <- new
     }
 
-    point <- segments[iseg, "end"]
+    node  <- segments[iseg, "end"]
     link <- links[iseg, "end"]
-    current <- iseg
-    is_closed_loop <- FALSE
+    segment <- iseg
     while (TRUE) {
-      stroke <- c(stroke, point)
-      is_segment_used[current] <- TRUE
-      if (is.na(link) || is_closed_loop) break
-      point <- get_nodes(point, link, segments)
-      is_closed_loop <- point %in% stroke
-      current <- link
-      link <- links[current, names(point)]
+      if (is.na(link) || is_segment_used[link]) break
+      node <- get_next_node(node, link, segments)
+      stroke <- c(stroke, node)
+      is_segment_used[link] <- TRUE
+      new <- get_next_segment(segment, link, links)
+      segment <- link
+      link <- new
     }
     strokes <- c(strokes, to_linestring(stroke, nodes))
   }

tests/testthat/test-stroke.R

@@ -1,7 +1,7 @@
 #           p4
 #         /
 # p1 - p2 - p3
-#         \ |
+#         \ |  \
 #           p5 - p6
 p1 <- sf::st_point(c(0, 0))
 p2 <- sf::st_point(c(1, 0))
@@ -14,8 +14,10 @@ l1 <- sf::st_linestring(c(p1, p2))
 l2 <- sf::st_linestring(c(p2, p3))
 l3 <- sf::st_linestring(c(p2, p4))
 l4 <- sf::st_linestring(c(p2, p5))
-l5 <- sf::st_linestring(c(p5, p3))
-l6 <- sf::st_linestring(c(p5, p6))
+l5 <- sf::st_linestring(c(p3, p5))
+l6 <- sf::st_linestring(c(p3, p6))
+l7 <- sf::st_linestring(c(p5, p6))
+
 
 test_that("a stroke is found in a very simple network", {
   sfc <- sf::st_sfc(l1, l2, l3)
@@ -24,6 +26,27 @@ test_that("a stroke is found in a very simple network", {
   expect_setequal(actual, expected)
 })
 
+test_that("a ring is recognized as a stroke", {
+  sfc <- sf::st_sfc(l2, l4, l6, l7)
+  expected <- sf::st_sfc(sf::st_linestring(c(p3, p6, p5, p2, p3)))
+  actual <- stroke(sfc)
+  expect_setequal(actual, expected)
+})
+
+test_that("a ring with a branch is recognized as one stroke", {
+  sfc <- sf::st_sfc(l1, l2, l4, l6, l7)
+  expected <- sf::st_sfc(sf::st_linestring(c(p1, p2, p3, p6, p5, p2)))
+  actual <- stroke(sfc)
+  expect_setequal(actual, expected)
+})
+
+test_that("more strokes are recognized in a ring with multiple branches", {
+  sfc <- sf::st_sfc(l1, l2, l3, l4, l6, l7)
+  expected <- sf::st_sfc(sf::st_linestring(c(p1, p2, p3, p6, p5, p2)), l3)
+  actual <- stroke(sfc)
+  expect_setequal(actual, expected)
+})
+
 test_that("sf objects can be used in input", {
   sfc <- sf::st_sfc(l1, l2, l3)
   expected <- sf::st_sfc(sf::st_linestring(c(p1, p2, p3)), l3)
@@ -67,14 +90,14 @@ test_that("two linesegments are always merged if threshold is zero", {
 })
 
 test_that("a more complex network with no threshold form a stroke", {
-  sfc <- sf::st_sfc(l1, l4, l5, l6)
+  sfc <- sf::st_sfc(l1, l4, l5, l7)
   expected <- sf::st_sfc(sf::st_linestring(c(p1, p2, p5, p6)), l5)
   actual <- stroke(sfc, angle_threshold = 0)
   expect_setequal(actual, expected)
 })
 
 test_that("a more complex network with threshold does not form strokes", {
-  sfc <- sf::st_sfc(l1, l4, l5, l6)
+  sfc <- sf::st_sfc(l1, l4, l5, l7)
   expected <- sfc
   actual <- stroke(sfc, angle_threshold = 150.)
   expect_setequal(actual, expected)
@@ -108,7 +131,7 @@ test_that("edges are not split if flow_mode is true", {
 test_that("strokes can be formed starting from a given edge", {
   skip(message = "stroke from edge to be implemented")
   l1 <- sf::st_linestring(c(p1, p2, p3))
-  sfc <- sf::st_sfc(l1, l4, l6)
+  sfc <- sf::st_sfc(l1, l4, l7)
   expected <- sf::st_sfc(sf::st_linestring(c(p1, p2, p5, p6)))
   actual <- stroke(sfc, flow_mode = FALSE, from_edge = 3)
   expect_setequal(actual, expected)
@@ -127,7 +150,7 @@ test_that("strokes can be formed starting from a given line segment", {
 
 test_that("attributes can be returned if edge is specified in flow mode", {
   skip(message = "flow mode to be implemented")
-  sfc <- sf::st_sfc(l1, l2, l5, l6)
+  sfc <- sf::st_sfc(l1, l2, l5, l7)
   expected <- as.integer(c(1, NA, 1, 1))
   actual <- stroke(sfc, attribute = TRUE, flow_mode = TRUE, from_edge = 3)
   expect_setequal(actual, expected)