diff --git a/R/get_elements_by_type.R b/R/get_elements_by_type.R index 625a177..4c38975 100644 --- a/R/get_elements_by_type.R +++ b/R/get_elements_by_type.R @@ -25,28 +25,55 @@ get_elements_by_type <- function(x, result = NULL, dbg = TRUE) { if (is.null(result)) { - kwb.utils::catAndRun(dbg = dbg, "Analysing the parse tree", { - result <- analyse(x) - }) + kwb.utils::catAndRun( + "Analysing the parse tree", + dbg = dbg, + expr = { + result <- analyse(x) + } + ) } type_paths <- get_paths_to_types(result) - code_parts <- lapply(type_paths, extract_by_path, x = x) - - stats::setNames(code_parts, names(type_paths)) + type_paths %>% + lapply(extract_by_path, x = x) %>% + stats::setNames(names(type_paths)) } # extract_by_path -------------------------------------------------------------- extract_by_path <- function(x, paths) { - # Remove leading slash from the type path - clean_paths <- gsub("^/", "", paths) + stopifnot(is.list(x)) + + paths %>% + + # Split the path strings into vectors of integer + split_index_path() %>% + + # Use the segments of the type path as (recursive) list indices + lapply(function(indices) { + if (length(indices)) { + x[[indices]] + } + }) +} + +# split_index_path ------------------------------------------------------------- +split_index_path <- function(x) +{ + stopifnot(is.character(x)) + stopifnot(all(is_index_path(x))) - # Use the segments of the type path as (recursive) list indices - lapply(strsplit(clean_paths, "/"), function(indices) { - if (length(indices)) { - x[[as.integer(indices)]] - } - }) + x %>% + remove_first_and_last_slash() %>% + strsplit("/") %>% + lapply(as.integer) +} + +# is_index_path ---------------------------------------------------------------- +# @examples is_index_path(c("1", "/1", "/11", "1/2/3")) +is_index_path <- function(x) +{ + grepl("^/?([0-9]+/?)+$", x) } diff --git a/R/utils.R b/R/utils.R index 975f74e..bb3c982 100644 --- a/R/utils.R +++ b/R/utils.R @@ -90,6 +90,12 @@ is_what <- function( gsub("^is.", "", names(which(is_results))) } +# remove_first_and_last_slash -------------------------------------------------- +remove_first_and_last_slash <- function(x) +{ + gsub("^/+|/+$", "", x) +} + # vector_to_count_table -------------------------------------------------------- vector_to_count_table <- function(x) { diff --git a/tests/testthat/test-function-extract_by_path.R b/tests/testthat/test-function-extract_by_path.R index b1a5922..aae0ce8 100644 --- a/tests/testthat/test-function-extract_by_path.R +++ b/tests/testthat/test-function-extract_by_path.R @@ -1,16 +1,28 @@ -# -# This test file has been generated by kwb.test::create_test_files() -# launched by user hauke on 2021-11-27 17:51:42. -# Your are strongly encouraged to modify the dummy functions -# so that real cases are tested. You should then delete this comment. -# +#library(testthat) test_that("extract_by_path() works", { - expect_error( - kwb.code:::extract_by_path() - # Argument "paths" fehlt (ohne Standardwert) + f <- kwb.code:::extract_by_path + + expect_error(f()) + expect_error(f("a")) + + x <- list( + list( # [[1]] + 11, + 12 + ), + list( # [[2]] + 21, + 22, + list( + 231, + 232 + ) + ) ) - + + expect_identical(f(x, "1"), x[1L]) + expect_identical(f(x, c("1", "2")), x[c(1, 2)]) + expect_identical(f(x, c("/1/1", "2/2", "/2/3/2")), list(11, 22, 232)) }) -