Refactor with closures

R/stroke.R

@@ -111,35 +111,55 @@ get_links <- function(segments) {
 }
 
 #' @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)
-}
+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)
+  }
 
-#' @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)
-}
+  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)
+  }
 
-#' @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")])
+  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)
+    }
+    # 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)
+      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")
@@ -148,48 +168,17 @@ best_link <- function(
     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_link_end <- find_best_link(end_node, start_node, iseg)
     if (length(best_link_end) > 0)
       best_links[iseg, "end"] <- best_link_end
   }
   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]
-  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:
@@ -246,59 +235,53 @@ 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)
-}
-
-#' @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
   } else {
     segment_ids <- which(edge_ids %in% from_edge)
     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
@@ -310,28 +293,25 @@ 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
 
     # 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
 
     # 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
   }
+
   # only at the end, add CRS
   sf::st_crs(strokes) <- sf::st_crs(crs)
   if (attributes) {