Skip to content

Commit

Permalink
Merge branch 'main' into 14-vignette-cf
Browse files Browse the repository at this point in the history
  • Loading branch information
@cforgaci
cforgaci committed Dec 16, 2024
2 parents e12c759 + f3c006a commit ef9d0cc
Show file tree
Hide file tree
Showing 2 changed files with 118 additions and 76 deletions.
177 changes: 103 additions & 74 deletions R/stroke.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -141,18 +141,18 @@ best_link <- function(nodes, segments, links, edge_ids, flow_mode,
return(linked_nodes)
}

get_link_on_same_edge <- function(linked_segs, current_segment) {
is_same_edge <- edge_ids[linked_segs] == edge_ids[current_segment]
link_on_same_edge <- linked_segs[is_same_edge]
return(link_on_same_edge)
}

find_best_link <- function(node, opposite_node, current_segment) {
linked_segs <- get_linked_segments(current_segment, node)

get_link_on_same_edge <- function(current_segment, edge_ids) {
is_same_edge <- edge_ids[linked_segs] == edge_ids[current_segment]
link_on_same_edge <- linked_segs[is_same_edge]
return(link_on_same_edge)
}

# if in flow mode, we look for a link on the same edge
if (flow_mode) {
best_link <- get_link_on_same_edge(current_segment, edge_ids)
best_link <- get_link_on_same_edge(linked_segs, current_segment)
}
# if not in flow mode or if no link is found on the same edge, we look for
# the best link by calculating the interior angles with all connections
Expand Down Expand Up @@ -210,20 +210,6 @@ get_best_link <- function(angles, links, angle_threshold = 0) {
return(best_link)
}

#' @noRd
check_reciprocal <- function(best_links, side) {
# find the best link of the best links
bl <- best_links[best_links[, side], ]
# we check both ends to see whether the best link is reciprocal
is_best_link <- bl == seq_len(nrow(bl))
# if we have a match on either of the sides, we keep the link
is_reciprocal <- apply(is_best_link, 1, any)
# fix for NA values
is_reciprocal[is.na(is_reciprocal)] <- FALSE

return(is_reciprocal)
}

#' @noRd
cross_check_links <- function(best_links) {
links <- array(integer(), dim = dim(best_links))
Expand All @@ -240,6 +226,21 @@ cross_check_links <- function(best_links) {
return(links)
}

#' @noRd
check_reciprocal <- function(best_links, side) {
# find the best link of the best links
bl <- best_links[best_links[, side], ]
# we check both ends to see whether the best link is reciprocal
is_best_link <- bl == seq_len(nrow(bl))
# if we have a match on either of the sides, we keep the link
is_reciprocal <- apply(is_best_link, 1, any)
# fix for NA values
is_reciprocal[is.na(is_reciprocal)] <- FALSE

return(is_reciprocal)
}

#' @noRd
merge_lines <- function(nodes, segments, links, edge_ids,
from_edge = NULL, attributes = FALSE, crs = NULL) {
is_segment_used <- array(FALSE, dim = nrow(segments))
Expand All @@ -254,66 +255,31 @@ merge_lines <- function(nodes, segments, links, edge_ids,
can_reuse_segments <- TRUE
}

traverse_segments <- function(node, link, stroke_label) {
get_next <- function() {
# find node and segment connected to the current ones via the given link
# 1. get the nodes and segments connected to the given link
nodes <- segments[link, ]
segs <- links[link, ]
# 2. identify the position of the current node in the arrays (the current
# segment will be in the same position
is_current <- nodes == node
# 3. exclude current node and segment from the respective lists to find
# the new elements
return(list(node = nodes[!is_current], link = segs[!is_current]))
}
stroke <- c()
while (TRUE) {
if (is.na(link) || (is_segment_used[link] && !can_reuse_segments)) break
stroke_labels[edge_ids[link]] <- stroke_label
new <- get_next()
is_segment_used[link] <- TRUE
node <- new$node
link <- new$link
stroke <- c(node, stroke)
}
return(list(stroke = stroke, is_segment_used = is_segment_used,
stroke_labels = stroke_labels))
}

to_linestring <- function(node_id) {
points <- nodes[node_id, ]
linestring <- sfheaders::sfc_linestring(points, x = "x", y = "y")
return(linestring)
}

istroke <- 1
for (iseg in segment_ids) {
if (is_segment_used[iseg]) next

stroke <- segments[iseg, ]
is_segment_used[iseg] <- TRUE
stroke_labels[edge_ids[iseg]] <- istroke

# traverse forwards from the start node
node <- segments[iseg, "start"]
link <- links[iseg, "start"]
forward_result <- traverse_segments(node, link, istroke)
forward_stroke <- forward_result$stroke
is_segment_used <- forward_result$is_segment_used
stroke_labels <- forward_result$stroke_labels
stroke <- c(iseg)

# traverse backwards from the end node
# traverse forwards from the end node of the current segment
node <- segments[iseg, "end"]
link <- links[iseg, "end"]
backward_result <- traverse_segments(node, link, istroke)
backward_stroke <- rev(backward_result$stroke)
is_segment_used <- backward_result$is_segment_used
stroke_labels <- backward_result$stroke_labels

# combine strokes and add to results
stroke <- c(forward_stroke, stroke, backward_stroke)
strokes <- c(strokes, to_linestring(stroke))
stroke <- traverse_segments(stroke, node, link, can_reuse_segments,
segments, links, is_segment_used)

# revert the stroke to traverse backwards from the start node of the
# current segment, then revert it back to the original direction
node <- segments[iseg, "start"]
link <- links[iseg, "start"]
stroke <- rev(stroke)
stroke <- traverse_segments(stroke, node, link, can_reuse_segments,
segments, links, is_segment_used)
stroke <- rev(stroke)

# keep track of edge ids of strokes and add current stroke to strokes
is_segment_used[stroke] <- TRUE
stroke_labels[edge_ids[stroke]] <- istroke
strokes <- c(strokes, to_linestring(stroke, segments, nodes))
istroke <- istroke + 1
}

Expand All @@ -325,3 +291,66 @@ merge_lines <- function(nodes, segments, links, edge_ids,
return(strokes)
}
}

#' @noRd
to_linestring <- function(stroke, segments, nodes) {
# extract the sequence of the nodes forming the stroke (with duplicates)
segs <- segments[stroke, , drop = FALSE]
if (nrow(segs) > 1) {
# get all but the last segment in the stroke (i.e. the "target" segments)
targets <- segs[-nrow(segs), , drop = FALSE]
# get the stroke segments that immediately follow the targets (these are all
# but the first segment in the stroke)
linked <- segs[-1, , drop = FALSE]
# for each pair of target/linked segments, find the duplicate nodes (we
# check both ends of the linked segments). The sequence of repeated nodes
# makes up the body of the stroke
is_duplicate <- targets == linked[, 1] | targets == linked[, 2]
# transpose both `targets` and `is_duplicate`, so that the duplicate nodes
# appear in the correct order when applying the mask (the "segment"
# dimension should run along the rows)
repeated_nodes <- t(targets)[t(is_duplicate)]
# we now have the body of the stroke, identify the first and last nodes
first_seg <- segs[1, ]
start <- first_seg[first_seg != repeated_nodes[1]]
last_seg <- segs[nrow(segs), ]
end <- last_seg[last_seg != repeated_nodes[length(repeated_nodes)]]
# concatenate the sequence of nodes
node_ids <- c(start, repeated_nodes, end)
} else {
# if we have a single segment, its two nodes already makes up the stroke
node_ids <- segs
}
# build the linestring geometry from the sequence of nodes
points <- nodes[node_ids, ]
linestring <- sfheaders::sfc_linestring(points, x = "x", y = "y")
return(linestring)
}

#' @noRd
traverse_segments <- function(stroke, node, link, can_reuse_segments,
segments, links, is_segment_used) {

get_next <- function(node, link) {
# find node and segment connected to the current ones via the given link
# 1. get the nodes and segments connected to the given link
nodes <- segments[link, ]
segs <- links[link, ]
# 2. identify the position of the current node in the arrays (the current
# segment will be in the same position
is_current <- nodes == node
# 3. exclude current node and segment from the respective lists to find
# the new elements
return(list(node = nodes[!is_current], link = segs[!is_current]))
}

while (TRUE) {
if (is.na(link) || (link %in% stroke) ||
(is_segment_used[link] && !can_reuse_segments)) break
stroke <- c(stroke, link)
new <- get_next(node, link)
node <- new$node
link <- new$link
}
return(stroke)
}
17 changes: 15 additions & 2 deletions tests/testthat/test-stroke.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,15 +24,14 @@ test_that("a stroke is found in a very simple network", {
# p4
# /
# p1 - p2 - p3

expected <- sf::st_sfc(sf::st_linestring(c(p1, p2, p3)), l3)
actual <- stroke(sfc)
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)))
expected <- sf::st_sfc(sf::st_linestring(c(p2, p3, p6, p5, p2)))
actual <- stroke(sfc)
expect_setequal(actual, expected)
})
Expand Down Expand Up @@ -144,6 +143,13 @@ test_that("edges are not split if flow_mode is true", {
expect_setequal(actual, expected)
})

test_that("a ring is recognized as a stroke also in flow_mode", {
sfc <- sf::st_sfc(l2, l4, l6, l7)
expected <- sf::st_sfc(sf::st_linestring(c(p2, p3, p6, p5, p2)))
actual <- stroke(sfc, flow_mode = TRUE)
expect_setequal(actual, expected)
})

test_that("strokes can be formed starting from a given edge", {
new_l1 <- sf::st_linestring(c(p1, p2, p3))
sfc <- sf::st_sfc(new_l1, l4, l7)
Expand Down Expand Up @@ -182,3 +188,10 @@ test_that("attributes can't be returned if edge is specified", {
expect_error(stroke(sfc, attribute = TRUE, flow_mode = TRUE, from_edge = 3),
"from_edge is not compatible with attributes or flow_mode")
})

test_that("a ring is recognized when from_edge is specified", {
sfc <- sf::st_sfc(l2, l4, l6, l7)
expected <- sf::st_sfc(sf::st_linestring(c(p2, p3, p6, p5, p2)))
actual <- stroke(sfc, from_edge = 1)
expect_setequal(actual, expected)
})

0 comments on commit ef9d0cc

Please sign in to comment.