From d57029711b6b3ca992cce1d4195b81efd6540a9f Mon Sep 17 00:00:00 2001 From: wangzhao0217 Date: Thu, 14 Mar 2024 16:40:33 +0000 Subject: [PATCH 1/9] add handle_strings to rnet_join --- R/rnet_join.R | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/R/rnet_join.R b/R/rnet_join.R index 444c5a66..2fbea1a1 100644 --- a/R/rnet_join.R +++ b/R/rnet_join.R @@ -224,16 +224,44 @@ line_cast <- function(x) { #' # rnet_y = sf::read_sf("rnet_y_ed.geojson") #' # rnet_merged = rnet_merge(rnet_x, rnet_y, dist = 9, segment_length = 20, funs = funs) #' @return An sf object with the same geometry as `rnet_x` +#' +rnet_y = sf::read_sf("rnet_y_ed.geojson") +#add a string column to rnet_y with random strings +rnet_y$random_string = sample(letters, nrow(rnet_y), replace = TRUE) + + + rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, crs = geo_select_aeq(rnet_x), ...) { + browser() + # handle_strings = function(strings) { + # unique_strings = unique(strings) + # paste(unique_strings, collapse = "; ") + # } + handle_strings <- function(strings) { + # Calculate the frequency of each unique string + string_freq <- table(strings) + + # Find the string(s) with the highest frequency + most_frequent_string <- names(which.max(string_freq)) + + return(most_frequent_string) + } if (is.null(funs)) { print("funs is NULL") funs <- list() for (col in names(rnet_y)) { - if (is.numeric(rnet_y[[col]])) { + if (col == "geometry") { + next # Skip the current iteration + } else if (is.numeric(rnet_y[[col]])) { funs[[col]] <- sum + } else if (is.character(r2[[name]])) { + funs[[col]] = handle_strings + } else if (col %in% c("gradient", "quietness")) { + funs[[col]] = mean } } } + sum_cols <- sapply(funs, function(f) identical(f, sum)) sum_cols <- names(funs)[which(sum_cols)] rnetj <- rnet_join(rnet_x, rnet_y, dist = dist, crs = crs, ...) From 3e7666dca4b855670161c972d675907ee3286d43 Mon Sep 17 00:00:00 2001 From: wangzhao0217 Date: Thu, 14 Mar 2024 16:41:54 +0000 Subject: [PATCH 2/9] remove brower --- R/rnet_join.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/rnet_join.R b/R/rnet_join.R index 2fbea1a1..acadb3f4 100644 --- a/R/rnet_join.R +++ b/R/rnet_join.R @@ -232,7 +232,7 @@ rnet_y$random_string = sample(letters, nrow(rnet_y), replace = TRUE) rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, crs = geo_select_aeq(rnet_x), ...) { - browser() + # handle_strings = function(strings) { # unique_strings = unique(strings) # paste(unique_strings, collapse = "; ") @@ -265,7 +265,7 @@ rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, sum_cols <- sapply(funs, function(f) identical(f, sum)) sum_cols <- names(funs)[which(sum_cols)] rnetj <- rnet_join(rnet_x, rnet_y, dist = dist, crs = crs, ...) - names(rnetj) + rnetj_df <- sf::st_drop_geometry(rnetj) # Apply functions to columns with lapply: res_list <- lapply(seq_along(funs), function(i) { From 4b11a2e22d2dfe79024f2d287c48312c282dc0bd Mon Sep 17 00:00:00 2001 From: wangzhao0217 Date: Thu, 14 Mar 2024 16:42:45 +0000 Subject: [PATCH 3/9] remove lines --- R/rnet_join.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/rnet_join.R b/R/rnet_join.R index acadb3f4..2c31e9c2 100644 --- a/R/rnet_join.R +++ b/R/rnet_join.R @@ -225,9 +225,9 @@ line_cast <- function(x) { #' # rnet_merged = rnet_merge(rnet_x, rnet_y, dist = 9, segment_length = 20, funs = funs) #' @return An sf object with the same geometry as `rnet_x` #' -rnet_y = sf::read_sf("rnet_y_ed.geojson") -#add a string column to rnet_y with random strings -rnet_y$random_string = sample(letters, nrow(rnet_y), replace = TRUE) +# rnet_y = sf::read_sf("rnet_y_ed.geojson") +# #add a string column to rnet_y with random strings +# rnet_y$random_string = sample(letters, nrow(rnet_y), replace = TRUE) From 61f6f0e3163bacb58cdf3fcfc306fcbc5f28f102 Mon Sep 17 00:00:00 2001 From: wangzhao0217 Date: Thu, 14 Mar 2024 16:54:33 +0000 Subject: [PATCH 4/9] fixing a bug --- R/rnet_join.R | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/R/rnet_join.R b/R/rnet_join.R index 2c31e9c2..0b1fb6c7 100644 --- a/R/rnet_join.R +++ b/R/rnet_join.R @@ -225,10 +225,6 @@ line_cast <- function(x) { #' # rnet_merged = rnet_merge(rnet_x, rnet_y, dist = 9, segment_length = 20, funs = funs) #' @return An sf object with the same geometry as `rnet_x` #' -# rnet_y = sf::read_sf("rnet_y_ed.geojson") -# #add a string column to rnet_y with random strings -# rnet_y$random_string = sample(letters, nrow(rnet_y), replace = TRUE) - rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, crs = geo_select_aeq(rnet_x), ...) { @@ -246,6 +242,7 @@ rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, return(most_frequent_string) } + if (is.null(funs)) { print("funs is NULL") funs <- list() @@ -254,7 +251,7 @@ rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, next # Skip the current iteration } else if (is.numeric(rnet_y[[col]])) { funs[[col]] <- sum - } else if (is.character(r2[[name]])) { + } else if (is.character(rnet_y[[name]])) { funs[[col]] = handle_strings } else if (col %in% c("gradient", "quietness")) { funs[[col]] = mean From 51a049d14fda4ddb3bbf2e9e921eaa7d738682d6 Mon Sep 17 00:00:00 2001 From: robinlovelace Date: Thu, 14 Mar 2024 17:05:53 +0000 Subject: [PATCH 5/9] Update merging route networks vignette --- vignettes/merging-route-networks.Rmd | 84 ++++++++-------------------- 1 file changed, 22 insertions(+), 62 deletions(-) diff --git a/vignettes/merging-route-networks.Rmd b/vignettes/merging-route-networks.Rmd index 5b1d7f9c..18649d44 100644 --- a/vignettes/merging-route-networks.Rmd +++ b/vignettes/merging-route-networks.Rmd @@ -11,9 +11,9 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, # # Uncomment to speed-up build - eval = FALSE, + eval = TRUE, comment = "#>", - echo = FALSE, + echo = TRUE, message = FALSE, warning = FALSE ) @@ -22,7 +22,8 @@ sf::sf_use_s2(FALSE) ``` ```{r setup} -library(stplanr) +# library(stplanr) +devtools::load_all() library(dplyr) library(tmap) library(ggplot2) @@ -88,6 +89,7 @@ system.time({ Let's check the results: ```{r} +names(rnet_merged) summary(rnet_merged$value) summary(rnet_y$value) sum(rnet_merged$value * sf::st_length(rnet_merged), na.rm = TRUE) @@ -141,6 +143,23 @@ sum(rnet_merged$value * sf::st_length(rnet_merged), na.rm = TRUE) sum(rnet_y$value * sf::st_length(rnet_y), na.rm = TRUE) ``` +It also works with charaster strings: + +```{r} +rnet_y$char = paste0("road", sample(1:3, nrow(rnet_y), replace = TRUE)) +most_common = function(x) { + ux = unique(x) + ux[which.max(tabulate(match(x, ux)))] +} +funs = list(char = most_common) +system.time({ + rnet_merged = rnet_merge(rnet_x, rnet_y, dist = 10, segment_length = 20, funs = funs) +}) +plot(rnet_y["char"]) +plot(rnet_merged["char"]) + +``` + Now let's testing on 3km dataset ```{r} @@ -188,62 +207,3 @@ summary(exmaple_3km$all_fastest_bicycle) sum(exmaple_3km$all_fastest_bicycle * sf::st_length(exmaple_3km), na.rm = TRUE) sum(rnet_y$all_fastest_bicycle * sf::st_length(rnet_y), na.rm = TRUE) ``` - -Now let's testing on large dataset - -```{r} -rnet_x = sf::read_sf("https://github.com/nptscot/networkmerge/releases/download/v0.1/OS_large_route_network_example_edingurgh.geojson") -rnet_y = sf::read_sf("https://github.com/nptscot/networkmerge/releases/download/v0.1/large_route_network_example_edingurgh.geojson") - -``` - -Read columns from rnet_y to assign functions to them -```{r} -# Extract column names from the rnet_x data frame -name_list <- names(rnet_y) -name_list -# Initialize an empty list -funs <- list() - -# Loop through each name and assign it a function based on specific conditions -for (name in name_list) { - if (name == "geometry") { - next # Skip the current iteration - } else if (name %in% c("Gradient", "Quietness")) { - funs[[name]] <- mean - } else { - funs[[name]] <- sum - } -} -``` - -```{r, eval = FALSE} -# Take 0.1% sample: -# ... -# Buffer of the 0.1% sample -# ... -# Select OS road data that intersects -# rnet_x = rnet_x[osm_buffer, ] # or similar - -brks = c(0, 100, 500, 1000, 5000,10000) -rnet_merged = rnet_merge(rnet_x, rnet_y, dist = 20, segment_length = 10, funs = funs, max_angle_diff = 20, crs = "EPSG:27700") -st_write(rnet_merged, "data-raw/large_exmaple_merged.geojson", driver = "GeoJSON") -rnet_merged <- st_make_valid(rnet_merged) -m1 = tm_shape(rnet_y) + tm_lines("all_fastest_bicycle", palette = "viridis", lwd = 5, breaks = brks) -m2 = tm_shape(rnet_merged) + tm_lines("all_fastest_bicycle", palette = "viridis", lwd = 5, breaks = brks) -tmap_arrange(m1, m2, sync = TRUE, nrow = 1) -dim(rnet_merged) -st_write(rnet_merged, "data-raw/large_exmaple_merged.geojson", driver = "GeoJSON") -``` - -Read large_exmaple_merged from github -```{r} -large_exmaple_merged = sf::read_sf("https://github.com/nptscot/networkmerge/releases/download/v0.1/large_exmaple_merged.geojson") - -summary(rnet_y$all_fastest_bicycle) -summary(large_exmaple_merged$all_fastest_bicycle) -sum(large_exmaple_merged$all_fastest_bicycle * sf::st_length(large_exmaple_merged), na.rm = TRUE) -sum(rnet_y$all_fastest_bicycle * sf::st_length(rnet_y), na.rm = TRUE) - -plot(large_exmaple_merged) -``` \ No newline at end of file From 0e11e3a2c8b1e61ca581bb7fa976c11ca2b7d36c Mon Sep 17 00:00:00 2001 From: robinlovelace Date: Thu, 14 Mar 2024 17:06:33 +0000 Subject: [PATCH 6/9] Eval false on big vignette --- vignettes/merging-route-networks.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/merging-route-networks.Rmd b/vignettes/merging-route-networks.Rmd index 18649d44..c7e97a3d 100644 --- a/vignettes/merging-route-networks.Rmd +++ b/vignettes/merging-route-networks.Rmd @@ -11,7 +11,7 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, # # Uncomment to speed-up build - eval = TRUE, + eval = FALSE, comment = "#>", echo = TRUE, message = FALSE, From b9f42516587026cf116d9cde27b2c7c135bf36e1 Mon Sep 17 00:00:00 2001 From: robinlovelace Date: Thu, 14 Mar 2024 17:11:31 +0000 Subject: [PATCH 7/9] Document --- man/rnet_group.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/rnet_group.Rd b/man/rnet_group.Rd index d1245356..b0ccc051 100644 --- a/man/rnet_group.Rd +++ b/man/rnet_group.Rd @@ -33,7 +33,7 @@ rnet_group(rnet, ...) \item{...}{Arguments passed to other methods.} \item{cluster_fun}{The clustering function to use. Various clustering functions -are available in the \code{igraph} package. Default: \code{\link[igraph:components]{igraph::clusters()}}.} +are available in the \code{igraph} package. Default: \code{\link[igraph:clusters]{igraph::clusters()}}.} \item{d}{Optional distance variable used to classify segments that are close (within a certain distance specified by \code{d}) to each other but not From f3f81397da2cbea6601d7404300581531b1b388b Mon Sep 17 00:00:00 2001 From: wangzhao0217 Date: Thu, 14 Mar 2024 17:11:58 +0000 Subject: [PATCH 8/9] change name to col --- R/rnet_join.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/rnet_join.R b/R/rnet_join.R index 0b1fb6c7..44dc31e7 100644 --- a/R/rnet_join.R +++ b/R/rnet_join.R @@ -250,8 +250,8 @@ rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, if (col == "geometry") { next # Skip the current iteration } else if (is.numeric(rnet_y[[col]])) { - funs[[col]] <- sum - } else if (is.character(rnet_y[[name]])) { + funs[[col]] = sum + } else if (is.character(rnet_y[[col]])) { funs[[col]] = handle_strings } else if (col %in% c("gradient", "quietness")) { funs[[col]] = mean From 336c208f08070b8a1723ba3ebc5568365046777a Mon Sep 17 00:00:00 2001 From: robinlovelace Date: Thu, 14 Mar 2024 17:21:55 +0000 Subject: [PATCH 9/9] Move function outside of function! --- R/rnet_join.R | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/R/rnet_join.R b/R/rnet_join.R index 44dc31e7..83874e21 100644 --- a/R/rnet_join.R +++ b/R/rnet_join.R @@ -224,7 +224,7 @@ line_cast <- function(x) { #' # rnet_y = sf::read_sf("rnet_y_ed.geojson") #' # rnet_merged = rnet_merge(rnet_x, rnet_y, dist = 9, segment_length = 20, funs = funs) #' @return An sf object with the same geometry as `rnet_x` -#' +#' rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, crs = geo_select_aeq(rnet_x), ...) { @@ -233,15 +233,6 @@ rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, # unique_strings = unique(strings) # paste(unique_strings, collapse = "; ") # } - handle_strings <- function(strings) { - # Calculate the frequency of each unique string - string_freq <- table(strings) - - # Find the string(s) with the highest frequency - most_frequent_string <- names(which.max(string_freq)) - - return(most_frequent_string) - } if (is.null(funs)) { print("funs is NULL") @@ -258,7 +249,7 @@ rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, } } } - + sum_cols <- sapply(funs, function(f) identical(f, sum)) sum_cols <- names(funs)[which(sum_cols)] rnetj <- rnet_join(rnet_x, rnet_y, dist = dist, crs = crs, ...) @@ -302,3 +293,13 @@ rnet_merge <- function(rnet_x, rnet_y, dist = 5, funs = NULL, sum_flows = TRUE, } res_sf } + +handle_strings <- function(strings) { + # Calculate the frequency of each unique string + string_freq <- table(strings) + + # Find the string(s) with the highest frequency + most_frequent_string <- names(which.max(string_freq)) + + return(most_frequent_string) +}