From b02d54d237f9f74dc7e74f32ce36ba24c2951c4e Mon Sep 17 00:00:00 2001 From: Claudiu Forgaci Date: Sun, 1 Dec 2024 13:40:24 +0100 Subject: [PATCH 1/7] Refactor traverse_segments into closure --- R/stroke.R | 51 +++++++++++++++++++++++---------------------------- 1 file changed, 23 insertions(+), 28 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index a70491b..ce18487 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -267,31 +267,12 @@ to_linestring <- function(node_id, nodes) { return(linestring) } -#' @noRd -traverse_segments <- function(node, link, stroke_label, segments, - links, edge_ids, is_segment_used, stroke_labels, - can_reuse_segments) { - 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(node, link, segments, links) - 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)) -} - -merge_lines <- function( - nodes, segments, links, edge_ids, from_edge = NULL, attributes = FALSE, - crs = NULL -) { +merge_lines <- function(nodes, segments, links, edge_ids, + from_edge = NULL, attributes = FALSE, crs = NULL) { is_segment_used <- array(FALSE, dim = nrow(segments)) stroke_labels <- array(integer(), dim = max(edge_ids)) strokes <- sf::st_sfc() + if (is.null(from_edge)) { segment_ids <- seq_len(nrow(segments)) can_reuse_segments <- FALSE @@ -299,7 +280,24 @@ merge_lines <- function( segment_ids <- which(edge_ids %in% from_edge) can_reuse_segments <- TRUE } + istroke <- 1 + + traverse_segments <- function(node, link, stroke_label) { + 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(node, link, segments, links) + 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)) + } + for (iseg in segment_ids) { if (is_segment_used[iseg]) next @@ -310,9 +308,7 @@ merge_lines <- function( # traverse forwards from the start node node <- segments[iseg, "start"] link <- links[iseg, "start"] - forward_result <- traverse_segments(node, link, istroke, segments, links, - edge_ids, is_segment_used, - stroke_labels, can_reuse_segments) + 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 @@ -320,9 +316,7 @@ merge_lines <- function( # traverse backwards from the end node node <- segments[iseg, "end"] link <- links[iseg, "end"] - backward_result <- traverse_segments(node, link, istroke, segments, links, - edge_ids, is_segment_used, - stroke_labels, can_reuse_segments) + 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 @@ -332,6 +326,7 @@ merge_lines <- function( strokes <- c(strokes, to_linestring(stroke, nodes)) istroke <- istroke + 1 } + # only at the end, add CRS sf::st_crs(strokes) <- sf::st_crs(crs) if (attributes) { From aeb24caf4c5b3d257100a31e3f45b7952f522a10 Mon Sep 17 00:00:00 2001 From: Claudiu Forgaci Date: Sun, 1 Dec 2024 13:46:24 +0100 Subject: [PATCH 2/7] Fix lintr issues --- R/stroke.R | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index ce18487..9af696a 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -272,7 +272,7 @@ merge_lines <- function(nodes, segments, links, edge_ids, is_segment_used <- array(FALSE, dim = nrow(segments)) stroke_labels <- array(integer(), dim = max(edge_ids)) strokes <- sf::st_sfc() - + if (is.null(from_edge)) { segment_ids <- seq_len(nrow(segments)) can_reuse_segments <- FALSE @@ -280,24 +280,23 @@ merge_lines <- function(nodes, segments, links, edge_ids, segment_ids <- which(edge_ids %in% from_edge) can_reuse_segments <- TRUE } - - istroke <- 1 - + traverse_segments <- function(node, link, stroke_label) { - 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(node, link, segments, links) - 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)) + 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(node, link, segments, links) + 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)) } - + + istroke <- 1 for (iseg in segment_ids) { if (is_segment_used[iseg]) next From f39d1600ad587d2c2580f61274d2bb6e3233666e Mon Sep 17 00:00:00 2001 From: Claudiu Forgaci Date: Sun, 1 Dec 2024 13:57:43 +0100 Subject: [PATCH 3/7] Refactor best_link to use find_best_link as closure --- R/stroke.R | 44 +++++++++++++++++++------------------------- 1 file changed, 19 insertions(+), 25 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index 9af696a..6f905ba 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -135,11 +135,25 @@ get_linked_nodes <- function(node_id, segment_id, segments) { } #' @noRd -best_link <- function( - nodes, segments, links, edge_ids, flow_mode, angle_threshold = 0 -) { - # convert nodes to a matrix for faster indexing - nodes <- as.matrix(nodes[c("x", "y")]) +best_link <- function(nodes, segments, links, edge_ids, flow_mode, + angle_threshold = 0) { + find_best_link <- function(node, opposite_node, current_segment) { + linked_segs <- get_linked_segments(current_segment, node, links) + # if in flow mode, we look for a link on the same edge + if (flow_mode) { + best_link <- get_link_on_same_edge(linked_segs, current_segment, edge_ids) + } + # 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 + if (length(best_link) == 0 || !flow_mode) { + linked_nodes <- get_linked_nodes(node, linked_segs, segments) + angles <- interior_angle(nodes[node, ], + nodes[opposite_node, , drop = FALSE], + nodes[linked_nodes, , drop = FALSE]) + best_link <- get_best_link(angles, linked_segs, angle_threshold) + } + return(best_link) + } best_links <- array(integer(), dim = dim(segments)) colnames(best_links) <- c("start", "end") @@ -163,26 +177,6 @@ best_link <- function( return(best_links) } -#' @noRd -find_best_link <- function(node, opposite_node, current_segment, segments, - links, nodes, edge_ids, flow_mode, angle_threshold) { - linked_segs <- get_linked_segments(current_segment, node, links) - # if in flow mode, we look for a link on the same edge - if (flow_mode) { - best_link <- get_link_on_same_edge(linked_segs, current_segment, edge_ids) - } - # 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 - if (length(best_link) == 0 || !flow_mode) { - linked_nodes <- get_linked_nodes(node, linked_segs, segments) - angles <- interior_angle(nodes[node, ], - nodes[opposite_node, , drop = FALSE], - nodes[linked_nodes, , drop = FALSE]) - best_link <- get_best_link(angles, linked_segs, angle_threshold) - } - return(best_link) -} - #' @noRd get_link_on_same_edge <- function(links, current_segment, edge_ids) { is_same_edge <- edge_ids[links] == edge_ids[current_segment] From 865a4ec2fff13c9333ad77aae52cfe6b11eed53f Mon Sep 17 00:00:00 2001 From: Claudiu Forgaci Date: Sun, 1 Dec 2024 14:01:21 +0100 Subject: [PATCH 4/7] Fix call to updated find_best_link --- R/stroke.R | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index 6f905ba..cd0e314 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -162,17 +162,13 @@ best_link <- function(nodes, segments, links, edge_ids, flow_mode, start_node <- segments[iseg, "start"] end_node <- segments[iseg, "end"] - best_link_start <- find_best_link(start_node, end_node, iseg, segments, - links, nodes, edge_ids, flow_mode, - angle_threshold) + best_link_start <- find_best_link(start_node, end_node, iseg) if (length(best_link_start) > 0) - best_links[iseg, "start"] <- best_link_start - - best_link_end <- find_best_link(end_node, start_node, iseg, segments, - links, nodes, edge_ids, flow_mode, - angle_threshold) + best_links[iseg, "start"] <- best_link_start + + best_link_end <- find_best_link(end_node, start_node, iseg) if (length(best_link_end) > 0) - best_links[iseg, "end"] <- best_link_end + best_links[iseg, "end"] <- best_link_end } return(best_links) } From 0083463004f3a81b4c51a282b61c35b4a75a2ae1 Mon Sep 17 00:00:00 2001 From: Claudiu Forgaci Date: Sun, 1 Dec 2024 15:55:38 +0100 Subject: [PATCH 5/7] Fix lintr issues --- R/stroke.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index cd0e314..26a4ead 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -164,11 +164,11 @@ best_link <- function(nodes, segments, links, edge_ids, flow_mode, best_link_start <- find_best_link(start_node, end_node, iseg) if (length(best_link_start) > 0) - best_links[iseg, "start"] <- best_link_start - + best_links[iseg, "start"] <- best_link_start + best_link_end <- find_best_link(end_node, start_node, iseg) if (length(best_link_end) > 0) - best_links[iseg, "end"] <- best_link_end + best_links[iseg, "end"] <- best_link_end } return(best_links) } From ef9334ec5e764d320efbdf5b0bc5b1fa768105d3 Mon Sep 17 00:00:00 2001 From: Claudiu Forgaci Date: Mon, 2 Dec 2024 17:32:17 +0100 Subject: [PATCH 6/7] Refactor remaining functions As indicated in https://github.com/CityRiverSpaces/rcoins/pull/32#pullrequestreview-2472254422 --- R/stroke.R | 110 ++++++++++++++++++++++++++--------------------------- 1 file changed, 53 insertions(+), 57 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index 26a4ead..a5d935b 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -110,43 +110,49 @@ get_links <- function(segments) { return(links) } -#' @noRd -get_linked_segments <- function(segment_id, node_id, links) { - # find the segments connected to the given one via the given node - # 1. find all segments connected to the node - segs <- links[[node_id]] - # 2. exclude the given segment from the list - is_current_segment <- segs == segment_id - linked_segments <- segs[!is_current_segment] - return(linked_segments) -} - -#' @noRd -get_linked_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, ] - # 2. flatten the array row by row (i.e. along the node dimension) - nds <- as.vector(t(nds)) - # 3. exclude the given node from the list - is_current_node <- nds %in% node_id - linked_nodes <- nds[!is_current_node] - return(linked_nodes) -} - #' @noRd best_link <- function(nodes, segments, links, edge_ids, flow_mode, angle_threshold = 0) { + + get_linked_segments <- function(segment_id, node_id) { + # find the segments connected to the given one via the given node + # 1. find all segments connected to the node + segs <- links[[node_id]] + # 2. exclude the given segment from the list + is_current_segment <- segs == segment_id + linked_segments <- segs[!is_current_segment] + return(linked_segments) + } + + get_linked_nodes <- function(node_id, segment_id) { + # 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, ] + # 2. flatten the array row by row (i.e. along the node dimension) + nds <- as.vector(t(nds)) + # 3. exclude the given node from the list + is_current_node <- nds %in% node_id + linked_nodes <- nds[!is_current_node] + return(linked_nodes) + } + find_best_link <- function(node, opposite_node, current_segment) { - linked_segs <- get_linked_segments(current_segment, node, links) + 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(linked_segs, current_segment, edge_ids) + best_link <- get_link_on_same_edge(current_segment, edge_ids) } # 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 if (length(best_link) == 0 || !flow_mode) { - linked_nodes <- get_linked_nodes(node, linked_segs, segments) + linked_nodes <- get_linked_nodes(node, linked_segs) angles <- interior_angle(nodes[node, ], nodes[opposite_node, , drop = FALSE], nodes[linked_nodes, , drop = FALSE]) @@ -173,13 +179,6 @@ best_link <- function(nodes, segments, links, edge_ids, flow_mode, return(best_links) } -#' @noRd -get_link_on_same_edge <- function(links, current_segment, edge_ids) { - is_same_edge <- edge_ids[links] == edge_ids[current_segment] - link_on_same_edge <- links[is_same_edge] - return(link_on_same_edge) -} - #' @noRd interior_angle <- function(v, p1, p2) { # compute convex angle between three points: @@ -236,27 +235,6 @@ cross_check_links <- function(best_links) { return(links) } -#' @noRd -get_next <- function(node, link, segments, links) { - # find the 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 the current node and segment from the respective lists to find - # the new elements - return(list(node = nodes[!is_current], link = segs[!is_current])) -} - -#' @noRd -to_linestring <- function(node_id, nodes) { - points <- nodes[node_id, ] - linestring <- sfheaders::sfc_linestring(points, x = "x", y = "y") - return(linestring) -} - merge_lines <- function(nodes, segments, links, edge_ids, from_edge = NULL, attributes = FALSE, crs = NULL) { is_segment_used <- array(FALSE, dim = nrow(segments)) @@ -272,11 +250,23 @@ merge_lines <- function(nodes, segments, links, edge_ids, } traverse_segments <- function(node, link, stroke_label) { + get_next <- function() { + # find the 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 the 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(node, link, segments, links) + new <- get_next() is_segment_used[link] <- TRUE node <- new$node link <- new$link @@ -285,6 +275,12 @@ merge_lines <- function(nodes, segments, links, edge_ids, 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) { @@ -312,7 +308,7 @@ merge_lines <- function(nodes, segments, links, edge_ids, # combine strokes and add to results stroke <- c(forward_stroke, stroke, backward_stroke) - strokes <- c(strokes, to_linestring(stroke, nodes)) + strokes <- c(strokes, to_linestring(stroke)) istroke <- istroke + 1 } From 2b1bb808724542c731be5b5e001aa97dd12bde7a Mon Sep 17 00:00:00 2001 From: Claudiu Forgaci Date: Mon, 2 Dec 2024 17:34:20 +0100 Subject: [PATCH 7/7] Fix lintr issues --- R/stroke.R | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index a5d935b..972c745 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -113,7 +113,7 @@ get_links <- function(segments) { #' @noRd best_link <- function(nodes, segments, links, edge_ids, flow_mode, angle_threshold = 0) { - + get_linked_segments <- function(segment_id, node_id) { # find the segments connected to the given one via the given node # 1. find all segments connected to the node @@ -123,7 +123,7 @@ best_link <- function(nodes, segments, links, edge_ids, flow_mode, linked_segments <- segs[!is_current_segment] return(linked_segments) } - + get_linked_nodes <- function(node_id, segment_id) { # 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) @@ -134,17 +134,17 @@ best_link <- function(nodes, segments, links, edge_ids, flow_mode, is_current_node <- nds %in% node_id linked_nodes <- nds[!is_current_node] return(linked_nodes) - } - + } + 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) + 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) @@ -251,14 +251,14 @@ merge_lines <- function(nodes, segments, links, edge_ids, traverse_segments <- function(node, link, stroke_label) { get_next <- function() { - # find the node and segment connected to the current ones via the given 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 the current node and segment from the respective lists to find + # 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])) } @@ -275,7 +275,7 @@ merge_lines <- function(nodes, segments, links, edge_ids, 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")