From 5e75cdbcb61913033f7b7e47957d563b99b918e4 Mon Sep 17 00:00:00 2001 From: mpadge Date: Thu, 27 Apr 2023 11:06:24 +0200 Subject: [PATCH] update bicycle weighting for sf networks #207 --- DESCRIPTION | 2 +- R/weight-streetnet.R | 45 ++++++++++++++++++++++++++------------------ codemeta.json | 8 ++------ 3 files changed, 30 insertions(+), 25 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a2e87e757..5cfcf08a2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: dodgr Title: Distances on Directed Graphs -Version: 0.2.20.001 +Version: 0.2.20.002 Authors@R: c( person("Mark", "Padgham", , "mark.padgham@email.com", role = c("aut", "cre")), person("Andreas", "Petutschnig", role = "aut"), diff --git a/R/weight-streetnet.R b/R/weight-streetnet.R index 753beea4b..d633e29be 100644 --- a/R/weight-streetnet.R +++ b/R/weight-streetnet.R @@ -20,8 +20,8 @@ #' `data.frame` object which provides unique identifiers for each highway #' (default works with `osmdata` objects). #' @param keep_cols Vectors of columns from `x` to be kept in the resultant -#' `dodgr` network; vector can be either names or indices of desired columns -#' (see notes). +#' `dodgr` network; vector can be either names, regex-patterns, or indices of +#' desired columns (see notes). #' @param turn_penalty Including time penalty on edges for turning across #' oncoming traffic at intersections (see Note). #' @param left_side Does traffic travel on the left side of the road (`TRUE`) or @@ -276,6 +276,14 @@ weight_streetnet.sf <- function (x, graph <- dodgr_components (graph) + if (!is.null (wt_profile_name)) { + if (wt_profile_name == "bicycle") { + if (is.integer (keep_cols)) { + keep_cols <- names (x) [keep_cols] + } + keep_cols <- unique (c (keep_cols, c ("^bicycle", "^cycleway"))) + } + } if (length (keep_cols) > 0) { graph <- reinsert_keep_cols (x, graph, keep_cols) } @@ -476,28 +484,29 @@ reinsert_keep_cols <- function (sf_lines, graph, keep_cols) { keep_names <- NULL if (is.character (keep_cols)) { - keep_names <- keep_cols - keep_cols <- match (keep_cols, names (sf_lines)) + keep_cols <- lapply (keep_cols, function (i) grep (i, names (sf_lines))) + keep_cols <- sort (unique (unlist (keep_cols))) + keep_names <- names (sf_lines) [keep_cols] # NA is no keep_cols match } else if (is.numeric (keep_cols)) { - keep_names <- names (sf_lines) [keep_cols] + if (min (keep_cols) < 1 || max (keep_cols) > nrow (sf_lines)) { + stop ( + "Numeric keep_cols must index into columns of 'sf' input", + call. = FALSE + ) + keep_names <- names (sf_lines) [keep_cols] + } } else { - stop ("keep_cols must be either character or numeric") - } - indx <- which (is.na (keep_cols)) - if (length (indx) > 0) { - message ( - "Data has no columns named ", - paste0 (keep_names, collapse = ", ") - ) + stop ("keep_cols must be either character or numeric", .call = FALSE) } - keep_cols <- keep_cols [!is.na (keep_cols)] + index <- which (!is.na (keep_cols)) + keep_cols <- keep_cols [index] + keep_names <- keep_names [index] if (length (keep_cols) > 0) { indx <- match (graph$geom_num, seq (sf_lines$geometry)) - for (k in seq (keep_names)) { - graph [[keep_names [k]]] <- sf_lines [indx, keep_cols [k], # nolint - drop = TRUE - ] + for (k in seq_along (keep_cols)) { + graph [[keep_names [k]]] <- + sf_lines [indx, keep_cols [k], drop = TRUE] } } diff --git a/codemeta.json b/codemeta.json index dd91fe37e..acb883459 100644 --- a/codemeta.json +++ b/codemeta.json @@ -7,7 +7,7 @@ "codeRepository": "https://github.com/ATFutures/dodgr", "issueTracker": "https://github.com/ATFutures/dodgr/issues", "license": "https://spdx.org/licenses/GPL-3.0", - "version": "0.2.20.1", + "version": "0.2.20.2", "programmingLanguage": { "@type": "ComputerLanguage", "name": "R", @@ -340,11 +340,7 @@ }, "SystemRequirements": "C++11, GNU make" }, -<<<<<<< HEAD - "fileSize": "28156.314KB", -======= - "fileSize": "28124.324KB", ->>>>>>> 0b4bd47e1729f244d53494eaa752de8d15ccee65 + "fileSize": "31377.214KB", "citation": [ { "@type": "ScholarlyArticle",