From a62c356e42ed4f6d0cf0f3dce054461e87db8b3c Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 17 Nov 2023 14:14:05 +0100 Subject: [PATCH] review 1 --- R/join_keys-extract.R | 26 ++++++++++----------- R/join_keys-names.R | 9 ++----- tests/testthat/test-join_keys-extract.R | 31 +++++++++++++++++++++---- tests/testthat/test-join_keys-print.R | 21 +++++++++++++++++ tests/testthat/test-join_keys.R | 7 ------ 5 files changed, 63 insertions(+), 31 deletions(-) diff --git a/R/join_keys-extract.R b/R/join_keys-extract.R index 011d287d3..eeeb0fe42 100644 --- a/R/join_keys-extract.R +++ b/R/join_keys-extract.R @@ -41,12 +41,12 @@ if ( !any( checkmate::test_string(i), - checkmate::test_integerish(i, len = 1), + checkmate::test_number(i), checkmate::test_logical(i, len = length(x)) && sum(j) == 1 ) || !any( checkmate::test_string(j), - checkmate::test_integerish(j, len = 1), + checkmate::test_number(j), checkmate::test_logical(j, len = length(x)) && sum(j) == 1 ) ) { @@ -56,6 +56,8 @@ call. = FALSE ) } + if (is.numeric(i)) i <- names(x)[i] + if (is.numeric(j)) j <- names(x)[j] subset_x <- update_keys_given_parents(x[union(i, j)]) return(subset_x[[i]][[j]]) @@ -68,13 +70,13 @@ checkmate::assert( combine = "or", checkmate::check_character(i), - checkmate::check_integerish(i), + checkmate::check_numeric(i), checkmate::check_logical(i) ) # Convert integer/logical index to named index - if (checkmate::test_integerish(i) || checkmate::test_logical(i)) { + if (checkmate::test_numeric(i) || checkmate::test_logical(i)) { i <- names(x)[i] } @@ -148,12 +150,12 @@ } else if ( !any( checkmate::test_string(i), - checkmate::test_integerish(i, len = 1), + checkmate::test_number(i), checkmate::test_logical(i, len = length(x)) && sum(j) == 1 ) || !any( checkmate::test_string(j), - checkmate::test_integerish(j, len = 1), + checkmate::test_number(j), checkmate::test_logical(j, len = length(x)) && sum(j) == 1 ) ) { @@ -193,11 +195,11 @@ checkmate::assert( combine = "or", checkmate::check_string(i), - checkmate::check_integerish(i, len = 1), + checkmate::check_number(i), checkmate::check_logical(i, len = length(x)) ) checkmate::assert_list(value, names = "named", types = "character", null.ok = TRUE) - if (checkmate::test_integerish(i) || checkmate::test_logical(i)) { + if (checkmate::test_numeric(i) || checkmate::test_logical(i)) { i <- names(x)[[i]] } @@ -229,17 +231,15 @@ # Safe to do as duplicated are the same norm_value[duplicated(names(norm_value))] <- NULL - # Remove elements with length == 0L - norm_value <- Filter(function(.x) length(.x) > 0, norm_value) + # Keep only elements with length > 0L + norm_value <- Filter(length, norm_value) # Remove classes to use list-based get/assign operations new_x <- unclass(x) # In case a pair is removed, also remove the symmetric pair removed_names <- setdiff(names(new_x[[i]]), names(norm_value)) - if (length(removed_names) > 0) { - for (.x in removed_names) new_x[[.x]][[i]] <- NULL - } + for (.x in removed_names) new_x[[.x]][[i]] <- NULL new_x[[i]] <- norm_value diff --git a/R/join_keys-names.R b/R/join_keys-names.R index 6503a5d5c..d9254e729 100644 --- a/R/join_keys-names.R +++ b/R/join_keys-names.R @@ -20,13 +20,8 @@ # changing name in the parents if (length(parent_list)) { names(parent_list)[names(parent_list) == old_name] <- new_name - parent_list <- lapply(parent_list, function(.x) { - if (identical(.x, old_name)) { - new_name - } else { - .x - } - }) + ind <- vapply(parent_list, identical, logical(1), old_name) + parent_list[ind] <- new_name attr(new_x, "__parents__") <- parent_list } } diff --git a/tests/testthat/test-join_keys-extract.R b/tests/testthat/test-join_keys-extract.R index abfc7a6d8..200dc5146 100644 --- a/tests/testthat/test-join_keys-extract.R +++ b/tests/testthat/test-join_keys-extract.R @@ -38,6 +38,18 @@ testthat::test_that("join_keys[i] returns join_keys object with keys for given i ) }) +testthat::test_that("join_keys[-i] drops keys for given index", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c") + ) + testthat::expect_identical( + my_keys[-3], + join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) + ) +}) + testthat::test_that("join_keys[i] returns join_keys object for given dataset including its parent", { my_keys <- join_keys( join_key("d1", "d1", "a"), @@ -119,6 +131,17 @@ testthat::test_that("join_keys[i,j] returns keys for given pair", { testthat::expect_identical(my_keys["b", "a"], c(`child-parent` = "child-parent")) }) +testthat::test_that("join_keys[i,j] returns keys for pair given by numeric indices", { + my_keys <- join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb"), + join_key("c", "c", "cc"), + join_key("b", "a", "child-parent"), + join_key("c", "a", "child-parent") + ) + testthat::expect_identical(my_keys[2, 1], c(`child-parent` = "child-parent")) +}) + testthat::test_that("join_keys[i,j] return NULL for given pair when no such key and no common parent", { my_keys <- join_keys( join_key("a", "a", "aa"), @@ -131,17 +154,17 @@ testthat::test_that("join_keys[i,j] return NULL for given pair when no such key }) testthat::test_that( - "join_keys[i,j] infer keys between children through unnamed foreign keys to parent (reglardless keys order)", + "join_keys[i,j] doesn't infer keys between children if they don't have common key to parent", { my_keys <- join_keys( join_key("a", "a", "aa"), join_key("b", "b", "bb"), join_key("c", "c", "cc"), - join_key("b", "a", sample(letters[1:5])), - join_key("c", "a", sample(letters[1:5])) + join_key("b", "a", c(child = "a1")), + join_key("c", "a", c(child = "a2")) ) parents(my_keys) <- list("b" = "a", "c" = "a") - testthat::expect_identical(my_keys["b", "c"], setNames(letters[1:5], letters[1:5])) + testthat::expect_null(my_keys["b", "c"]) } ) diff --git a/tests/testthat/test-join_keys-print.R b/tests/testthat/test-join_keys-print.R index 973dacc76..dd3c51e95 100644 --- a/tests/testthat/test-join_keys-print.R +++ b/tests/testthat/test-join_keys-print.R @@ -42,6 +42,27 @@ testthat::test_that("format.join_keys for parents", { ) }) +testthat::test_that("format.join_keys print inferred keys for children sharing parent", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "child-a"), + join_key("d3", "d1", "child-a") + ) + parents(my_keys) <- list("d2" = "d1", "d3" = "d1") + testthat::expect_identical( + format(my_keys), + paste( + "A join_keys object containing foreign keys between 3 datasets:", + "d1: [a]", " <-- d2: [child-a]", " <-- d3: [child-a]", + "d2: [b]", " --> d1: [child-a]", " --* (implicit via parent with): d3", + "d3: [c]", " --> d1: [child-a]", " --* (implicit via parent with): d2", + sep = "\n" + ) + ) +}) + testthat::test_that("print.join_keys produces output same as format", { my_keys <- join_keys( join_key("d1", "d1", "a"), diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 92f7ec729..0b303ba2a 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -150,10 +150,3 @@ testthat::test_that("join_keys()[]<-.join_keys with empty value in a named vecto testthat::expect_message(join_keys(jk)[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") testthat::expect_equal(jk[["d1"]][["d2"]], c(A = "B")) }) - - - -# ----------------------------------------------------------------------------- -# -# Setting names (names<-join_keys) -#