From a6f91a7a7ce3c0772dce521d4143c45c9df4bbf8 Mon Sep 17 00:00:00 2001 From: Francesco Nattino Date: Tue, 19 Nov 2024 10:54:24 +0100 Subject: [PATCH 1/4] join iteration on nodes and links --- R/stroke.R | 60 +++++++++++++++++++----------------------------------- 1 file changed, 21 insertions(+), 39 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index 6b89041..f13acf8 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -113,7 +113,7 @@ to_line_segments <- function(points, nodes) { #' @noRd get_links <- function(segments) { nsegments <- nrow(segments) - links <- data.frame(node_id = as.vector(segments[, 1:2])) |> + links <- data.frame(node_id = as.vector(segments)) |> dplyr::group_by(node_id) |> dplyr::group_rows() |> lapply(function(x) (x - 1) %% nsegments + 1) @@ -135,7 +135,7 @@ get_linked_segments <- function(segment_id, node_id, links) { 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, 1:2] + 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 @@ -233,28 +233,17 @@ cross_check_links <- function(best_links, flow_mode = FALSE) { } #' @noRd -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, 1:2] - # 2. exclude the given node from the list +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 - 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 - next_segment <- segments[!is_current] - # next_segment should be a single element but it is not always the case - if (length(next_segment) != 1) { - next_segment <- NA - } - return(next_segment) + # 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 @@ -274,42 +263,35 @@ merge_lines <- function( for (iseg in segments_ids) { if (is_segment_used[iseg]) next - stroke <- segments[iseg, 1:2] + stroke <- segments[iseg, ] is_segment_used[iseg] <- TRUE node <- segments[iseg, "start"] link <- links[iseg, "start"] - segment <- iseg while (TRUE) { # one segment can appear in multiple strokes when using from_edge if (is.na(link) || (is_segment_used[link] && is.null(from_edge))) break - - node <- get_next_node(node, link, segments) - stroke <- c(node, stroke) + new <- get_next(node, link, segments, links) is_segment_used[link] <- TRUE - new <- get_next_segment(segment, link, links) - segment <- link - link <- new + node <- new$node + link <- new$link + stroke <- c(node, stroke) } node <- segments[iseg, "end"] link <- links[iseg, "end"] - segment <- iseg while (TRUE) { # one segment can appear in multiple strokes when using from_edge if (is.na(link) || (is_segment_used[link] && is.null(from_edge))) break - - node <- get_next_node(node, link, segments) - stroke <- c(stroke, node) + new <- get_next(node, link, segments, links) is_segment_used[link] <- TRUE - new <- get_next_segment(segment, link, links) - segment <- link - link <- new + node <- new$node + link <- new$link + stroke <- c(stroke, node) } - strokes <- c(strokes, to_linestring(stroke, nodes)) } return(strokes) From 6a1965b5471cfa127709642b69e297db7c207eb2 Mon Sep 17 00:00:00 2001 From: Francesco Nattino Date: Tue, 19 Nov 2024 21:02:23 +0100 Subject: [PATCH 2/4] fix bug on filtering for angle_threshold --- R/stroke.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index f13acf8..f3d9b27 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -186,10 +186,10 @@ interior_angle <- function(v, p1, p2) { # compute convex angle between three points: # p1--v--p2 ("v" is the vertex) # NOTE: multiple points are supported as p1 and p2 - dx1 <- p1[, "x"] - v["x"] - dx2 <- p2[, "x"] - v["x"] - dy1 <- p1[, "y"] - v["y"] - dy2 <- p2[, "y"] - v["y"] + dx1 <- p1[, "x"] - v[["x"]] + dx2 <- p2[, "x"] - v[["x"]] + dy1 <- p1[, "y"] - v[["y"]] + dy2 <- p2[, "y"] - v[["y"]] dot_product <- dx1 * dx2 + dy1 * dy2 norm1 <- sqrt(dx1^2 + dy1^2) norm2 <- sqrt(dx2^2 + dy2^2) @@ -202,8 +202,9 @@ interior_angle <- function(v, p1, p2) { get_best_link <- function(angles, links, angle_threshold = 0) { if (length(angles) == 0) return(NA) is_above_threshold <- angles > angle_threshold + idx_above_threshold <- which(is_above_threshold) is_best_link <- which.max(angles[is_above_threshold]) - best_link <- links[is_best_link] + best_link <- links[idx_above_threshold[is_best_link]] return(best_link) } From bf884ad3f5f047a51a9401bdc7875b4708603dca Mon Sep 17 00:00:00 2001 From: Francesco Nattino Date: Tue, 19 Nov 2024 21:23:02 +0100 Subject: [PATCH 3/4] rollback change --- R/stroke.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index f3d9b27..6fa3c45 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -150,8 +150,7 @@ best_link <- function(nodes, segments, links, angle_threshold = 0) { # convert nodes to a matrix for faster indexing nodes <- as.matrix(nodes[c("x", "y")]) - dim_best_links <- c(nrow(segments), 2) - best_links <- array(integer(), dim = dim_best_links) + best_links <- array(integer(), dim = dim(segments)) colnames(best_links) <- c("start", "end") angle_threshold_rad <- angle_threshold / 180 * pi # convert to radians From 0051783734c288ccc256255323a6227aad15ea9a Mon Sep 17 00:00:00 2001 From: Francesco Nattino <49899980+fnattino@users.noreply.github.com> Date: Wed, 20 Nov 2024 10:50:24 +0100 Subject: [PATCH 4/4] more concise Co-authored-by: SarahAlidoost <55081872+SarahAlidoost@users.noreply.github.com> --- R/stroke.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/stroke.R b/R/stroke.R index 6fa3c45..ed0ddf5 100644 --- a/R/stroke.R +++ b/R/stroke.R @@ -200,9 +200,8 @@ interior_angle <- function(v, p1, p2) { #' @noRd get_best_link <- function(angles, links, angle_threshold = 0) { if (length(angles) == 0) return(NA) - is_above_threshold <- angles > angle_threshold - idx_above_threshold <- which(is_above_threshold) - is_best_link <- which.max(angles[is_above_threshold]) + idx_above_threshold <- which(angles > angle_threshold) + is_best_link <- which.max(angles[idx_above_threshold]) best_link <- links[idx_above_threshold[is_best_link]] return(best_link) }